# 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{"Any/Moose.pm"} = <<'ANY_MOOSE';
  package Any::Moose;
  {
    $Any::Moose::VERSION = '0.18';
  }
  # ABSTRACT: use Moose or Mouse modules
  
  use 5.006_002;
  use strict;
  use warnings;
  
  # decide which backend to use
  our $PREFERRED;
  do {
      local $@;
      if ($ENV{ANY_MOOSE}) {
          $PREFERRED = $ENV{'ANY_MOOSE'};
          warn "ANY_MOOSE is not set to Moose or Mouse"
              unless $PREFERRED eq 'Moose'
                  || $PREFERRED eq 'Mouse';
  
          # if we die here, then perl gives "unknown error" which doesn't tell
          # you what the problem is at all. argh.
          if ($PREFERRED eq 'Moose' && !eval { require Moose }) {
              warn "\$ANY_MOOSE is set to Moose but we cannot load it";
          }
          elsif ($PREFERRED eq 'Mouse' && !eval { require Mouse }) {
              warn "\$ANY_MOOSE is set to Mouse but we cannot load it";
          }
      }
      elsif (_is_moose_loaded()) {
          $PREFERRED = 'Moose';
      }
      elsif (eval { require Mouse }) {
          $PREFERRED = 'Mouse';
      }
      elsif (eval { require Moose }) {
          $PREFERRED = 'Moose';
      }
      else {
          require Carp;
          warn "Unable to locate Mouse or Moose in INC";
      }
  };
  
  sub import {
      my $self = shift;
      my $pkg  = caller;
  
      # Any::Moose gives you strict and warnings
      strict->import;
      warnings->import;
  
      # first options are for Mo*se
      unshift @_, 'Moose' if !@_ || ref($_[0]);
  
      while (my $module = shift) {
          my $options = @_ && ref($_[0]) ? shift : [];
  
          $options = $self->_canonicalize_options(
              module  => $module,
              options => $options,
              package => $pkg,
          );
  
          $self->_install_module($options);
      }
  
      # give them any_moose too
      no strict 'refs';
      *{$pkg.'::any_moose'} = \&any_moose;
  }
  
  sub unimport {
      my $sel = shift;
      my $pkg = caller;
      my $module;
  
      if(@_){
          $module = any_moose(shift, $pkg);
      }
      else {
          $module = _backer_of($pkg);
      }
      my $e = do{
          local $@;
          eval "package $pkg;\n"
             . '$module->unimport();';
          $@;
     };
  
     if ($e) {
          require Carp;
          Carp::croak("Cannot unimport Any::Moose: $e");
     }
  
     return;
  }
  
  sub _backer_of {
      my $pkg = shift;
  
      if(exists $INC{'Mouse.pm'}){
          my $meta = Mouse::Util::get_metaclass_by_name($pkg);
          if ($meta) {
              return 'Mouse::Role' if $meta->isa('Mouse::Meta::Role');
              return 'Mouse'       if $meta->isa('Mouse::Meta::Class');
         }
      }
  
      if (_is_moose_loaded()) {
          my $meta = Class::MOP::get_metaclass_by_name($pkg);
          if ($meta) {
              return 'Moose::Role' if $meta->isa('Moose::Meta::Role');
              return 'Moose'       if $meta->isa('Moose::Meta::Class');
          }
      }
  
      return undef;
  }
  
  sub _canonicalize_options {
      my $self = shift;
      my %args = @_;
  
      my %options;
      if (ref($args{options}) eq 'HASH') {
          %options = %{ $args{options} };
      }
      else {
          %options = (
              imports => $args{options},
          );
      }
  
      $options{package} = $args{package};
      $options{module}  = any_moose($args{module}, $args{package});
  
      return \%options;
  }
  
  sub _install_module {
      my $self    = shift;
      my $options = shift;
  
      my $module = $options->{module};
      (my $file = $module . '.pm') =~ s{::}{/}g;
  
      require $file;
  
      my $e = do {
          local $@;
          eval "package $options->{package};\n"
             . '$module->import(@{ $options->{imports} });';
          $@;
      };
      if ($e) {
          require Carp;
          Carp::croak("Cannot import Any::Moose: $e");
      }
      return;
  }
  
  sub any_moose {
      my $fragment = _canonicalize_fragment(shift);
      my $package  = shift || caller;
  
      # Mouse gets first dibs because it doesn't introspect existing classes
  
      my $backer = _backer_of($package) || '';
  
      if ($backer =~ /^Mouse/) {
          $fragment =~ s/^Moose/Mouse/;
          return $fragment;
      }
  
      return $fragment if $backer =~ /^Moose/;
  
      $fragment =~ s/^Moose/Mouse/ if mouse_is_preferred();
      return $fragment;
  }
  
  for my $name (qw/
      load_class
      is_class_loaded
      class_of
      get_metaclass_by_name
      get_all_metaclass_instances
      get_all_metaclass_names
      load_first_existing_class
          /) {
      no strict 'refs';
      *{__PACKAGE__."::$name"} = moose_is_preferred()
          ? *{"Class::MOP::$name"}
          : *{"Mouse::Util::$name"};
  }
  
  sub moose_is_preferred { $PREFERRED eq 'Moose' }
  sub mouse_is_preferred { $PREFERRED eq 'Mouse' }
  
  sub _is_moose_loaded { exists $INC{'Moose.pm'} }
  
  sub is_moose_loaded {
      require Carp;
      Carp::carp("Any::Moose::is_moose_loaded is deprecated. Please use Any::Moose::moose_is_preferred instead");
      goto \&_is_moose_loaded;
  }
  
  sub _canonicalize_fragment {
      my $fragment = shift;
  
      return 'Moose' if !$fragment;
  
      # any_moose("X::Types") -> any_moose("MooseX::Types")
      $fragment =~ s/^X::/MooseX::/;
  
      # any_moose("::Util") -> any_moose("Moose::Util")
      $fragment =~ s/^::/Moose::/;
  
      # any_moose("Mouse::Util") -> any_moose("Moose::Util")
      $fragment =~ s/^Mouse(X?)\b/Moose$1/;
  
      # any_moose("Util") -> any_moose("Moose::Util")
      $fragment =~ s/^(?!Moose)/Moose::/;
  
      return $fragment;
  }
  
  1;
  
  
  =pod
  
  =head1 NAME
  
  Any::Moose - use Moose or Mouse modules
  
  =head1 VERSION
  
  version 0.18
  
  =head1 SYNOPSIS
  
  =head2 BASIC
  
      package Class;
  
      # uses Moose if it's loaded or demanded, Mouse otherwise
      use Any::Moose;
  
      # cleans the namespace up
      no Any::Moose;
  
  =head2 OTHER MODULES
  
      package Other::Class;
      use Any::Moose;
  
      # uses Moose::Util::TypeConstraints if the class has loaded Moose,
      # Mouse::Util::TypeConstraints otherwise.
      use Any::Moose '::Util::TypeConstraints';
  
  =head2 ROLES
  
      package My::Sorter;
      use Any::Moose 'Role';
  
      requires 'cmp';
  
  =head2 COMPLEX USAGE
  
      package My::Meta::Class;
      use Any::Moose;
  
      # uses subtype from Moose::Util::TypeConstraints if the class loaded Moose,
      # subtype from Mouse::Util::TypeConstraints otherwise.
      # similarly for Mo*se::Util's does_role
      use Any::Moose (
          '::Util::TypeConstraints' => ['subtype'],
          '::Util' => ['does_role'],
      );
  
      # uses MouseX::Types or MooseX::Types
      use Any::Moose 'X::Types';
  
      # gives you the right class name depending on which Mo*se was loaded
      extends any_moose('::Meta::Class');
  
  =head1 DESCRIPTION
  
  Though we recommend that people generally use L<Moose>, we accept that Moose
  cannot yet be used for everything everywhere. People generally like the Moose
  sugar, so many people use L<Mouse>, a lightweight replacement for parts of
  Moose.
  
  Because Mouse strives for compatibility with Moose, it's easy to substitute one
  for the other. This module facilitates that substitution. By default, Mouse
  will be provided to libraries, unless Moose is already loaded -or-
  explicitly requested by the end-user. The end-user can force the decision
  of which backend to use by setting the environment variable C<ANY_MOOSE> to
  be C<Moose> or C<Mouse>.
  
  Note that the decision of which backend to use is made only once, so that if
  Any-Moose picks Mouse, then a third-party library loads Moose, anything else
  that uses Any-Moose will continue to pick Mouse.
  
  So, if you have to use L<Mouse>, please be considerate to the Moose fanboys
  (like myself!) and use L<Any-Moose> instead. C<:)>
  
  =head1 SEE ALSO
  
  L<Moose>
  
  L<Mouse>
  
  L<Squirrel> - a deprecated first-stab at Any-Moose-like logic. Its biggest
  fault was in making the decision of which backend to use every time it was
  used, rather than just once.
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Shawn M Moore <sartak@gmail.com>
  
  =item *
  
  Florian Ragwitz <rafl@debian.org>
  
  =item *
  
  Stevan Little <stevan@iinteractive.com>
  
  =item *
  
  Tokuhiro Matsuno <tokuhirom@gmail.com>
  
  =item *
  
  Goro Fuji <gfuji@cpan.org>
  
  =item *
  
  Ricardo Signes <rjbs@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Best Practical Solutions.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
ANY_MOOSE

$fatpacked{"Bundle/LWP.pm"} = <<'BUNDLE_LWP';
  package Bundle::LWP;
  
  $VERSION = "5.835";
  
  1;
  
  __END__
  
  =head1 NAME
  
  Bundle::LWP - install all libwww-perl related modules
  
  =head1 SYNOPSIS
  
   perl -MCPAN -e 'install Bundle::LWP'
  
  =head1 CONTENTS
  
  MIME::Base64       - Used in authentication headers
  
  Digest::MD5        - Needed to do Digest authentication
  
  URI 1.10           - There are URIs everywhere
  
  Net::FTP 2.58      - If you want ftp://-support
  
  HTML::Tagset       - Needed by HTML::Parser
  
  HTML::Parser       - Needed by HTML::HeadParser
  
  HTML::HeadParser   - To get the correct $res->base
  
  LWP                - The reason why you need the modules above
  
  =head1 DESCRIPTION
  
  This bundle defines all prerequisite modules for libwww-perl.  Bundles
  have special meaning for the CPAN module.  When you install the bundle
  module all modules mentioned in L</CONTENTS> will be installed
  instead.
  
  =head1 SEE ALSO
  
  L<CPAN/Bundles>
BUNDLE_LWP

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

$fatpacked{"Class/Load.pm"} = <<'CLASS_LOAD';
  package Class::Load;
  {
    $Class::Load::VERSION = '0.12';
  }
  use strict;
  use warnings;
  use base 'Exporter';
  use Data::OptList 'mkopt';
  use Module::Runtime qw(check_module_name module_notional_filename
                         require_module use_module);
  use Package::Stash;
  use Try::Tiny;
  
  our $IMPLEMENTATION;
  
  BEGIN {
      $IMPLEMENTATION = $ENV{CLASS_LOAD_IMPLEMENTATION}
          if exists $ENV{CLASS_LOAD_IMPLEMENTATION};
  
      my $err;
      if ($IMPLEMENTATION) {
          if (!try { require_module("Class::Load::$IMPLEMENTATION") }) {
              require Carp;
              Carp::croak("Could not load Class::Load::$IMPLEMENTATION: $@");
          }
      }
      else {
          for my $impl ('XS', 'PP') {
              if (try { require_module("Class::Load::$impl") }) {
                  $IMPLEMENTATION = $impl;
                  last;
              }
              else {
                  $err .= $@;
              }
          }
      }
  
      if (!$IMPLEMENTATION) {
          require Carp;
          Carp::croak("Could not find a suitable Class::Load implementation: $err");
      }
  
      my $impl = "Class::Load::$IMPLEMENTATION";
      my $stash = Package::Stash->new(__PACKAGE__);
      $stash->add_symbol('&is_class_loaded' => $impl->can('is_class_loaded'));
  
      sub _implementation {
          return $IMPLEMENTATION;
      }
  }
  
  our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/;
  our %EXPORT_TAGS = (
      all => \@EXPORT_OK,
  );
  
  our $ERROR;
  
  sub load_class {
      my $class   = shift;
      my $options = shift;
  
      my ($res, $e) = try_load_class($class, $options);
      return 1 if $res;
  
      _croak($e);
  }
  
  sub load_first_existing_class {
      my $classes = Data::OptList::mkopt(\@_)
          or return;
  
      foreach my $class (@{$classes}) {
          check_module_name($class->[0]);
      }
  
      for my $class (@{$classes}) {
          my ($name, $options) = @{$class};
  
          # We need to be careful not to pass an undef $options to this sub,
          # since the XS version will blow up if that happens.
          return $name if is_class_loaded($name, ($options ? $options : ()));
  
          my ($res, $e) = try_load_class($name, $options);
  
          return $name if $res;
  
          my $file = module_notional_filename($name);
  
          next if $e =~ /^Can't locate \Q$file\E in \@INC/;
          next
              if $options
                  && defined $options->{-version}
                  && $e =~ _version_fail_re($name, $options->{-version});
  
          _croak("Couldn't load class ($name) because: $e");
      }
  
      my @list = map {
          $_->[0]
              . ( $_->[1] && defined $_->[1]{-version}
              ? " (version >= $_->[1]{-version})"
              : q{} )
      } @{$classes};
  
      my $err
          .= q{Can't locate }
          . _or_list(@list)
          . " in \@INC (\@INC contains: @INC).";
      _croak($err);
  }
  
  sub _version_fail_re {
      my $name = shift;
      my $vers = shift;
  
      return qr/\Q$name\E version \Q$vers\E required--this is only version/;
  }
  
  sub _or_list {
      return $_[0] if @_ == 1;
  
      return join ' or ', @_ if @_ ==2;
  
      my $last = pop;
  
      my $list = join ', ', @_;
      $list .= ', or ' . $last;
  
      return $list;
  }
  
  sub load_optional_class {
      my $class   = shift;
      my $options = shift;
  
      check_module_name($class);
  
      my ($res, $e) = try_load_class($class, $options);
      return 1 if $res;
  
      return 0
          if $options
              && defined $options->{-version}
              && $e =~ _version_fail_re($class, $options->{-version});
  
      # My testing says that if its in INC, the file definitely exists
      # on disk. In all versions of Perl. The value isn't reliable,
      # but it existing is.
      my $file = module_notional_filename($class);
      return 0 unless exists $INC{$file};
  
      _croak($ERROR);
  }
  
  sub try_load_class {
      my $class   = shift;
      my $options = shift;
  
      check_module_name($class);
  
      local $@;
      undef $ERROR;
  
      if (is_class_loaded($class)) {
          # We need to check this here rather than in is_class_loaded() because
          # we want to return the error message for a failed version check, but
          # is_class_loaded just returns true/false.
          return 1 unless $options && defined $options->{-version};
          return try {
              $class->VERSION($options->{-version});
              1;
          }
          catch {
              _error($_);
          };
      }
  
      my $file = module_notional_filename($class);
      # This says "our diagnostics of the package
      # say perl's INC status about the file being loaded are
      # wrong", so we delete it from %INC, so when we call require(),
      # perl will *actually* try reloading the file.
      #
      # If the file is already in %INC, it won't retry,
      # And on 5.8, it won't fail either!
      #
      # The extra benefit of this trick, is it helps even on
      # 5.10, as instead of dying with "Compilation failed",
      # it will die with the actual error, and thats a win-win.
      delete $INC{$file};
      return try {
          local $SIG{__DIE__} = 'DEFAULT';
          if ($options && defined $options->{-version}) {
              use_module($class, $options->{-version});
          }
          else {
              require_module($class);
          }
          1;
      }
      catch {
          _error($_);
      };
  }
  
  sub _error {
      $ERROR = shift;
      return 0 unless wantarray;
      return 0, $ERROR;
  }
  
  sub _croak {
      require Carp;
      local $Carp::CarpLevel = $Carp::CarpLevel + 1;
      Carp::croak(shift);
  }
  
  1;
  
  # ABSTRACT: a working (require "Class::Name") and more
  
  
  
  =pod
  
  =head1 NAME
  
  Class::Load - a working (require "Class::Name") and more
  
  =head1 VERSION
  
  version 0.12
  
  =head1 SYNOPSIS
  
      use Class::Load ':all';
  
      try_load_class('Class::Name')
          or plan skip_all => "Class::Name required to run these tests";
  
      load_class('Class::Name');
  
      is_class_loaded('Class::Name');
  
      my $baseclass = load_optional_class('Class::Name::MightExist')
          ? 'Class::Name::MightExist'
          : 'Class::Name::Default';
  
  =head1 DESCRIPTION
  
  C<require EXPR> only accepts C<Class/Name.pm> style module names, not
  C<Class::Name>. How frustrating! For that, we provide
  C<load_class 'Class::Name'>.
  
  It's often useful to test whether a module can be loaded, instead of throwing
  an error when it's not available. For that, we provide
  C<try_load_class 'Class::Name'>.
  
  Finally, sometimes we need to know whether a particular class has been loaded.
  Asking C<%INC> is an option, but that will miss inner packages and any class
  for which the filename does not correspond to the package name. For that, we
  provide C<is_class_loaded 'Class::Name'>.
  
  =head1 FUNCTIONS
  
  =head2 load_class Class::Name, \%options
  
  C<load_class> will load C<Class::Name> or throw an error, much like C<require>.
  
  If C<Class::Name> is already loaded (checked with C<is_class_loaded>) then it
  will not try to load the class. This is useful when you have inner packages
  which C<require> does not check.
  
  The C<%options> hash currently accepts one key, C<-version>. If you specify a
  version, then this subroutine will call C<< Class::Name->VERSION(
  $options{-version} ) >> internally, which will throw an error if the class's
  version is not equal to or greater than the version you requested.
  
  =head2 try_load_class Class::Name, \%options -> (0|1, error message)
  
  Returns 1 if the class was loaded, 0 if it was not. If the class was not
  loaded, the error will be returned as a second return value in list context.
  
  Again, if C<Class::Name> is already loaded (checked with C<is_class_loaded>)
  then it will not try to load the class. This is useful when you have inner
  packages which C<require> does not check.
  
  Like C<load_class>, you can pass a C<-version> in C<%options>. If the version
  is not sufficient, then this subroutine will return false.
  
  =head2 is_class_loaded Class::Name, \%options -> 0|1
  
  This uses a number of heuristics to determine if the class C<Class::Name> is
  loaded. There heuristics were taken from L<Class::MOP>'s old pure-perl
  implementation.
  
  Like C<load_class>, you can pass a C<-version> in C<%options>. If the version
  is not sufficient, then this subroutine will return false.
  
  =head2 load_first_existing_class Class::Name, \%options, ...
  
  This attempts to load the first loadable class in the list of classes
  given. Each class name can be followed by an options hash reference.
  
  If any one of the classes loads and passes the optional version check, that
  class name will be returned. If I<none> of the classes can be loaded (or none
  pass their version check), then an error will be thrown.
  
  If, when attempting to load a class, it fails to load because of a syntax
  error, then an error will be thrown immediately.
  
  =head2 load_optional_class Class::Name, \%options -> 0|1
  
  C<load_optional_class> is a lot like C<try_load_class>, but also a lot like
  C<load_class>.
  
  If the class exists, and it works, then it will return 1. If you specify a
  version in C<%options>, then the version check must succeed or it will return
  0.
  
  If the class doesn't exist, and it appears to not exist on disk either, it
  will return 0.
  
  If the class exists on disk, but loading from disk results in an error
  ( i.e.: a syntax error ), then it will C<croak> with that error.
  
  This is useful for using if you want a fallback module system, i.e.:
  
      my $class = load_optional_class($foo) ? $foo : $default;
  
  That way, if $foo does exist, but can't be loaded due to error, you won't
  get the behaviour of it simply not existing.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<http://blog.fox.geek.nz/2010/11/searching-design-spec-for-ultimate.html>
  
  This blog post is a good overview of the current state of the existing modules
  for loading other modules in various ways.
  
  =item L<http://blog.fox.geek.nz/2010/11/handling-optional-requirements-with.html>
  
  This blog post describes how to handle optional modules with L<Class::Load>.
  
  =item L<http://d.hatena.ne.jp/tokuhirom/20110202/1296598578>
  
  This Japanese blog post describes why L<DBIx::Skinny> now uses L<Class::Load>
  over its competitors.
  
  =item L<Moose>, L<Jifty>, L<Prophet>, etc
  
  This module was designed to be used anywhere you have
  C<if (eval "require $module"; 1)>, which occurs in many large projects.
  
  =back
  
  =head1 AUTHOR
  
  Shawn M Moore <sartak at bestpractical.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Shawn M Moore.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
CLASS_LOAD

$fatpacked{"Class/Load/PP.pm"} = <<'CLASS_LOAD_PP';
  package Class::Load::PP;
  {
    $Class::Load::PP::VERSION = '0.12';
  }
  
  use strict;
  use warnings;
  use Module::Runtime 'is_module_name';
  use Package::Stash;
  use Scalar::Util 'blessed', 'reftype';
  use Try::Tiny;
  
  sub is_class_loaded {
      my $class   = shift;
      my $options = shift;
  
      my $loaded = _is_class_loaded($class);
  
      return $loaded if ! $loaded;
      return $loaded unless $options && $options->{-version};
  
      return try {
          $class->VERSION($options->{-version});
          1;
      }
      catch {
          0;
      };
  }
  
  sub _is_class_loaded {
      my $class = shift;
  
      return 0 unless is_module_name($class);
  
      my $stash = Package::Stash->new($class);
  
      if ($stash->has_symbol('$VERSION')) {
          my $version = ${ $stash->get_symbol('$VERSION') };
          if (defined $version) {
              return 1 if ! ref $version;
              # Sometimes $VERSION ends up as a reference to undef (weird)
              return 1 if ref $version && reftype $version eq 'SCALAR' && defined ${$version};
              # a version object
              return 1 if blessed $version;
          }
      }
  
      if ($stash->has_symbol('@ISA')) {
          return 1 if @{ $stash->get_symbol('@ISA') };
      }
  
      # check for any method
      return 1 if $stash->list_all_symbols('CODE');
  
      # fail
      return 0;
  }
  
  1;
CLASS_LOAD_PP

$fatpacked{"Data/Dumper/Concise.pm"} = <<'DATA_DUMPER_CONCISE';
  package Data::Dumper::Concise;
  
  use 5.006;
  
  $VERSION = '1.200';
  
  require Exporter;
  require Data::Dumper;
  
  BEGIN { @ISA = qw(Exporter) }
  
  @EXPORT = qw(Dumper);
  
  sub Dumper {
    my $dd = Data::Dumper->new([]);
    $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
    return $dd unless @_;
    return $dd->Values([ @_ ])->Dump;
  }
  
  =head1 NAME
  
  Data::Dumper::Concise - Less indentation and newlines plus sub deparsing
  
  =head1 SYNOPSIS
  
    use Data::Dumper::Concise;
  
    warn Dumper($var);
  
  is equivalent to:
  
    use Data::Dumper;
    {
      local $Data::Dumper::Terse = 1;
      local $Data::Dumper::Indent = 1;
      local $Data::Dumper::Useqq = 1;
      local $Data::Dumper::Deparse = 1;
      local $Data::Dumper::Quotekeys = 0;
      local $Data::Dumper::Sortkeys = 1;
      warn Dumper($var);
    }
  
  whereas
  
    my $dd = Dumper;
  
  is equivalent to:
  
    my $dd = Data::Dumper->new([])
                         ->Terse(1)
                         ->Indent(1)
                         ->Useqq(1)
                         ->Deparse(1)
                         ->Quotekeys(0)
                         ->Sortkeys(1);
  
  So for the structure:
  
    { foo => "bar\nbaz", quux => sub { "fleem" } };
  
  Data::Dumper::Concise will give you:
  
    {
      foo => "bar\nbaz",
      quux => sub {
          use warnings;
          use strict 'refs';
          'fleem';
      }
    }
  
  instead of the default Data::Dumper output:
  
    $VAR1 = {
    	'quux' => sub { "DUMMY" },
    	'foo' => 'bar
    baz'
    };
  
  (note the tab indentation, oh joy ...)
  
  =head1 DESCRIPTION
  
  This module always exports a single function, Dumper, which can be called
  with an array of values to dump those values or with no arguments to
  return the Data::Dumper object it's created. Note that this means that
  
    Dumper @list
  
  will probably not do what you wanted when @list is empty. In this case use
  
    Dumper \@list
  
  instead.
  
  It exists, fundamentally, as a convenient way to reproduce a set of Dumper
  options that we've found ourselves using across large numbers of applications,
  primarily for debugging output.
  
  The principle guiding theme is "all the concision you can get while still
  having a useful dump and not doing anything cleverer than setting Data::Dumper
  options" - it's been pointed out to us that Data::Dump::Streamer can produce
  shorter output with less lines of code. We know. This is simpler and we've
  never seen it segfault. But for complex/weird structures, it generally rocks.
  You should use it as well, when Concise is underkill. We do.
  
  Why is deparsing on when the aim is concision? Because you often want to know
  what subroutine refs you have when debugging and because if you were planning
  to eval this back in you probably wanted to remove subrefs first and add them
  back in a custom way anyway. Note that this -does- force using the pure perl
  Dumper rather than the XS one, but I've never in my life seen Data::Dumper
  show up in a profile so "who cares?".
  
  =head1 BUT BUT BUT ...
  
  Yes, we know. Consider this module in the ::Tiny spirit and feel free to
  write a Data::Dumper::Concise::ButWithExtraTwiddlyBits if it makes you
  happy. Then tell us so we can add it to the see also section.
  
  =head1 SUGARY SYNTAX
  
  This package also provides:
  
  L<Data::Dumper::Concise::Sugar> - provides Dwarn and DwarnS convenience functions
  
  L<Devel::Dwarn> - shorter form for Data::Dumper::Concise::Sugar
  
  =head1 SEE ALSO
  
  We use for some purposes, and dearly love, the following alternatives:
  
  L<Data::Dump> - prettiness oriented but not amazingly configurable
  
  L<Data::Dump::Streamer> - brilliant. beautiful. insane. extensive. excessive. try it.
  
  L<JSON::XS> - no, really. If it's just plain data, JSON is a great option.
  
  =head1 AUTHOR
  
  mst - Matt S. Trout <mst@shadowcat.co.uk>
  
  =head1 CONTRIBUTORS
  
  frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2009 the Data::Dumper::Concise L</AUTHOR> and L</CONTRIBUTORS>
  as listed above.
  
  =head1 LICENSE
  
  This library is free software and may be distributed under the same terms
  as perl itself.
  
  =cut
  
  1;
DATA_DUMPER_CONCISE

$fatpacked{"Data/Dumper/Concise/Sugar.pm"} = <<'DATA_DUMPER_CONCISE_SUGAR';
  package Data::Dumper::Concise::Sugar;
  
  use 5.006;
  
  use Exporter ();
  use Data::Dumper::Concise ();
  
  BEGIN { @ISA = qw(Exporter) }
  
  @EXPORT = qw(Dwarn DwarnS);
  
  sub Dwarn { warn Data::Dumper::Concise::Dumper @_; @_ }
  
  sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
  
  =head1 NAME
  
  Data::Dumper::Concise::Sugar - return Dwarn @return_value
  
  =head1 SYNOPSIS
  
    use Data::Dumper::Concise::Sugar;
  
    return Dwarn some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn Dumper(@return);
    return @return;
  
  but shorter. If you need to force scalar context on the value,
  
    use Data::Dumper::Concise::Sugar;
  
    return DwarnS some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my $return = some_call(...);
    warn Dumper($return);
    return $return;
  
  Another trick that is extremely useful when doing method chaining is the
  following:
  
    my $foo = Bar->new;
    $foo->bar->baz->Data::Dumper::Concise::Sugar::DwarnS->biff;
  
  which is the same as:
  
    my $foo = Bar->new;
    (DwarnS $foo->bar->baz)->biff;
  
  =head1 DESCRIPTION
  
    use Data::Dumper::Concise::Sugar;
  
  will import Dwarn and DwarnS into your namespace. Using L<Exporter>, so see
  its docs for ways to make it do something else.
  
  =head2 Dwarn
  
    sub Dwarn { warn Data::Dumper::Concise::Dumper @_; @_ }
  
  =head3 DwarnS
  
    sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
  
  =head1 SEE ALSO
  
  You probably want L<Devel::Dwarn>, it's the shorter name for this module.
  
  =cut
  
  1;
DATA_DUMPER_CONCISE_SUGAR

$fatpacked{"Data/OptList.pm"} = <<'DATA_OPTLIST';
  use strict;
  use warnings;
  package Data::OptList;
  BEGIN {
    $Data::OptList::VERSION = '0.107';
  }
  # ABSTRACT: parse and validate simple name/value option pairs
  
  use List::Util ();
  use Params::Util ();
  use Sub::Install 0.921 ();
  
  
  my %test_for;
  BEGIN {
    %test_for = (
      CODE   => \&Params::Util::_CODELIKE,  ## no critic
      HASH   => \&Params::Util::_HASHLIKE,  ## no critic
      ARRAY  => \&Params::Util::_ARRAYLIKE, ## no critic
      SCALAR => \&Params::Util::_SCALAR0,   ## no critic
    );
  }
  
  sub __is_a {
    my ($got, $expected) = @_;
  
    return List::Util::first { __is_a($got, $_) } @$expected if ref $expected;
  
    return defined (
      exists($test_for{$expected})
      ? $test_for{$expected}->($got)
      : Params::Util::_INSTANCE($got, $expected) ## no critic
    );
  }
  
  sub mkopt {
    my ($opt_list) = shift;
  
    my ($moniker, $require_unique, $must_be); # the old positional args
    my $name_test;
  
    if (@_ == 1 and Params::Util::_HASHLIKE($_[0])) {
      my $arg = $_[0];
      ($moniker, $require_unique, $must_be, $name_test)
        = @$arg{ qw(moniker require_unique must_be name_test) };
    } else {
      ($moniker, $require_unique, $must_be) = @_;
    }
  
    $moniker = 'unnamed' unless defined $moniker;
  
    return [] unless $opt_list;
  
    $name_test ||= sub { ! ref $_[0] };
  
    $opt_list = [
      map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list
    ] if ref $opt_list eq 'HASH';
  
    my @return;
    my %seen;
  
    for (my $i = 0; $i < @$opt_list; $i++) { ## no critic
      my $name = $opt_list->[$i];
      my $value;
  
      if ($require_unique) {
        Carp::croak "multiple definitions provided for $name" if $seen{$name}++;
      }
  
      if    ($i == $#$opt_list)               { $value = undef;            }
      elsif (not defined $opt_list->[$i+1])   { $value = undef; $i++       }
      elsif ($name_test->($opt_list->[$i+1])) { $value = undef;            }
      else                                    { $value = $opt_list->[++$i] }
  
      if ($must_be and defined $value) {
        unless (__is_a($value, $must_be)) {
          my $ref = ref $value;
          Carp::croak "$ref-ref values are not valid in $moniker opt list";
        }
      }
  
      push @return, [ $name => $value ];
    }
  
    return \@return;
  }
  
  
  sub mkopt_hash {
    my ($opt_list, $moniker, $must_be) = @_;
    return {} unless $opt_list;
  
    $opt_list = mkopt($opt_list, $moniker, 1, $must_be);
    my %hash = map { $_->[0] => $_->[1] } @$opt_list;
    return \%hash;
  }
  
  
  BEGIN {
    *import = Sub::Install::exporter {
      exports => [qw(mkopt mkopt_hash)],
    };
  }
  
  1;
  
  __END__
  =pod
  
  =head1 NAME
  
  Data::OptList - parse and validate simple name/value option pairs
  
  =head1 VERSION
  
  version 0.107
  
  =head1 SYNOPSIS
  
    use Data::OptList;
  
    my $options = Data::OptList::mkopt([
      qw(key1 key2 key3 key4),
      key5 => { ... },
      key6 => [ ... ],
      key7 => sub { ... },
      key8 => { ... },
      key8 => [ ... ],
    ]);
  
  ...is the same thing, more or less, as:
  
    my $options = [
      [ key1 => undef,        ],
      [ key2 => undef,        ],
      [ key3 => undef,        ],
      [ key4 => undef,        ],
      [ key5 => { ... },      ],
      [ key6 => [ ... ],      ],
      [ key7 => sub { ... },  ],
      [ key8 => { ... },      ],
      [ key8 => [ ... ],      ],
    ]);
  
  =head1 DESCRIPTION
  
  Hashes are great for storing named data, but if you want more than one entry
  for a name, you have to use a list of pairs.  Even then, this is really boring
  to write:
  
    $values = [
      foo => undef,
      bar => undef,
      baz => undef,
      xyz => { ... },
    ];
  
  Just look at all those undefs!  Don't worry, we can get rid of those:
  
    $values = [
      map { $_ => undef } qw(foo bar baz),
      xyz => { ... },
    ];
  
  Aaaauuugh!  We've saved a little typing, but now it requires thought to read,
  and thinking is even worse than typing... and it's got a bug!  It looked right,
  didn't it?  Well, the C<< xyz => { ... } >> gets consumed by the map, and we
  don't get the data we wanted.
  
  With Data::OptList, you can do this instead:
  
    $values = Data::OptList::mkopt([
      qw(foo bar baz),
      xyz => { ... },
    ]);
  
  This works by assuming that any defined scalar is a name and any reference
  following a name is its value.
  
  =head1 FUNCTIONS
  
  =head2 mkopt
  
    my $opt_list = Data::OptList::mkopt($input, \%arg);
  
  Valid arguments are:
  
    moniker        - a word used in errors to describe the opt list; encouraged
    require_unique - if true, no name may appear more than once
    must_be        - types to which opt list values are limited (described below)
    name_test      - a coderef used to test whether a value can be a name
                     (described below, but you probably don't want this)
  
  This produces an array of arrays; the inner arrays are name/value pairs.
  Values will be either "undef" or a reference.
  
  Positional parameters may be used for compability with the old C<mkopt>
  interface:
  
    my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be);
  
  Valid values for C<$input>:
  
   undef    -> []
   hashref  -> [ [ key1 => value1 ] ... ] # non-ref values become undef
   arrayref -> every name followed by a non-name becomes a pair: [ name => ref ]
               every name followed by undef becomes a pair: [ name => undef ]
               otherwise, it becomes [ name => undef ] like so:
               [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ]
  
  By default, a I<name> is any defined non-reference.  The C<name_test> parameter
  can be a code ref that tests whether the argument passed it is a name or not.
  This should be used rarely.  Interactions between C<require_unique> and
  C<name_test> are not yet particularly elegant, as C<require_unique> just tests
  string equality.  B<This may change.>
  
  The C<must_be> parameter is either a scalar or array of scalars; it defines
  what kind(s) of refs may be values.  If an invalid value is found, an exception
  is thrown.  If no value is passed for this argument, any reference is valid.
  If C<must_be> specifies that values must be CODE, HASH, ARRAY, or SCALAR, then
  Params::Util is used to check whether the given value can provide that
  interface.  Otherwise, it checks that the given value is an object of the kind.
  
  In other words:
  
    [ qw(SCALAR HASH Object::Known) ]
  
  Means:
  
    _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known')
  
  =head2 mkopt_hash
  
    my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be);
  
  Given valid C<L</mkopt>> input, this routine returns a reference to a hash.  It
  will throw an exception if any name has more than one value.
  
  =head1 EXPORTS
  
  Both C<mkopt> and C<mkopt_hash> may be exported on request.
  
  =head1 AUTHOR
  
  Ricardo Signes <rjbs@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2006 by Ricardo Signes.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
DATA_OPTLIST

$fatpacked{"Devel/Dwarn.pm"} = <<'DEVEL_DWARN';
  package Devel::Dwarn;
  
  use Data::Dumper::Concise::Sugar;
  
  sub import {
    Data::Dumper::Concise::Sugar->export_to_level(1, @_);
  }
  
  =head1 NAME
  
  Devel::Dwarn - return Dwarn @return_value
  
  =head1 SYNOPSIS
  
    use Devel::Dwarn;
  
    return Dwarn some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my @return = some_call(...);
    warn Dumper(@return);
    return @return;
  
  but shorter. If you need to force scalar context on the value,
  
    use Devel::Dwarn;
  
    return DwarnS some_call(...)
  
  is equivalent to:
  
    use Data::Dumper::Concise;
  
    my $return = some_call(...);
    warn Dumper($return);
    return $return;
  
  Another trick that is extremely useful when doing method chaining is the
  following:
  
    my $foo = Bar->new;
    $foo->bar->baz->Devel::Dwarn::DwarnS->biff;
  
  which is the same as:
  
    my $foo = Bar->new;
    (DwarnS $foo->bar->baz)->biff;
  
  =head1 SEE ALSO
  
  This module is really just a shortcut for L<Data::Dumper::Concise::Sugar>, check
  it out for more complete documentation.
  
  =cut
  
  1;
DEVEL_DWARN

$fatpacked{"Dist/Surveyor.pm"} = <<'DIST_SURVEYOR';
  package Dist::Surveyor;
  
  =head1 NAME
  
  Dist::Surveyor - Survey installed modules and determine the specific distribution versions they came from
  
  =head1 SYNOPSIS
  
  See L<dist_surveyor> for documentation.
  
  =cut
  
  use strict;
  use warnings;
  
  use version;
  use autodie;
  use Carp;
  use Compress::Zlib;
  use Config;
  use CPAN::DistnameInfo;
  use Data::Dumper::Concise;
  use DBI qw(looks_like_number);
  use Digest::SHA qw(sha1_base64);
  use Fcntl qw(:DEFAULT :flock);
  use File::Fetch;
  use File::Basename;
  use File::Find;
  use File::Path;
  use File::Slurp;
  use File::Spec;
  use File::Spec::Unix;
  use Getopt::Long;
  use List::Util qw(max sum);
  use LWP::Simple;
  use Memoize;
  use MetaCPAN::API 0.32;
  use DB_File;
  use MLDBM qw(DB_File Storable);
  use Module::CoreList;
  use Module::Metadata;
  use Storable qw(nfreeze);
  use Try::Tiny;
  use URI;
  
  use constant PROGNAME => 'dist_surveyor';
  use constant ON_WIN32 => $^O eq 'MSWin32';
  use constant ON_VMS   => $^O eq 'VMS';
  
  GetOptions(
      'match=s' => \my $opt_match,
      'v|verbose!' => \my $opt_verbose,
      'd|debug!' => \my $opt_debug,
      # target perl version, re core modules
      'perlver=s' => \my $opt_perlver,
      # include old dists that have remnant/orphaned modules installed
      'remnants!' => \my $opt_remnants,
      # don't use a persistent cache
      'uncached!' => \my $opt_uncached,
      'makecpan=s' => \my $opt_makecpan,
      # e.g., 'download_url author'
      'output=s' => \(my $opt_output ||= 'url'),
      # e.g., 'some-command --foo --file %s --authorid %s'
      'format=s' => \my $opt_format,
  ) or exit 1;
  
  $opt_verbose++ if $opt_debug;
  $opt_perlver = version->parse($opt_perlver || $])->numify;
  
  my $major_error_count = 0; # exit status
  
  # We have to limit the number of results when using MetaCPAN::API.
  # We can'r make it too large as it hurts the server (it preallocates)
  # but need to make it large enough for worst case distros (eg eBay-API).
  # TODO: switching to the ElasticSearch module, with cursor support, will
  # probably avoid the need for this. Else we could dynamically adjust.
  my $metacpan_size = 1500;
  my $metacpan_calls = 0;
  my $metacpan_api ||= MetaCPAN::API->new(
      ua_args => [ agent => $0 ],
  );
  
  
  # caching via persistent memoize
  
  my $db_generation = 1; # XXX increment on incompatible change
  my $memoize_file = PROGNAME."-$db_generation.db";
  my %memoize_cache;
  if (not $opt_uncached) {
      # XXX no need for MLDBM now? Could just use DB_File
      my $db = tie %memoize_cache => 'MLDBM', $memoize_file, O_CREAT|O_RDWR, 0640
          or die "Unable to use persistent cache: $!";
      # XXX this locking is flawed but good enough for my needs
      # http://search.cpan.org/~pmqs/DB_File-1.824/DB_File.pm#HINTS_AND_TIPS
      my $fd = $db->fd;
      open(DB_FH, "+<&=$fd") || die "dup $!";
      flock (DB_FH, LOCK_EX) || die "flock: $!";
  }
  my %memoize_subs = (
      get_candidate_cpan_dist_releases => { generation => 1 },
      get_module_versions_in_release   => { generation => 1 },
  );
  for my $subname (keys %memoize_subs) {
      my %memoize_args = %{$memoize_subs{$subname}};
      my $generation = delete $memoize_args{generation} || 1;
      $memoize_args{SCALAR_CACHE} = [ HASH => \%memoize_cache ];
      $memoize_args{LIST_CACHE}   = 'FAULT';
      # TODO use faster normalizer for subs that don't get refs
      # not needed because we don't pass refs
      #$memoize_args{NORMALIZER} = sub { $Storable::canonical = 1; sha1_base64(nfreeze([ $subname, $generation, wantarray, @_ ])) }
      memoize($subname, %memoize_args);
  }
  
  
  
  # for distros with names that don't match the principle module name
  # yet the principle module version always matches the distro
  # Used for perllocal.pod lookups and for picking 'token packages' for minicpan
  # # XXX should be automated lookup rather than hardcoded (else remove perllocal.pod parsing)
  my %distro_key_mod_names = (
      'PathTools' => 'File::Spec',
      'Template-Toolkit' => 'Template',
      'TermReadKey' => 'Term::ReadKey',
      'libwww-perl' => 'LWP',
      'ack' => 'App::Ack',
  );
  
  
  sub main {
  
  die "Usage: $0 perl-lib-directory [...]\n"
      unless @ARGV;
  my @libdirs = @ARGV;
  
  # check dirs and add archlib's if appropriate
  for my $libdir (@libdirs) {
      die "$libdir isn't a directory\n"
          unless -d $libdir;
  
      my $archdir = "$libdir/$Config{archname}";
      if (-d $archdir) {
          unshift @libdirs, $archdir
              unless grep { $_ eq $archdir } @libdirs;
      }
  }
  
  my @installed_releases = determine_installed_releases(@libdirs);
  write_fields(\@installed_releases, $opt_format, [split ' ', $opt_output], \*STDOUT);
  
  warn sprintf "Completed survey in %.1f minutes using %d metacpan calls.\n",
      (time-$^T)/60, $metacpan_calls;
  
  
  do_makecpan(@installed_releases)
      if $opt_makecpan;
  
  exit $major_error_count;
  }
  
  
  sub do_makecpan {
      my (@installed_releases) = @_;
  
      warn "Updating $opt_makecpan for ".@installed_releases." releases...\n";
      mkpath("$opt_makecpan/modules");
  
      my %pkg_ver_rel;    # for 02packages
      for my $ri (@installed_releases) {
  
          # --- get the file
  
          my $main_url = URI->new($ri->{download_url});
          my $di = distname_info_from_url($main_url);
          my $pathfile = "authors/id/".$di->pathname;
          my $destfile = "$opt_makecpan/$pathfile";
          mkpath(dirname($destfile));
  
          my @urls = ($main_url);
          for my $mirror ('http://backpan.perl.org') {
              push @urls, "$mirror/$pathfile";
          }
  
          my $mirror_status;
          for my $url (@urls) {
              $mirror_status = eval { mirror($url, $destfile) };
              last if not is_error($mirror_status||500);
          }
          if ($@ || is_error($mirror_status)) {
              my $err = ($@ and chomp $@) ? $@ : $mirror_status;
              my $msg = "Error $err mirroring $main_url";
              if (-f $destfile) {
                  warn "$msg - using existing file\n";
              }
              else {
                  # better to keep going and add the packages to the index
                  # than abort at this stage due to network/mirror problems
                  # the user can drop the files in later
                  warn "$msg - continuing, ADD FILE MANUALLY!\n";
                  ++$major_error_count;
              }
          }
          else {
              warn "$mirror_status $main_url\n" if $opt_verbose;
          }
  
  
          my $mods_in_rel = get_module_versions_in_release($ri->{author}, $ri->{name});
  
          if (!keys %$mods_in_rel) { # XXX hack for common::sense
              (my $dist_as_pkg = $ri->{distribution}) =~ s/-/::/g;
              warn "$ri->{author}/$ri->{name} has no modules! Adding fake module $dist_as_pkg ".$di->version."\n";
              $mods_in_rel->{$dist_as_pkg} = {
                  name => $dist_as_pkg,
                  version => $di->version,
                  version_obj => version->parse($di->version),
              };
          }
  
  
          # --- accumulate package info for 02packages file
  
          for my $pkg (sort keys %$mods_in_rel ) {
              # pi => { name=>, version=>, version_obj=> }
              my $pi = $mods_in_rel->{$pkg};
  
              # for selecting which dist a package belongs to
              # XXX should factor in authorization status
              my $p_r_match_score = p_r_match_score($pkg, $ri);
  
              if (my $pvr = $pkg_ver_rel{$pkg}) {
                  # already seen same package name in different distribution
                  if ($p_r_match_score < $pvr->{p_r_match_score}) {
                      warn "$pkg seen in $pvr->{ri}{name} so ignoring one in $ri->{name}\n";
                      next;
                  }
                  warn "$pkg seen in $pvr->{ri}{name} - now overridden by $ri->{name}\n";
              }
  
              my $line = _fmtmodule($pkg, $di->pathname, $pi->{version});
              $pkg_ver_rel{$pkg} = { line => $line, pi => $pi, ri => $ri, p_r_match_score => $p_r_match_score };
          }
  
      }
  
  
      # --- write 02packages file
  
      my $pkg_lines = _readpkgs($opt_makecpan);
      my %packages;
      for my $line (@$pkg_lines, map { $_->{line} } values %pkg_ver_rel) {
          my ($pkg) = split(/\s+/, $line, 2);
          if ($packages{$pkg} and $packages{$pkg} ne $line) {
              warn "Old $packages{$pkg}\nNew $line\n" if $opt_verbose;
          }
          $packages{$pkg} = $line;
      };
      _writepkgs($opt_makecpan, [ sort values %packages ] );
  
  
      # --- write extra data files that may be useful XXX may change
      # XXX these don't all (yet?) merge with existing data
      my $survey_datadump_dir = "$opt_makecpan/".PROGNAME;
      mkpath($survey_datadump_dir);
  
      # Write list of token packages - each should match only one release.
      # This makes it _much_ faster to do installs via cpanm because it
      # can skip the modules it knows are installed (whereas using a list of
      # distros it has to reinstall _all_ of them every time).
      # XXX maybe add as a separate option: "--mainpkgs mainpkgs.lst"
      my %dist_packages;
      while ( my ($pkg, $line) = each %packages) {
          my $distpath = (split /\s+/, $line)[2];
          $dist_packages{$distpath}{$pkg}++;
      }
      my %token_package;
      my %token_package_pri = (       # alter install order for some modules
          'Module::Build' => 100,     # should be near first
          Moose => 50,
  
          # install distros that use Module::Install late so their dependencies
          # have already been resolved (else they try to fetch them directly,
          # bypassing our cpanm --mirror-only goal)
          'Olson::Abbreviations' => -90,
  
          # distros with special needs
          'Term::ReadKey' => -100,    # tests hang if run in background
      );
      for my $distpath (sort keys %dist_packages) {
          my $dp = $dist_packages{$distpath};
          my $di = CPAN::DistnameInfo->new($distpath);
          #warn Dumper([ $distpath, $di->dist, $di]);
          (my $token_pkg = $di->dist) =~ s/-/::/g;
          if (!$dp->{$token_pkg}) {
              if (my $keypkg = $distro_key_mod_names{$di->dist}) {
                  $token_pkg = $keypkg;
              }
              else {
                  # XXX not good - may pick a dummy test package
                  $token_pkg = (grep { $_ } keys %$dp)[0] || $token_pkg;
                  warn "Picked $token_pkg as token package for ".$di->distvname."\n";
              }
          }
          $token_package{$token_pkg} = $token_package_pri{$token_pkg} || 0;
      }
  
      my @main_pkgs = sort { $token_package{$b} <=> $token_package{$a} or $a cmp $b } keys %token_package;
      open my $key_pkg_fh, ">", "$survey_datadump_dir/token_packages.txt";
      print $key_pkg_fh "$_\n" for @main_pkgs;
      close $key_pkg_fh;
  
      # Write list of releases, like default stdout
      open my $rel_fh, ">", "$survey_datadump_dir/releases.txt";
      write_fields(\@installed_releases, undef, [qw(url)], $rel_fh);
      close $rel_fh;
  
      # dump the primary result data for additional info and debugging
      my $gzwrite = gzopen("$survey_datadump_dir/_data_dump.perl.gz", 'wb')
          or croak "Cannot open $survey_datadump_dir/_data_dump.perl.gz for writing: $gzerrno";
      $gzwrite->gzwrite("[\n");
      for my $ri (@installed_releases) {
          $gzwrite->gzwrite(Dumper($ri));
          $gzwrite->gzwrite(",");
      }
      $gzwrite->gzwrite("]\n");
      $gzwrite->gzclose;
  
      warn "$opt_makecpan updated.\n"
  }
  
  
  
  sub p_r_match_score {
      my ($pkg_name, $ri) = @_;
      my @p = split /\W/, $pkg_name;
      my @r = split /\W/, $ri->{name};
      for my $i (0..max(scalar @p, scalar @r)) {
          return $i if not defined $p[$i]
                    or not defined $r[$i]
                    or $p[$i] ne $r[$i]
      }
      die; # unreached
  }
  
  
  sub write_fields {
      my ($releases, $format, $fields, $fh) = @_;
  
      $format ||= join("\t", ('%s') x @$fields);
      $format .= "\n";
  
      for my $release_data (@$releases) {
          printf $fh $format, map {
              exists $release_data->{$_} ? $release_data->{$_} : "?$_"
          } @$fields;
      }
  }
  
  
  sub determine_installed_releases {
      my (@search_dirs) = @_;
  
      warn "Searching @search_dirs\n" if $opt_verbose;
  
      my %installed_mod_info;
  
      warn "Finding modules in @search_dirs\n";
      my ($installed_mod_files, $installed_meta) = find_installed_modules(@search_dirs);
  
      # get the installed version of each installed module and related info
      warn "Finding candidate releases for the ".keys(%$installed_mod_files)." installed modules\n";
      foreach my $module ( sort keys %$installed_mod_files ) {
          my $mod_file = $installed_mod_files->{$module};
  
          if ($opt_match) {
              if ($module !~ m/$opt_match/o) {
                  delete $installed_mod_files->{$module};
                  next;
              }
          }
  
          module_progress_indicator($module) unless $opt_verbose;
  
          my $mod_version = do {
              # silence warnings about duplicate VERSION declarations
              # eg Catalyst::Controller::DBIC::API* 2.002001
              local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /already declared with version/ };
              my $mm = Module::Metadata->new_from_file($mod_file);
              $mm->version; # only one version for one package in file
          };
          $mod_version ||= 0; # XXX
          my $mod_file_size = -s $mod_file;
  
          # Eliminate modules that will be supplied by the target perl version
          if ( my $cv = $Module::CoreList::version{ $opt_perlver }->{$module} ) {
              $cv =~ s/ //g;
              if (version->parse($cv) >= version->parse($mod_version)) {
                  warn "$module $mod_version is core in perl $opt_perlver (as v$cv) - skipped\n";
                  next;
              }
          }
  
          my $mi = $installed_mod_info{$module} = {
              file => $mod_file,
              module => $module,
              version => $mod_version,
              version_obj => version->parse($mod_version),
              size => $mod_file_size,
          };
  
          # ignore modules we know aren't indexed
          next if $module =~ /^Moose::Meta::Method::Accessor::Native::/;
  
          # XXX could also consider file mtime: releases newer than the mtime
          # of the module file can't be the origin of that module file.
          # (assuming clocks and file times haven't been messed with)
  
          try {
              my $ccdr = get_candidate_cpan_dist_releases($module, $mod_version, $mod_file_size);
              if (not %$ccdr) {
                  $ccdr = get_candidate_cpan_dist_releases($module, $mod_version, 0);
                  if (%$ccdr) {
                      # probably either a local change/patch or installed direct from repo
                      # but with a version number that matches a release
                      warn "$module $mod_version on CPAN but with different file size (not $mod_file_size)\n"
                          if $mod_version or $opt_verbose;
                      $mi->{file_size_mismatch}++;
                  }
                  elsif ($ccdr = get_candidate_cpan_dist_releases_fallback($module, $mod_version) and %$ccdr) {
                      warn "$module $mod_version not on CPAN but assumed to be from @{[ sort keys %$ccdr ]}\n"
                          if $mod_version or $opt_verbose;
                      $mi->{cpan_dist_fallback}++;
                  }
                  else {
                      $mi->{version_not_on_cpan}++;
                      # Possibly:
                      # - a local change/patch or installed direct from repo
                      #   with a version number that was never released.
                      # - a private module never released on cpan.
                      # - a build-time create module eg common/sense.pm.PL
                      warn "$module $mod_version not found on CPAN\n"
                          if $mi->{version} # no version implies uninteresting
                          or $opt_verbose;
                      # XXX could try finding the module with *any* version on cpan
                      # to help with later advice. ie could select as candidates
                      # the version above and the version below the number we have,
                      # and set a flag to inform later logic.
                  }
              }
              $mi->{candidate_cpan_dist_releases} = $ccdr if %$ccdr;
          }
          catch {
              warn "Failed get_candidate_cpan_dist_releases($module, $mod_version, $mod_file_size): $_";
          }
  
      }
  
  
      # Map modules to dists using the accumulated %installed_mod_info info
  
      warn "*** Mapping modules to releases\n";
  
      my %best_dist;
      foreach my $mod ( sort keys %installed_mod_info ) {
          my $mi = $installed_mod_info{$mod};
  
          module_progress_indicator($mod) unless $opt_verbose;
  
          # find best match among the cpan releases that included this module
          my $ccdr = $installed_mod_info{$mod}{candidate_cpan_dist_releases}
              or next; # no candidates, warned about above (for mods with a version)
  
          my $best_dist_cache_key = join " ", sort keys %$ccdr;
          our %best_dist_cache;
          my $best = $best_dist_cache{$best_dist_cache_key}
              ||= pick_best_cpan_dist_release($ccdr, \%installed_mod_info);
  
          my $note = "";
          if (@$best > 1) { # try using perllocal.pod to narrow the options
              # XXX TODO move this logic into the per-candidate-distro loop below
              # it doesn't make much sense to be here at the per-module level
              my @in_perllocal = grep {
                  my $distname = $_->{distribution};
                  my ($v, $dist_mod_name) = perllocal_distro_mod_version($distname, $installed_meta->{perllocalpod});
                  warn "$dist_mod_name in perllocal.pod: ".($v ? "YES" : "NO")."\n"
                      if $opt_debug;
                  $v;
              } @$best;
              if (@in_perllocal && @in_perllocal < @$best) {
                  $note = sprintf "narrowed from %d via perllocal", scalar @$best;
                  $best = \@in_perllocal;
              }
          }
  
          if (@$best > 1 or $note) { # note the poor match for this module
              # but not if there's no version (as that's common)
              my $best_desc = join " or ", map { $_->{release} } @$best;
              my $pct = sprintf "%.2f%%", $best->[0]{fraction_installed} * 100;
              warn "$mod $mi->{version} odd best match: $best_desc $note ($best->[0]{fraction_installed})\n"
                  if $note or $opt_verbose or ($mi->{version} and $best->[0]{fraction_installed} < 0.3);
              # if the module has no version and multiple best matches
              # then it's unlikely make a useful contribution, so ignore it
              # XXX there's a risk that we'd ignore all the modules of a release
              # where none of the modules has a version, but that seems unlikely.
              next if not $mi->{version};
          }
  
          for my $dist (@$best) {
              # two level hash to make it easier to handle versions
              my $di = $best_dist{ $dist->{distribution} }{ $dist->{release} } ||= { dist => $dist };
              push @{ $di->{modules} }, $mi;
              $di->{or}{$_->{release}}++ for grep { $_ != $dist } @$best;
          }
  
      }
  
      warn "*** Refining releases\n";
  
      # $best_dist{ Foo }{ Foo-1.23 }{ dist=>$dist_struct, modules=>, or=>{ Foo-1.22 => $dist_struct } }
  
      my @installed_releases;    # Dist-Name => { ... }
  
      for my $distname ( sort keys %best_dist ) {
          my $releases = $best_dist{$distname};
  
          my @dist_by_version  = sort {
              $a->{dist}{version_obj}        <=> $b->{dist}{version_obj} or
              $a->{dist}{fraction_installed} <=> $b->{dist}{fraction_installed}
          } values %$releases;
          my @dist_by_fraction = sort {
              $a->{dist}{fraction_installed} <=> $b->{dist}{fraction_installed} or
              $a->{dist}{version_obj}        <=> $b->{dist}{version_obj}
          } values %$releases;
          
          my @remnant_dists  = @dist_by_version;
          my $installed_dist = pop @remnant_dists;
  
          # is the most recent candidate dist version also the one with the
          # highest fraction_installed?
          if ($dist_by_version[-1] == $dist_by_fraction[-1]) {
              # this is the common case: we'll assume that's installed and the
              # rest are remnants of earlier versions
          }
          elsif ($dist_by_fraction[-1]{dist}{fraction_installed} == 100) {
              warn "Unsure which $distname is installed from among @{[ keys %$releases ]}\n";
              @remnant_dists  = @dist_by_fraction;
              $installed_dist = pop @remnant_dists;
              warn "Selecting the one that apprears to be 100% installed\n";
          }
          else {
              # else grumble so the user knows to ponder the possibilities
              warn "Can't determine which $distname is installed from among @{[ keys %$releases ]}\n";
              warn Dumper([\@dist_by_version, \@dist_by_fraction]);
              warn "\tSelecting based on latest version\n";
          }
  
          if (@remnant_dists or $opt_debug) {
              warn "Distributions with remnants (chosen release is first):\n"
                  unless our $dist_with_remnants_warning++;
              warn "@{[ map { $_->{dist}{release} } reverse @dist_by_fraction ]}\n"; 
              for ($installed_dist, @remnant_dists) {
                  my $fi = $_->{dist}{fraction_installed};
                  my $modules = $_->{modules};
                  my $mv_desc = join(", ", map { "$_->{module} $_->{version}" } @$modules);
                  warn sprintf "\t%s\t%s%% installed: %s\n",
                      $_->{dist}{release},
                      $_->{dist}{percent_installed},
                      (@$modules > 4 ? "(".@$modules." modules)" : $mv_desc),
              }
          }
  
          # note ordering: remnants first
          for (($opt_remnants ? @remnant_dists : ()), $installed_dist) {
              my ($author, $distribution, $release)
                  = @{$_->{dist}}{qw(author distribution release)};
  
              $metacpan_calls++;
              my $release_data = $metacpan_api->release( author => $author, release => $release );
              if (!$release_data) {
                  warn "Can't find release details for $author/$release - SKIPPED!\n";
                  next; # XXX could fake some of $release_data instead
              }
  
              # shortcuts
              (my $url = $release_data->{download_url}) =~ s{ .*? \b authors/ }{authors/}x;
  
              push @installed_releases, {
                  # 
                  %$release_data,
                  # extra items mushed inhandy shortcuts
                  url => $url,
                  # raw data structures
                  dist_data => $_->{dist},
              };
          }
          #die Dumper(\@installed_releases);
      }
  
      # sorting into dependency order could be added later, maybe
  
      return @installed_releases;
  }
  
  
  # pick_best_cpan_dist_release - memoized
  # for each %$ccdr adds a fraction_installed based on %$installed_mod_info
  # returns ref to array of %$ccdr values that have the max fraction_installed
  
  sub pick_best_cpan_dist_release {
      my ($ccdr, $installed_mod_info) = @_;
  
      for my $release (sort keys %$ccdr) {
          my $release_info = $ccdr->{$release};
          $release_info->{fraction_installed}
              = dist_fraction_installed($release_info->{author}, $release, $installed_mod_info);
          $release_info->{percent_installed} # for informal use
              = sprintf "%.2f", $release_info->{fraction_installed} * 100;
      }
  
      my $max_fraction_installed = max( map { $_->{fraction_installed} } values %$ccdr );
      my @best = grep { $_->{fraction_installed} == $max_fraction_installed } values %$ccdr;
  
      return \@best;
  }
  
  
  # returns a number from 0 to 1 representing the fraction of the modules
  # in a particular release match the coresponding modules in %$installed_mod_info
  sub dist_fraction_installed {
      my ($author, $release, $installed_mod_info) = @_;
  
      my $tag = "$author/$release";
      my $mods_in_rel = get_module_versions_in_release($author, $release);
      my $mods_in_rel_count = keys %$mods_in_rel;
      my $mods_inst_count = sum( map {
          my $mi = $installed_mod_info->{ $_->{name} };
          # XXX we stash the version_obj into the mods_in_rel hash
          # (though with little/no caching effect with current setup)
          $_->{version_obj} ||= eval { version->parse($_->{version}) };
          my $hit = ($mi && $mi->{version_obj} == $_->{version_obj}) ? 1 : 0;
          # demote to a low-scoring partial match if the file size differs
          # XXX this isn't good as the effect varies with the number of modules
          $hit = 0.1 if $mi && $mi->{size} != $_->{size};
          warn sprintf "%s %s %s %s: %s\n", $tag, $_->{name}, $_->{version_obj}, $_->{size},
                  ($hit == 1) ? "matches"
                      : ($mi) ? "differs ($mi->{version_obj}, $mi->{size})"
                      : "not installed",
              if $opt_debug;
          $hit;
      } values %$mods_in_rel) || 0;
  
      my $fraction_installed = ($mods_in_rel_count) ? $mods_inst_count/$mods_in_rel_count : 0;
      warn "$author/$release:\tfraction_installed $fraction_installed ($mods_inst_count/$mods_in_rel_count)\n"
          if $opt_verbose or !$mods_in_rel_count;
  
      return $fraction_installed;
  }
  
  
  sub get_candidate_cpan_dist_releases {
      my ($module, $version, $file_size) = @_;
  
      $version = 0 if not defined $version; # XXX
  
      # timbunce: So, the current situation is that: version_numified is a float
      # holding version->parse($raw_version)->numify, and version is a string
      # also holding version->parse($raw_version)->numify at the moment, and
      # that'll change to ->stringify at some point. Is that right now? 
      # mo: yes, I already patched the indexer, so new releases are already
      # indexed ok, but for older ones I need to reindex cpan
      my $v = (ref $version && $version->isa('version')) ? $version : version->parse($version);
      my %v = map { $_ => 1 } "$version", $v->stringify, $v->numify;
      my @version_qual;
      push @version_qual, { term => { "file.module.version" => $_ } }
          for keys %v;
      push @version_qual, { term => { "file.module.version_numified" => $_ }}
          for grep { looks_like_number($_) } keys %v;
  
      my @and_quals = (
          {"term" => {"file.module.name" => $module }},
          (@version_qual > 1 ? { "or" => \@version_qual } : $version_qual[0]),
      );
      push @and_quals, {"term" => {"file.stat.size" => $file_size }}
          if $file_size;
  
      # XXX doesn't cope with odd cases like 
      # http://explorer.metacpan.org/?url=/module/MLEHMANN/common-sense-3.4/sense.pm.PL
      $metacpan_calls++;
      my $results = $metacpan_api->post("file", {
          "size" => $metacpan_size,
          "query" =>  { "filtered" => {
              "filter" => {"and" => \@and_quals },
              "query" => {"match_all" => {}},
          }},
          "fields" => [qw(release _parent author version version_numified file.module.version file.module.version_numified date stat.mtime distribution)]
      });
  
      my $hits = $results->{hits}{hits};
      die "get_candidate_cpan_dist_releases($module, $version, $file_size): too many results (>$metacpan_size)"
          if @$hits >= $metacpan_size;
      warn "get_candidate_cpan_dist_releases($module, $version, $file_size): ".Dumper($results)
          if grep { not $_->{fields}{release} } @$hits; # XXX temp, seen once but not since
  
      # filter out perl-like releases
      @$hits = grep {
          $_->{fields}{release} !~ /^(perl|ponie|parrot|kurila|SiePerl-5.6.1-)/;
      } @$hits;
  
      for my $hit (@$hits) {
          $hit->{release_id} = delete $hit->{_parent};
          # add version_obj for convenience (will fail and be undef for releases like "0.08124-TRIAL")
          $hit->{fields}{version_obj} = eval { version->parse($hit->{fields}{version}) };
      }
  
      # we'll return { "Dist-Name-Version" => { details }, ... }
      my %dists = map { $_->{fields}{release} => $_->{fields} } @$hits;
      warn "get_candidate_cpan_dist_releases($module, $version, $file_size): @{[ sort keys %dists ]}\n"
          if $opt_verbose;
  
      return \%dists;
  }
  
  sub get_candidate_cpan_dist_releases_fallback {
      my ($module, $version) = @_;
  
      # fallback to look for distro of the same name as the module
      # for odd cases like
      # http://explorer.metacpan.org/?url=/module/MLEHMANN/common-sense-3.4/sense.pm.PL
      (my $distname = $module) =~ s/::/-/g;
  
      # timbunce: So, the current situation is that: version_numified is a float
      # holding version->parse($raw_version)->numify, and version is a string
      # also holding version->parse($raw_version)->numify at the moment, and
      # that'll change to ->stringify at some point. Is that right now? 
      # mo: yes, I already patched the indexer, so new releases are already
      # indexed ok, but for older ones I need to reindex cpan
      my $v = (ref $version && $version->isa('version')) ? $version : version->parse($version);
      my %v = map { $_ => 1 } "$version", $v->stringify, $v->numify;
      my @version_qual;
      push @version_qual, { term => { "version" => $_ } }
          for keys %v;
      push @version_qual, { term => { "version_numified" => $_ }}
          for grep { looks_like_number($_) } keys %v;
  
      my @and_quals = (
          {"term" => {"distribution" => $distname }},
          (@version_qual > 1 ? { "or" => \@version_qual } : $version_qual[0]),
      );
  
      # XXX doesn't cope with odd cases like 
      $metacpan_calls++;
      my $results = $metacpan_api->post("file", {
          "size" => $metacpan_size,
          "query" =>  { "filtered" => {
              "filter" => {"and" => \@and_quals },
              "query" => {"match_all" => {}},
          }},
          "fields" => [qw(release _parent author version version_numified file.module.version file.module.version_numified date stat.mtime distribution)]
      });
  
      my $hits = $results->{hits}{hits};
      die "get_candidate_cpan_dist_releases_fallback($module, $version): too many results (>$metacpan_size)"
          if @$hits >= $metacpan_size;
      warn "get_candidate_cpan_dist_releases_fallback($module, $version): ".Dumper($results)
          if grep { not $_->{fields}{release} } @$hits; # XXX temp, seen once but not since
  
      # filter out perl-like releases
      @$hits = grep {
          $_->{fields}{release} !~ /^(perl|ponie|parrot|kurila|SiePerl-5.6.1-)/;
      } @$hits;
  
      for my $hit (@$hits) {
          $hit->{release_id} = delete $hit->{_parent};
          # add version_obj for convenience (will fail and be undef for releases like "0.08124-TRIAL")
          $hit->{fields}{version_obj} = eval { version->parse($hit->{fields}{version}) };
      }
  
      # we'll return { "Dist-Name-Version" => { details }, ... }
      my %dists = map { $_->{fields}{release} => $_->{fields} } @$hits;
      warn "get_candidate_cpan_dist_releases_fallback($module, $version): @{[ sort keys %dists ]}\n"
          if $opt_verbose;
  
      return \%dists;
  }
  
  
  # this can be called for all sorts of releases that are only vague possibilities
  # and aren't actually installed, so generally it's quiet
  sub get_module_versions_in_release {
      my ($author, $release) = @_;
  
      $metacpan_calls++;
      my $results = eval { $metacpan_api->post("file", {
          "size" => $metacpan_size,
          "query" =>  { "filtered" => {
              "filter" => {"and" => [
                  {"term" => {"release" => $release }},
                  {"term" => {"author" => $author }},
                  {"term" => {"mime" => "text/x-script.perl-module"}},
              ]},
              "query" => {"match_all" => {}},
          }},
          "fields" => ["path","name","_source.module", "_source.stat.size"],
      }) };
      if (not $results) {
          warn "Failed get_module_versions_in_release for $author/$release: $@";
          return {};
      }
      my $hits = $results->{hits}{hits};
      die "get_module_versions_in_release($author, $release): too many results"
          if @$hits >= $metacpan_size;
  
      my %modules_in_release;
      for my $hit (@$hits) {
          my $path = $hit->{fields}{path};
  
          # XXX try to ignore files that won't get installed
          # XXX should use META noindex!
          if ($path =~ m!^(?:t|xt|tests?|inc|samples?|ex|examples?|bak)\b!) {
              warn "$author/$release: ignored non-installed module $path\n"
                  if $opt_debug;
              next;
          }
  
          my $size = $hit->{fields}{"_source.stat.size"};
          # files can contain more than one package ('module')
          my $rel_mods = $hit->{fields}{"_source.module"} || [];
          for my $mod (@$rel_mods) { # actually packages in the file
  
              # Some files may contain multiple packages. We want to ignore
              # all except the one that matches the name of the file.
              # We use a fairly loose (but still very effective) test because we
              # can't rely on $path including the full package name.
              (my $filebasename = $hit->{fields}{name}) =~ s/\.pm$//;
              if ($mod->{name} !~ m/\b$filebasename$/) {
                  warn "$author/$release: ignored $mod->{name} in $path\n"
                      if $opt_debug;
                  next;
              }
  
              # warn if package previously seen in this release
              # with a different version or file size
              if (my $prev = $modules_in_release{$mod->{name}}) {
                  my $version_obj = eval { version->parse($mod->{version}) };
                  die "$author/$release: $mod $mod->{version}: $@" if $@;
  
                  if ($opt_verbose) {
                      # XXX could add a show-only-once cache here
                      my $msg = "$mod->{name} $mod->{version} ($size) seen in $path after $prev->{path} $prev->{version} ($prev->{size})";
                      warn "$release: $msg\n"
                          if ($version_obj != version->parse($prev->{version}) or $size != $prev->{size});
                  }
              }
  
              # keep result small as Storable thawing this is major runtime cost
              # (specifically we avoid storing a version_obj here)
              $modules_in_release{$mod->{name}} = {
                  name => $mod->{name},
                  path => $path,
                  version => $mod->{version},
                  size => $size,
              };
          }
      }
  
      warn "\n$author/$release contains: @{[ map { qq($_->{name} $_->{version}) } values %modules_in_release ]}\n"
          if $opt_debug;
  
      return \%modules_in_release;
  }
  
  
  sub get_file_mtime {
      my ($file) = @_;
      # try to find the time the file was 'installed'
      # by looking for the commit date in svn or git
      # else fallback to the file modification time
      return (stat($file))[9];
  }
  
  
  sub find_installed_modules {
      my (@dirs) = @_;
  
      ### File::Find uses follow_skip => 1 by default, which doesn't die
      ### on duplicates, unless they are directories or symlinks.
      ### Ticket #29796 shows this code dying on Alien::WxWidgets,
      ### which uses symlinks.
      ### File::Find doc says to use follow_skip => 2 to ignore duplicates
      ### so this will stop it from dying.
      my %find_args = ( follow_skip => 2 );
  
      ### File::Find uses lstat, which quietly becomes stat on win32
      ### it then uses -l _ which is not allowed by the statbuffer because
      ### you did a stat, not an lstat (duh!). so don't tell win32 to
      ### follow symlinks, as that will break badly
      # XXX disabled because we want the postprocess hook to work
      #$find_args{'follow_fast'} = 1 unless ON_WIN32;
  
      ### never use the @INC hooks to find installed versions of
      ### modules -- they're just there in case they're not on the
      ### perl install, but the user shouldn't trust them for *other*
      ### modules!
      ### XXX CPANPLUS::inc is now obsolete, remove the calls
      #local @INC = CPANPLUS::inc->original_inc;
  
      # sort @dirs to put longest first to make it easy to handle
      # elements that are within other elements (e.g., an archdir)
      my @dirs_ordered = sort { length $b <=> length $a } @dirs;
  
      my %seen_mod;
      my %dir_done;
      my %meta; # return metadata about the search
      for my $dir (@dirs_ordered) {
          next if $dir eq '.';
  
          ### not a directory after all
          ### may be coderef or some such
          next unless -d $dir;
  
          ### make sure to clean up the directories just in case,
          ### as we're making assumptions about the length
          ### This solves rt.cpan issue #19738
  
          ### John M. notes: On VMS cannonpath can not currently handle
          ### the $dir values that are in UNIX format.
          $dir = File::Spec->canonpath($dir) unless ON_VMS;
  
          ### have to use F::S::Unix on VMS, or things will break
          my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
  
          ### XXX in some cases File::Find can actually die!
          ### so be safe and wrap it in an eval.
          eval {
              File::Find::find(
                  {   %find_args,
                      postprocess => sub {
                          $dir_done{$File::Find::dir}++;
                      },
                      wanted => sub {
  
                          unless (/\.pm$/i) {
                              # skip all dot-dirs (eg .git .svn)
                              $File::Find::prune = 1
                                  if -d $File::Find::name and /^\.\w/;
                              # don't reenter a dir we've already done
                              $File::Find::prune = 1
                                  if $dir_done{$File::Find::name};
                              # remember perllocal.pod if we see it
                              push @{$meta{perllocalpod}}, $File::Find::name
                                  if $_ eq 'perllocal.pod';
                              return;
                          }
                          my $mod = $File::Find::name;
  
                          ### make sure it's in Unix format, as it
                          ### may be in VMS format on VMS;
                          $mod = VMS::Filespec::unixify($mod) if ON_VMS;
  
                          $mod = substr( $mod, length($dir) + 1, -3 );
                          $mod = join '::', $file_spec->splitdir($mod);
  
                          return if $seen_mod{$mod};
                          $seen_mod{$mod} = $File::Find::name;
  
                          ### ignore files that don't contain a matching package declaration
                          ### warn about those that do contain some kind of package declaration
                          #my $content = read_file($File::Find::name);
                          #unless ( $content =~ m/^ \s* package \s+ (\#.*\n\s*)? $mod \b/xm ) {
                          #warn "No 'package $mod' seen in $File::Find::name\n"
                          #if $opt_verbose && $content =~ /\b package \b/x;
                          #return;
                          #}
  
                      },
                  },
                  $dir
              );
              1;
          }
              or die "File::Find died: $@";
  
      }
  
      return (\%seen_mod, \%meta);
  }
  
  
  sub perllocal_distro_mod_version {
      my ($distname, $perllocalpod) = @_;
  
      ( my $dist_mod_name = $distname ) =~ s/-/::/g;
      my $key_mod_name = $distro_key_mod_names{$distname} || $dist_mod_name;
  
      our $perllocal_distro_mod_version;
      if (not $perllocal_distro_mod_version) { # initial setup
          warn "Only first perllocal.pod file will be processed: @$perllocalpod\n"
              if @$perllocalpod > 1;
  
          $perllocal_distro_mod_version = {};
          # extract data from perllocal.pod
          if (my $plp = shift @$perllocalpod) {
              # The VERSION isn't always the same as that in the distro file
              if (eval { require ExtUtils::Perllocal::Parser }) {
                  my $p = ExtUtils::Perllocal::Parser->new;
                  $perllocal_distro_mod_version = { map {
                      $_->name => $_->{data}{VERSION}
                  } $p->parse_from_file($plp) };
                  warn "Details of ".keys(%$perllocal_distro_mod_version)." distributions found in $plp\n";
              }
              else {
                  warn "Wanted to use perllocal.pod but can't because ExtUtils::Perllocal::Parser isn't available\n";
              }
          }
          else {
              warn "No perllocal.pod found to aid disambiguation\n";
          }
      }
  
      return $perllocal_distro_mod_version->{$key_mod_name};
  }
  
  
  sub module_progress_indicator {
      my ($module) = @_;
      my $crnt = (split /::/, $module)[0];
      our $last ||= '';
      if ($last ne $crnt) {
          warn "\t$crnt...\n";
          $last = $crnt;
      }
  }
  
  
  # copied from CPAN::Mini::Inject and hacked
  
  sub _readpkgs {
      my ($cpandir) = @_;
  
      my $packages_file = $cpandir.'/modules/02packages.details.txt.gz';
      return [] if not -f $packages_file;
  
      my $gzread = gzopen($packages_file, 'rb')
          or croak "Cannot open $packages_file: $gzerrno\n";
  
      my $inheader = 1;
      my @packages;
      my $package;
  
      while ( $gzread->gzreadline( $package ) ) {
          if ( $inheader ) {
              $inheader = 0 unless $package =~ /\S/;
              next;
          }
          chomp $package;
          push @packages, $package;
      }
  
      $gzread->gzclose;
  
      return \@packages;
  }
  
  sub _writepkgs {
      my ($cpandir, $pkgs) = @_;
  
      my $packages_file = $cpandir.'/modules/02packages.details.txt.gz';
      my $gzwrite = gzopen($packages_file, 'wb')
          or croak "Cannot open $packages_file for writing: $gzerrno";
      
      $gzwrite->gzwrite( "File:         02packages.details.txt\n" );
      $gzwrite->gzwrite(
          "URL:          http://www.perl.com/CPAN/modules/02packages.details.txt\n"
      );
      $gzwrite->gzwrite(
          'Description:  Package names found in directory $CPAN/authors/id/'
          . "\n" );
      $gzwrite->gzwrite( "Columns:      package name, version, path\n" );
      $gzwrite->gzwrite(
          "Intended-For: Automated fetch routines, namespace documentation.\n"
      );
      $gzwrite->gzwrite( "Written-By:   $0 0.001\n" ); # XXX TODO
      $gzwrite->gzwrite( "Line-Count:   " . scalar( @$pkgs ) . "\n" );
      # Last-Updated: Sat, 19 Mar 2005 19:49:10 GMT
      my @date = split( /\s+/, scalar( gmtime ) );
      $gzwrite->gzwrite( "Last-Updated: $date[0], $date[2] $date[1] $date[4] $date[3] GMT\n\n" );
      
      $gzwrite->gzwrite( "$_\n" ) for ( @$pkgs );
      
      $gzwrite->gzclose;
  }
  
  sub _fmtmodule {
      my ( $module, $file, $version ) = @_;
      $version = "undef" if not defined $version;
      my $fw = 38 - length $version;
      $fw = length $module if $fw < length $module;
      return sprintf "%-${fw}s %s  %s", $module, $version, $file;
  }
  
  sub first_word {
      my $string = shift;
      return ($string =~ m/^(\w+)/) ? $1 : $string;
  }
  
  sub distname_info_from_url {
      my ($url) = @_;
      $url =~ s{.* \b authors/id/ }{}x
          or warn "No authors/ in '$url'\n";
      my $di = CPAN::DistnameInfo->new($url);
      return $di;
  }
DIST_SURVEYOR

$fatpacked{"Encode/Locale.pm"} = <<'ENCODE_LOCALE';
  package Encode::Locale;
  
  use strict;
  our $VERSION = "1.02";
  
  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") {
  	# Try to obtain what the Windows ANSI code page is
  	eval {
  	    require Win32::API;
  	    if (Win32::API->Import('kernel32', 'int GetACP()')) {
  		my $cp = GetACP();
  		$ENCODING_LOCALE = "cp$cp" if $cp;
  	    }
  	};
  
  	# 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
  	    # introducted 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;
  
      }
  }
  
  _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 is still byte
  based.  Programs therefore needs 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 arrange 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 adviced 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{"Eval/Closure.pm"} = <<'EVAL_CLOSURE';
  package Eval::Closure;
  BEGIN {
    $Eval::Closure::VERSION = '0.06';
  }
  use strict;
  use warnings;
  use Sub::Exporter -setup => {
      exports => [qw(eval_closure)],
      groups  => { default => [qw(eval_closure)] },
  };
  # ABSTRACT: safely and cleanly create closures via string eval
  
  use Carp;
  use overload ();
  use Scalar::Util qw(reftype);
  use Try::Tiny;
  
  
  
  sub eval_closure {
      my (%args) = @_;
  
      $args{source} = _canonicalize_source($args{source});
      _validate_env($args{environment} ||= {});
  
      $args{source} = _line_directive(@args{qw(line description)})
                    . $args{source}
          if defined $args{description} && !($^P & 0x10);
  
      my ($code, $e) = _clean_eval_closure(@args{qw(source environment)});
  
      if (!$code) {
          if ($args{terse_error}) {
              die "$e\n";
          }
          else {
              croak("Failed to compile source: $e\n\nsource:\n$args{source}")
          }
      }
  
      return $code;
  }
  
  sub _canonicalize_source {
      my ($source) = @_;
  
      if (defined($source)) {
          if (ref($source)) {
              if (reftype($source) eq 'ARRAY'
               || overload::Method($source, '@{}')) {
                  return join "\n", @$source;
              }
              elsif (overload::Method($source, '""')) {
                  return "$source";
              }
              else {
                  croak("The 'source' parameter to eval_closure must be a "
                      . "string or array reference");
              }
          }
          else {
              return $source;
          }
      }
      else {
          croak("The 'source' parameter to eval_closure is required");
      }
  }
  
  sub _validate_env {
      my ($env) = @_;
  
      croak("The 'environment' parameter must be a hashref")
          unless reftype($env) eq 'HASH';
  
      for my $var (keys %$env) {
          croak("Environment key '$var' should start with \@, \%, or \$")
              unless $var =~ /^([\@\%\$])/;
          croak("Environment values must be references, not $env->{$var}")
              unless ref($env->{$var});
      }
  }
  
  sub _line_directive {
      my ($line, $description) = @_;
  
      $line = 1 unless defined($line);
  
      return qq{#line $line "$description"\n};
  }
  
  sub _clean_eval_closure {
       my ($source, $captures) = @_;
  
      my @capture_keys = sort keys %$captures;
  
      if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) {
          _dump_source(_make_compiler_source($source, @capture_keys));
      }
  
      my ($compiler, $e) = _make_compiler($source, @capture_keys);
      my $code;
      if (defined $compiler) {
          $code = $compiler->(@$captures{@capture_keys});
      }
  
      if (defined($code) && (!ref($code) || ref($code) ne 'CODE')) {
          $e = "The 'source' parameter must return a subroutine reference, "
             . "not $code";
          undef $code;
      }
  
      return ($code, $e);
  }
  
  {
      my %compiler_cache;
  
      sub _make_compiler {
          my $source = _make_compiler_source(@_);
  
          unless (exists $compiler_cache{$source}) {
              local $@;
              local $SIG{__DIE__};
              my $compiler = eval $source;
              my $e = $@;
              $compiler_cache{$source} = [ $compiler, $e ];
          }
  
          return @{ $compiler_cache{$source} };
      }
  }
  
  sub _make_compiler_source {
      my ($source, @capture_keys) = @_;
      my $i = 0;
      return join "\n", (
          'sub {',
          (map {
              'my ' . $_ . ' = ' . substr($_, 0, 1) . '{$_[' . $i++ . ']};'
           } @capture_keys),
          $source,
          '}',
      );
  }
  
  sub _dump_source {
      my ($source) = @_;
  
      my $output;
      if (try { require Perl::Tidy }) {
          Perl::Tidy::perltidy(
              source      => \$source,
              destination => \$output,
              argv        => [],
          );
      }
      else {
          $output = $source;
      }
  
      warn "$output\n";
  }
  
  
  1;
  
  __END__
  =pod
  
  =head1 NAME
  
  Eval::Closure - safely and cleanly create closures via string eval
  
  =head1 VERSION
  
  version 0.06
  
  =head1 SYNOPSIS
  
    use Eval::Closure;
  
    my $code = eval_closure(
        source      => 'sub { $foo++ }',
        environment => {
            '$foo' => \1,
        },
    );
  
    warn $code->(); # 1
    warn $code->(); # 2
  
    my $code2 = eval_closure(
        source => 'sub { $code->() }',
    ); # dies, $code isn't in scope
  
  =head1 DESCRIPTION
  
  String eval is often used for dynamic code generation. For instance, C<Moose>
  uses it heavily, to generate inlined versions of accessors and constructors,
  which speeds code up at runtime by a significant amount. String eval is not
  without its issues however - it's difficult to control the scope it's used in
  (which determines which variables are in scope inside the eval), and it can be
  quite slow, especially if doing a large number of evals.
  
  This module attempts to solve both of those problems. It provides an
  C<eval_closure> function, which evals a string in a clean environment, other
  than a fixed list of specified variables. It also caches the result of the
  eval, so that doing repeated evals of the same source, even with a different
  environment, will be much faster (but note that the description is part of the
  string to be evaled, so it must also be the same (or non-existent) if caching
  is to work properly).
  
  =head1 FUNCTIONS
  
  =head2 eval_closure(%args)
  
  This function provides the main functionality of this module. It is exported by
  default. It takes a hash of parameters, with these keys being valid:
  
  =over 4
  
  =item source
  
  The string to be evaled. It should end by returning a code reference. It can
  access any variable declared in the C<environment> parameter (and only those
  variables). It can be either a string, or an arrayref of lines (which will be
  joined with newlines to produce the string).
  
  =item environment
  
  The environment to provide to the eval. This should be a hashref, mapping
  variable names (including sigils) to references of the appropriate type. For
  instance, a valid value for environment would be C<< { '@foo' => [] } >> (which
  would allow the generated function to use an array named C<@foo>). Generally,
  this is used to allow the generated function to access externally defined
  variables (so you would pass in a reference to a variable that already exists).
  
  =item description
  
  This lets you provide a bit more information in backtraces. Normally, when a
  function that was generated through string eval is called, that stack frame
  will show up as "(eval n)", where 'n' is a sequential identifier for every
  string eval that has happened so far in the program. Passing a C<description>
  parameter lets you override that to something more useful (for instance,
  L<Moose> overrides the description for accessors to something like "accessor
  foo at MyClass.pm, line 123").
  
  =item line
  
  This lets you override the particular line number that appears in backtraces,
  much like the C<description> option. The default is 1.
  
  =item terse_error
  
  Normally, this function appends the source code that failed to compile, and
  prepends some explanatory text. Setting this option to true suppresses that
  behavior so you get only the compilation error that Perl actually reported.
  
  =back
  
  =head1 BUGS
  
  No known bugs.
  
  Please report any bugs through RT: email
  C<bug-eval-closure at rt.cpan.org>, or browse to
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Eval-Closure>.
  
  =head1 SUPPORT
  
  You can find this documentation for this module with the perldoc command.
  
      perldoc Eval::Closure
  
  You can also look for information at:
  
  =over 4
  
  =item * AnnoCPAN: Annotated CPAN documentation
  
  L<http://annocpan.org/dist/Eval-Closure>
  
  =item * CPAN Ratings
  
  L<http://cpanratings.perl.org/d/Eval-Closure>
  
  =item * RT: CPAN's request tracker
  
  L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Eval-Closure>
  
  =item * Search CPAN
  
  L<http://search.cpan.org/dist/Eval-Closure>
  
  =back
  
  =head1 AUTHOR
  
  Jesse Luehrs <doy at tozt dot net>
  
  Based on code from L<Class::MOP::Method::Accessor>, by Stevan Little and the
  Moose Cabal.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<Class::MOP::Method::Accessor>
  
  This module is a factoring out of code that used to live here
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 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
  
EVAL_CLOSURE

$fatpacked{"File/Listing.pm"} = <<'FILE_LISTING';
  package File::Listing;
  
  sub Version { $VERSION; }
  $VERSION = "6.02";
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(parse_dir);
  
  use strict;
  
  use Carp ();
  use HTTP::Date qw(str2time);
  
  
  
  sub parse_dir ($;$$$)
  {
     my($dir, $tz, $fstype, $error) = @_;
  
     $fstype ||= 'unix';
     $fstype = "File::Listing::" . lc $fstype;
  
     my @args = $_[0];
     push(@args, $tz) if(@_ >= 2);
     push(@args, $error) if(@_ >= 4);
  
     $fstype->parse(@args);
  }
  
  
  sub line { Carp::croak("Not implemented yet"); }
  sub init { } # Dummy sub
  
  
  sub file_mode ($)
  {
      # This routine was originally borrowed from Graham Barr's
      # Net::FTP package.
  
      local $_ = shift;
      my $mode = 0;
      my($type,$ch);
  
      s/^(.)// and $type = $1;
  
      while (/(.)/g) {
  	$mode <<= 1;
  	$mode |= 1 if $1 ne "-" &&
  		      $1 ne 'S' &&
  		      $1 ne 't' &&
  		      $1 ne 'T';
      }
  
      $type eq "d" and $mode |= 0040000 or	# Directory
        $type eq "l" and $mode |= 0120000 or	# Symbolic Link
  	$mode |= 0100000;			# Regular File
  
      $mode |= 0004000 if /^...s....../i;
      $mode |= 0002000 if /^......s.../i;
      $mode |= 0001000 if /^.........t/i;
  
      $mode;
  }
  
  
  sub parse
  {
     my($pkg, $dir, $tz, $error) = @_;
  
     # First let's try to determine what kind of dir parameter we have
     # received.  We allow both listings, reference to arrays and
     # file handles to read from.
  
     if (ref($dir) eq 'ARRAY') {
         # Already splitted up
     }
     elsif (ref($dir) eq 'GLOB') {
         # A file handle
     }
     elsif (ref($dir)) {
        Carp::croak("Illegal argument to parse_dir()");
     }
     elsif ($dir =~ /^\*\w+(::\w+)+$/) {
        # This scalar looks like a file handle, so we assume it is
     }
     else {
        # A normal scalar listing
        $dir = [ split(/\n/, $dir) ];
     }
  
     $pkg->init();
  
     my @files = ();
     if (ref($dir) eq 'ARRAY') {
         for (@$dir) {
  	   push(@files, $pkg->line($_, $tz, $error));
         }
     }
     else {
         local($_);
         while (<$dir>) {
  	   chomp;
  	   push(@files, $pkg->line($_, $tz, $error));
         }
     }
     wantarray ? @files : \@files;
  }
  
  
  
  package File::Listing::unix;
  
  use HTTP::Date qw(str2time);
  
  # A place to remember current directory from last line parsed.
  use vars qw($curdir @ISA);
  
  @ISA = qw(File::Listing);
  
  
  
  sub init
  {
      $curdir = '';
  }
  
  
  sub line
  {
      shift; # package name
      local($_) = shift;
      my($tz, $error) = @_;
  
      s/\015//g;
      #study;
  
      my ($kind, $size, $date, $name);
      if (($kind, $size, $date, $name) =
  	/^([\-FlrwxsStTdD]{10})                   # Type and permission bits
  	 .*                                       # Graps
  	 \D(\d+)                                  # File size
  	 \s+                                      # Some space
  	 (\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2})  # Date
  	 \s+                                      # Some more space
  	 (.*)$                                    # File name
  	/x )
  
      {
  	return if $name eq '.' || $name eq '..';
  	$name = "$curdir/$name" if length $curdir;
  	my $type = '?';
  	if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
  	    $name = $1;
  	    $type = "l $2";
  	}
  	elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
  	    $type = 'f';
  	}
  	elsif ($kind =~ /^[dD]/) {
  	    $type = 'd';
  	    $size = undef;  # Don't believe the reported size
  	}
  	return [$name, $type, $size, str2time($date, $tz), 
                File::Listing::file_mode($kind)];
  
      }
      elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
  	my $dir = $1;
  	return () if $dir eq '.';
  	$curdir = $dir;
  	return ();
      }
      elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
  	return ();
      }
      elsif (/not found/    || # OSF1, HPUX, and SunOS return
               # "$file not found"
               /No such file/ || # IRIX returns
               # "UX:ls: ERROR: Cannot access $file: No such file or directory"
                                 # Solaris returns
               # "$file: No such file or directory"
               /cannot find/     # Windows NT returns
               # "The system cannot find the path specified."
               ) {
  	return () unless defined $error;
  	&$error($_) if ref($error) eq 'CODE';
  	warn "Error: $_\n" if $error eq 'warn';
  	return ();
      }
      elsif ($_ eq '') {       # AIX, and Linux return nothing
  	return () unless defined $error;
  	&$error("No such file or directory") if ref($error) eq 'CODE';
  	warn "Warning: No such file or directory\n" if $error eq 'warn';
  	return ();
      }
      else {
          # parse failed, check if the dosftp parse understands it
          File::Listing::dosftp->init();
          return(File::Listing::dosftp->line($_,$tz,$error));
      }
  
  }
  
  
  
  package File::Listing::dosftp;
  
  use HTTP::Date qw(str2time);
  
  # A place to remember current directory from last line parsed.
  use vars qw($curdir @ISA);
  
  @ISA = qw(File::Listing);
  
  
  
  sub init
  {
      $curdir = '';
  }
  
  
  sub line
  {
      shift; # package name
      local($_) = shift;
      my($tz, $error) = @_;
  
      s/\015//g;
  
      my ($date, $size_or_dir, $name, $size);
  
      # 02-05-96  10:48AM                 1415 src.slf
      # 09-10-96  09:18AM       <DIR>          sl_util
      if (($date, $size_or_dir, $name) =
          /^(\d\d-\d\d-\d\d\s+\d\d:\d\d\wM)         # Date and time info
           \s+                                      # Some space
           (<\w{3}>|\d+)                            # Dir or Size
           \s+                                      # Some more space
           (.+)$                                    # File name
          /x )
      {
  	return if $name eq '.' || $name eq '..';
  	$name = "$curdir/$name" if length $curdir;
  	my $type = '?';
  	if ($size_or_dir eq '<DIR>') {
  	    $type = "d";
              $size = ""; # directories have no size in the pc listing
          }
          else {
  	    $type = 'f';
              $size = $size_or_dir;
  	}
  	return [$name, $type, $size, str2time($date, $tz), undef];
      }
      else {
  	return () unless defined $error;
  	&$error($_) if ref($error) eq 'CODE';
  	warn "Can't parse: $_\n" if $error eq 'warn';
  	return ();
      }
  
  }
  
  
  
  package File::Listing::vms;
  @File::Listing::vms::ISA = qw(File::Listing);
  
  package File::Listing::netware;
  @File::Listing::netware::ISA = qw(File::Listing);
  
  
  
  package File::Listing::apache;
  
  use vars qw(@ISA);
  
  @ISA = qw(File::Listing);
  
  
  sub init { }
  
  
  sub line {
      shift; # package name
      local($_) = shift;
      my($tz, $error) = @_; # ignored for now...
  
      s!</?t[rd][^>]*>! !g;  # clean away various table stuff
      if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
  	my($filename, $filesize) = ($1, $7);
  	my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
  	if ($m =~ /^\d+$/) {
  	    ($d,$y) = ($y,$d) # iso date
  	}
  	else {
  	    $m = _monthabbrev_number($m);
  	}
  
  	$filesize = 0 if $filesize eq '-';
  	if ($filesize =~ s/k$//i) {
  	    $filesize *= 1024;
  	}
  	elsif ($filesize =~ s/M$//) {
  	    $filesize *= 1024*1024;
  	}
  	elsif ($filesize =~ s/G$//) {
  	    $filesize *= 1024*1024*1024;
  	}
  	$filesize = int $filesize;
  
  	require Time::Local;
  	my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y)-1900);
  	my $filetype = ($filename =~ s|/$|| ? "d" : "f");
  	return [$filename, $filetype, $filesize, $filetime, undef];
      }
  
      return ();
  }
  
  
  sub _guess_year {
      my $y = shift;
      if ($y >= 90) {
  	$y = 1900+$y;
      }
      elsif ($y < 100) {
  	$y = 2000+$y;
      }
      $y;
  }
  
  
  sub _monthabbrev_number {
      my $mon = shift;
      +{'Jan' => 1,
        'Feb' => 2,
        'Mar' => 3,
        'Apr' => 4,
        'May' => 5,
        'Jun' => 6,
        'Jul' => 7,
        'Aug' => 8,
        'Sep' => 9,
        'Oct' => 10,
        'Nov' => 11,
        'Dec' => 12,
       }->{$mon};
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  File::Listing - parse directory listing
  
  =head1 SYNOPSIS
  
   use File::Listing qw(parse_dir);
   $ENV{LANG} = "C";  # dates in non-English locales not supported
   for (parse_dir(`ls -l`)) {
       ($name, $type, $size, $mtime, $mode) = @$_;
       next if $type ne 'f'; # plain file
       #...
   }
  
   # directory listing can also be read from a file
   open(LISTING, "zcat ls-lR.gz|");
   $dir = parse_dir(\*LISTING, '+0000');
  
  =head1 DESCRIPTION
  
  This module exports a single function called parse_dir(), which can be
  used to parse directory listings.
  
  The first parameter to parse_dir() is the directory listing to parse.
  It can be a scalar, a reference to an array of directory lines or a
  glob representing a filehandle to read the directory listing from.
  
  The second parameter is the time zone to use when parsing time stamps
  in the listing. If this value is undefined, then the local time zone is
  assumed.
  
  The third parameter is the type of listing to assume.  Currently
  supported formats are 'unix', 'apache' and 'dosftp'.  The default
  value 'unix'.  Ideally, the listing type should be determined
  automatically.
  
  The fourth parameter specifies how unparseable lines should be treated.
  Values can be 'ignore', 'warn' or a code reference.  Warn means that
  the perl warn() function will be called.  If a code reference is
  passed, then this routine will be called and the return value from it
  will be incorporated in the listing.  The default is 'ignore'.
  
  Only the first parameter is mandatory.
  
  The return value from parse_dir() is a list of directory entries.  In
  a scalar context the return value is a reference to the list.  The
  directory entries are represented by an array consisting of [
  $filename, $filetype, $filesize, $filetime, $filemode ].  The
  $filetype value is one of the letters 'f', 'd', 'l' or '?'.  The
  $filetime value is the seconds since Jan 1, 1970.  The
  $filemode is a bitmask like the mode returned by stat().
  
  =head1 COPYRIGHT
  
  Copyright 1996-2010, Gisle Aas
  
  Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
  Net::FTP's parse_dir (Graham Barr).
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
FILE_LISTING

$fatpacked{"File/Slurp.pm"} = <<'FILE_SLURP';
  package File::Slurp;
  
  use strict;
  
  use Carp ;
  use POSIX qw( :fcntl_h ) ;
  use Fcntl qw( :DEFAULT ) ;
  use Symbol ;
  
  my $is_win32 = $^O =~ /win32/i ;
  
  # Install subs for various constants that aren't set in older perls
  # (< 5.005).  Fcntl on old perls uses Exporter to define subs without a
  # () prototype These can't be overridden with the constant pragma or
  # we get a prototype mismatch.  Hence this less than aesthetically
  # appealing BEGIN block:
  
  BEGIN {
  	unless( eval { defined SEEK_SET() } ) {
  		*SEEK_SET = sub { 0 };
  		*SEEK_CUR = sub { 1 };
  		*SEEK_END = sub { 2 };
  	}
  
  	unless( eval { defined O_BINARY() } ) {
  		*O_BINARY = sub { 0 };
  		*O_RDONLY = sub { 0 };
  		*O_WRONLY = sub { 1 };
  	}
  
  	unless ( eval { defined O_APPEND() } ) {
  
  		if ( $^O =~ /olaris/ ) {
  			*O_APPEND = sub { 8 };
  			*O_CREAT = sub { 256 };
  			*O_EXCL = sub { 1024 };
  		}
  		elsif ( $^O =~ /inux/ ) {
  			*O_APPEND = sub { 1024 };
  			*O_CREAT = sub { 64 };
  			*O_EXCL = sub { 128 };
  		}
  		elsif ( $^O =~ /BSD/i ) {
  			*O_APPEND = sub { 8 };
  			*O_CREAT = sub { 512 };
  			*O_EXCL = sub { 2048 };
  		}
  	}
  }
  
  # print "OS [$^O]\n" ;
  
  # print "O_BINARY = ", O_BINARY(), "\n" ;
  # print "O_RDONLY = ", O_RDONLY(), "\n" ;
  # print "O_WRONLY = ", O_WRONLY(), "\n" ;
  # print "O_APPEND = ", O_APPEND(), "\n" ;
  # print "O_CREAT   ", O_CREAT(), "\n" ;
  # print "O_EXCL   ", O_EXCL(), "\n" ;
  
  use base 'Exporter' ;
  use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
  
  %EXPORT_TAGS = ( 'all' => [
  	qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
  
  @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
  @EXPORT_OK = qw( slurp ) ;
  
  $VERSION = '9999.13';
  
  *slurp = \&read_file ;
  
  sub read_file {
  
  	my( $file_name, %args ) = @_ ;
  
  # set the buffer to either the passed in one or ours and init it to the null
  # string
  
  	my $buf ;
  	my $buf_ref = $args{'buf_ref'} || \$buf ;
  	${$buf_ref} = '' ;
  
  	my( $read_fh, $size_left, $blk_size ) ;
  
  # check if we are reading from a handle (glob ref or IO:: object)
  
  	if ( ref $file_name ) {
  
  # slurping a handle so use it and don't open anything.
  # set the block size so we know it is a handle and read that amount
  
  		$read_fh = $file_name ;
  		$blk_size = $args{'blk_size'} || 1024 * 1024 ;
  		$size_left = $blk_size ;
  
  # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
  # glob/handle. only the DATA handle is untainted (since it is from
  # trusted data in the source file). this allows us to test if this is
  # the DATA handle and then to do a sysseek to make sure it gets
  # slurped correctly. on some systems, the buffered i/o pointer is not
  # left at the same place as the fd pointer. this sysseek makes them
  # the same so slurping with sysread will work.
  
  		eval{ require B } ;
  
  		if ( $@ ) {
  
  			@_ = ( \%args, <<ERR ) ;
  Can't find B.pm with this Perl: $!.
  That module is needed to slurp the DATA handle.
  ERR
  			goto &_error ;
  		}
  
  		if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
  
  # set the seek position to the current tell.
  
  			sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
  				croak "sysseek $!" ;
  		}
  	}
  	else {
  
  # a regular file. set the sysopen mode
  
  		my $mode = O_RDONLY ;
  		$mode |= O_BINARY if $args{'binmode'} ;
  
  #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
  
  # open the file and handle any error
  
  		$read_fh = gensym ;
  		unless ( sysopen( $read_fh, $file_name, $mode ) ) {
  			@_ = ( \%args, "read_file '$file_name' - sysopen: $!");
  			goto &_error ;
  		}
  
  # get the size of the file for use in the read loop
  
  		$size_left = -s $read_fh ;
  
  		unless( $size_left ) {
  
  			$blk_size = $args{'blk_size'} || 1024 * 1024 ;
  			$size_left = $blk_size ;
  		}
  	}
  
  # infinite read loop. we exit when we are done slurping
  
  	while( 1 ) {
  
  # do the read and see how much we got
  
  		my $read_cnt = sysread( $read_fh, ${$buf_ref},
  				$size_left, length ${$buf_ref} ) ;
  
  		if ( defined $read_cnt ) {
  
  # good read. see if we hit EOF (nothing left to read)
  
  			last if $read_cnt == 0 ;
  
  # loop if we are slurping a handle. we don't track $size_left then.
  
  			next if $blk_size ;
  
  # count down how much we read and loop if we have more to read.
  			$size_left -= $read_cnt ;
  			last if $size_left <= 0 ;
  			next ;
  		}
  
  # handle the read error
  
  		@_ = ( \%args, "read_file '$file_name' - sysread: $!");
  		goto &_error ;
  	}
  
  # fix up cr/lf to be a newline if this is a windows text file
  
  	${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
  
  # this is the 5 returns in a row. each handles one possible
  # combination of caller context and requested return type
  
  	my $sep = $/ ;
  	$sep = '\n\n+' if defined $sep && $sep eq '' ;
  
  # caller wants to get an array ref of lines
  
  # this split doesn't work since it tries to use variable length lookbehind
  # the m// line works.
  #	return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'}  ;
  	return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
  		if $args{'array_ref'}  ;
  
  # caller wants a list of lines (normal list context)
  
  # same problem with this split as before.
  #	return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
  	return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
  		if wantarray ;
  
  # caller wants a scalar ref to the slurped text
  
  	return $buf_ref if $args{'scalar_ref'} ;
  
  # caller wants a scalar with the slurped text (normal scalar context)
  
  	return ${$buf_ref} if defined wantarray ;
  
  # caller passed in an i/o buffer by reference (normal void context)
  
  	return ;
  }
  
  sub write_file {
  
  	my $file_name = shift ;
  
  # get the optional argument hash ref from @_ or an empty hash ref.
  
  	my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
  
  	my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
  
  # get the buffer ref - it depends on how the data is passed into write_file
  # after this if/else $buf_ref will have a scalar ref to the data.
  
  	if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {
  
  # a scalar ref passed in %args has the data
  # note that the data was passed by ref
  
  		$buf_ref = $args->{'buf_ref'} ;
  		$data_is_ref = 1 ;
  	}
  	elsif ( ref $_[0] eq 'SCALAR' ) {
  
  # the first value in @_ is the scalar ref to the data
  # note that the data was passed by ref
  
  		$buf_ref = shift ;
  		$data_is_ref = 1 ;
  	}
  	elsif ( ref $_[0] eq 'ARRAY' ) {
  
  # the first value in @_ is the array ref to the data so join it.
  
  		${$buf_ref} = join '', @{$_[0]} ;
  	}
  	else {
  
  # good old @_ has all the data so join it.
  
  		${$buf_ref} = join '', @_ ;
  	}
  
  # see if we were passed a open handle to spew to.
  
  	if ( ref $file_name ) {
  
  # we have a handle. make sure we don't call truncate on it.
  
  		$write_fh = $file_name ;
  		$no_truncate = 1 ;
  	}
  	else {
  
  # spew to regular file.
  
  		if ( $args->{'atomic'} ) {
  
  # in atomic mode, we spew to a temp file so make one and save the original
  # file name.
  			$orig_file_name = $file_name ;
  			$file_name .= ".$$" ;
  		}
  
  # set the mode for the sysopen
  
  		my $mode = O_WRONLY | O_CREAT ;
  		$mode |= O_BINARY if $args->{'binmode'} ;
  		$mode |= O_APPEND if $args->{'append'} ;
  		$mode |= O_EXCL if $args->{'no_clobber'} ;
  
  #printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
  
  # open the file and handle any error.
  
  		$write_fh = gensym ;
  		unless ( sysopen( $write_fh, $file_name, $mode ) ) {
  			@_ = ( $args, "write_file '$file_name' - sysopen: $!");
  			goto &_error ;
  		}
  	}
  
  	sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;
  
  
  #print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
  
  # fix up newline to write cr/lf if this is a windows text file
  
  	if ( $is_win32 && !$args->{'binmode'} ) {
  
  # copy the write data if it was passed by ref so we don't clobber the
  # caller's data
  		$buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
  		${$buf_ref} =~ s/\n/\015\012/g ;
  	}
  
  #print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
  
  # get the size of how much we are writing and init the offset into that buffer
  
  	my $size_left = length( ${$buf_ref} ) ;
  	my $offset = 0 ;
  
  # loop until we have no more data left to write
  
  	do {
  
  # do the write and track how much we just wrote
  
  		my $write_cnt = syswrite( $write_fh, ${$buf_ref},
  				$size_left, $offset ) ;
  
  		unless ( defined $write_cnt ) {
  
  # the write failed
  			@_ = ( $args, "write_file '$file_name' - syswrite: $!");
  			goto &_error ;
  		}
  
  # track much left to write and where to write from in the buffer
  
  		$size_left -= $write_cnt ;
  		$offset += $write_cnt ;
  
  	} while( $size_left > 0 ) ;
  
  # we truncate regular files in case we overwrite a long file with a shorter file
  # so seek to the current position to get it (same as tell()).
  
  	truncate( $write_fh,
  		  sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
  
  	close( $write_fh ) ;
  
  # handle the atomic mode - move the temp file to the original filename.
  
  	rename( $file_name, $orig_file_name ) if $args->{'atomic'} ;
  
  	return 1 ;
  }
  
  # this is for backwards compatibility with the previous File::Slurp module. 
  # write_file always overwrites an existing file
  
  *overwrite_file = \&write_file ;
  
  # the current write_file has an append mode so we use that. this
  # supports the same API with an optional second argument which is a
  # hash ref of options.
  
  sub append_file {
  
  # get the optional args hash ref
  	my $args = $_[1] ;
  	if ( ref $args eq 'HASH' ) {
  
  # we were passed an args ref so just mark the append mode
  
  		$args->{append} = 1 ;
  	}
  	else {
  
  # no args hash so insert one with the append mode
  
  		splice( @_, 1, 0, { append => 1 } ) ;
  	}
  
  # magic goto the main write_file sub. this overlays the sub without touching
  # the stack or @_
  
  	goto &write_file
  }
  
  # basic wrapper around opendir/readdir
  
  sub read_dir {
  
  	my ($dir, %args ) = @_;
  
  # this handle will be destroyed upon return
  
  	local(*DIRH);
  
  # open the dir and handle any errors
  
  	unless ( opendir( DIRH, $dir ) ) {
  
  		@_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ;
  		goto &_error ;
  	}
  
  	my @dir_entries = readdir(DIRH) ;
  
  	@dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
  		unless $args{'keep_dot_dot'} ;
  
  	return @dir_entries if wantarray ;
  	return \@dir_entries ;
  }
  
  # error handling section
  #
  # all the error handling uses magic goto so the caller will get the
  # error message as if from their code and not this module. if we just
  # did a call on the error code, the carp/croak would report it from
  # this module since the error sub is one level down on the call stack
  # from read_file/write_file/read_dir.
  
  
  my %err_func = (
  	'carp'	=> \&carp,
  	'croak'	=> \&croak,
  ) ;
  
  sub _error {
  
  	my( $args, $err_msg ) = @_ ;
  
  # get the error function to use
  
   	my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
  
  # if we didn't find it in our error function hash, they must have set
  # it to quiet and we don't do anything.
  
  	return unless $func ;
  
  # call the carp/croak function
  
  	$func->($err_msg) ;
  
  # return a hard undef (in list context this will be a single value of
  # undef which is not a legal in-band value)
  
  	return undef ;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  File::Slurp - Efficient Reading/Writing of Complete Files
  
  =head1 SYNOPSIS
  
    use File::Slurp;
  
    my $text = read_file( 'filename' ) ;
    my @lines = read_file( 'filename' ) ;
  
    write_file( 'filename', @lines ) ;
  
    use File::Slurp qw( slurp ) ;
  
    my $text = slurp( 'filename' ) ;
  
  
  =head1 DESCRIPTION
  
  This module provides subs that allow you to read or write entire files
  with one simple call. They are designed to be simple to use, have
  flexible ways to pass in or get the file contents and to be very
  efficient.  There is also a sub to read in all the files in a
  directory other than C<.> and C<..>
  
  These slurp/spew subs work for files, pipes and
  sockets, and stdio, pseudo-files, and DATA.
  
  =head2 B<read_file>
  
  This sub reads in an entire file and returns its contents to the
  caller. In list context it will return a list of lines (using the
  current value of $/ as the separator including support for paragraph
  mode when it is set to ''). In scalar context it returns the entire
  file as a single scalar.
  
    my $text = read_file( 'filename' ) ;
    my @lines = read_file( 'filename' ) ;
  
  The first argument to C<read_file> is the filename and the rest of the
  arguments are key/value pairs which are optional and which modify the
  behavior of the call. Other than binmode the options all control how
  the slurped file is returned to the caller.
  
  If the first argument is a file handle reference or I/O object (if ref
  is true), then that handle is slurped in. This mode is supported so
  you slurp handles such as C<DATA>, C<STDIN>. See the test handle.t
  for an example that does C<open( '-|' )> and child process spews data
  to the parant which slurps it in.  All of the options that control how
  the data is returned to the caller still work in this case.
  
  NOTE: as of version 9999.06, read_file works correctly on the C<DATA>
  handle. It used to need a sysseek workaround but that is now handled
  when needed by the module itself.
  
  You can optionally request that C<slurp()> is exported to your code. This
  is an alias for read_file and is meant to be forward compatible with
  Perl 6 (which will have slurp() built-in).
  
  The options are:
  
  =head3 binmode
  
  If you set the binmode option, then the file will be slurped in binary
  mode.
  
  	my $bin_data = read_file( $bin_file, binmode => ':raw' ) ;
  
  NOTE: this actually sets the O_BINARY mode flag for sysopen. It
  probably should call binmode and pass its argument to support other
  file modes.
  
  =head3 array_ref
  
  If this boolean option is set, the return value (only in scalar
  context) will be an array reference which contains the lines of the
  slurped file. The following two calls are equivalent:
  
  	my $lines_ref = read_file( $bin_file, array_ref => 1 ) ;
  	my $lines_ref = [ read_file( $bin_file ) ] ;
  
  =head3 scalar_ref
  
  If this boolean option is set, the return value (only in scalar
  context) will be an scalar reference to a string which is the contents
  of the slurped file. This will usually be faster than returning the
  plain scalar.
  
  	my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ;
  
  =head3 buf_ref
  
  You can use this option to pass in a scalar reference and the slurped
  file contents will be stored in the scalar. This can be used in
  conjunction with any of the other options.
  
  	my $text_ref = read_file( $bin_file, buf_ref => \$buffer,
  					     array_ref => 1 ) ;
  	my @lines = read_file( $bin_file, buf_ref => \$buffer ) ;
  
  =head3 blk_size
  
  You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB.
  
  	my $text_ref = read_file( $bin_file, blk_size => 10_000_000,
  					     array_ref => 1 ) ;
  
  =head3 err_mode
  
  You can use this option to control how read_file behaves when an error
  occurs. This option defaults to 'croak'. You can set it to 'carp' or
  to 'quiet to have no error handling. This code wants to carp and then
  read abother file if it fails.
  
  	my $text_ref = read_file( $file, err_mode => 'carp' ) ;
  	unless ( $text_ref ) {
  
  		# read a different file but croak if not found
  		$text_ref = read_file( $another_file ) ;
  	}
  	
  	# process ${$text_ref}
  
  =head2 B<write_file>
  
  This sub writes out an entire file in one call.
  
    write_file( 'filename', @data ) ;
  
  The first argument to C<write_file> is the filename. The next argument
  is an optional hash reference and it contains key/values that can
  modify the behavior of C<write_file>. The rest of the argument list is
  the data to be written to the file.
  
    write_file( 'filename', {append => 1 }, @data ) ;
    write_file( 'filename', {binmode => ':raw' }, $buffer ) ;
  
  As a shortcut if the first data argument is a scalar or array
  reference, it is used as the only data to be written to the file. Any
  following arguments in @_ are ignored. This is a faster way to pass in
  the output to be written to the file and is equivilent to the
  C<buf_ref> option. These following pairs are equivilent but the pass
  by reference call will be faster in most cases (especially with larger
  files).
  
    write_file( 'filename', \$buffer ) ;
    write_file( 'filename', $buffer ) ;
  
    write_file( 'filename', \@lines ) ;
    write_file( 'filename', @lines ) ;
  
  If the first argument is a file handle reference or I/O object (if ref
  is true), then that handle is slurped in. This mode is supported so
  you spew to handles such as \*STDOUT. See the test handle.t for an
  example that does C<open( '-|' )> and child process spews data to the
  parant which slurps it in.  All of the options that control how the
  data is passes into C<write_file> still work in this case.
  
  C<write_file> returns 1 upon successfully writing the file or undef if
  it encountered an error.
  
  The options are:
  
  =head3 binmode
  
  If you set the binmode option, then the file will be written in binary
  mode.
  
  	write_file( $bin_file, {binmode => ':raw'}, @data ) ;
  
  NOTE: this actually sets the O_BINARY mode flag for sysopen. It
  probably should call binmode and pass its argument to support other
  file modes.
  
  =head3 buf_ref
  
  You can use this option to pass in a scalar reference which has the
  data to be written. If this is set then any data arguments (including
  the scalar reference shortcut) in @_ will be ignored. These are
  equivilent:
  
  	write_file( $bin_file, { buf_ref => \$buffer } ) ;
  	write_file( $bin_file, \$buffer ) ;
  	write_file( $bin_file, $buffer ) ;
  
  =head3 atomic
  
  If you set this boolean option, the file will be written to in an
  atomic fashion. A temporary file name is created by appending the pid
  ($$) to the file name argument and that file is spewed to. After the
  file is closed it is renamed to the original file name (and rename is
  an atomic operation on most OS's). If the program using this were to
  crash in the middle of this, then the file with the pid suffix could
  be left behind.
  
  =head3 append
  
  If you set this boolean option, the data will be written at the end of
  the current file.
  
  	write_file( $file, {append => 1}, @data ) ;
  
  C<write_file> croaks if it cannot open the file. It returns true if it
  succeeded in writing out the file and undef if there was an
  error. (Yes, I know if it croaks it can't return anything but that is
  for when I add the options to select the error handling mode).
  
  =head3 no_clobber
  
  If you set this boolean option, an existing file will not be overwritten.
  
  	write_file( $file, {no_clobber => 1}, @data ) ;
  
  =head3 err_mode
  
  You can use this option to control how C<write_file> behaves when an
  error occurs. This option defaults to 'croak'. You can set it to
  'carp' or to 'quiet' to have no error handling other than the return
  value. If the first call to C<write_file> fails it will carp and then
  write to another file. If the second call to C<write_file> fails, it
  will croak.
  
  	unless ( write_file( $file, { err_mode => 'carp', \$data ) ;
  
  		# write a different file but croak if not found
  		write_file( $other_file, \$data ) ;
  	}
  
  =head2 overwrite_file
  
  This sub is just a typeglob alias to write_file since write_file
  always overwrites an existing file. This sub is supported for
  backwards compatibility with the original version of this module. See
  write_file for its API and behavior.
  
  =head2 append_file
  
  This sub will write its data to the end of the file. It is a wrapper
  around write_file and it has the same API so see that for the full
  documentation. These calls are equivilent:
  
  	append_file( $file, @data ) ;
  	write_file( $file, {append => 1}, @data ) ;
  
  =head2 read_dir
  
  This sub reads all the file names from directory and returns them to
  the caller but C<.> and C<..> are removed by default.
  
  	my @files = read_dir( '/path/to/dir' ) ;
  
  It croaks if it cannot open the directory.
  
  In a list context C<read_dir> returns a list of the entries in the
  directory. In a scalar context it returns an array reference which has
  the entries.
  
  =head3 keep_dot_dot
  
  If this boolean option is set, C<.> and C<..> are not removed from the
  list of files.
  
  	my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ;
  
  =head2 EXPORT
  
    read_file write_file overwrite_file append_file read_dir
  
  =head2 SEE ALSO
  
  An article on file slurping in extras/slurp_article.pod. There is
  also a benchmarking script in extras/slurp_bench.pl.
  
  =head2 BUGS
  
  If run under Perl 5.004, slurping from the DATA handle will fail as
  that requires B.pm which didn't get into core until 5.005.
  
  =head1 AUTHOR
  
  Uri Guttman, E<lt>uri@stemsystems.comE<gt>
  
  =cut
FILE_SLURP

$fatpacked{"HTML/Form.pm"} = <<'HTML_FORM';
  package HTML::Form;
  
  use strict;
  use URI;
  use Carp ();
  
  use vars qw($VERSION $Encode_available);
  $VERSION = "5.829";
  
  eval { require Encode };
  $Encode_available = !$@;
  
  my %form_tags = map {$_ => 1} qw(input textarea button select option);
  
  my %type2class = (
   text     => "TextInput",
   password => "TextInput",
   hidden   => "TextInput",
   textarea => "TextInput",
  
   "reset"  => "IgnoreInput",
  
   radio    => "ListInput",
   checkbox => "ListInput",
   option   => "ListInput",
  
   button   => "SubmitInput",
   submit   => "SubmitInput",
   image    => "ImageInput",
   file     => "FileInput",
  
   keygen   => "KeygenInput",
  );
  
  =head1 NAME
  
  HTML::Form - Class that represents an HTML form element
  
  =head1 SYNOPSIS
  
   use HTML::Form;
   $form = HTML::Form->parse($html, $base_uri);
   $form->value(query => "Perl");
  
   use LWP::UserAgent;
   $ua = LWP::UserAgent->new;
   $response = $ua->request($form->click);
  
  =head1 DESCRIPTION
  
  Objects of the C<HTML::Form> class represents a single HTML
  C<E<lt>formE<gt> ... E<lt>/formE<gt>> instance.  A form consists of a
  sequence of inputs that usually have names, and which can take on
  various values.  The state of a form can be tweaked and it can then be
  asked to provide C<HTTP::Request> objects that can be passed to the
  request() method of C<LWP::UserAgent>.
  
  The following methods are available:
  
  =over 4
  
  =item @forms = HTML::Form->parse( $html_document, $base_uri )
  
  =item @forms = HTML::Form->parse( $html_document, base => $base_uri, %opt )
  
  =item @forms = HTML::Form->parse( $response, %opt )
  
  The parse() class method will parse an HTML document and build up
  C<HTML::Form> objects for each <form> element found.  If called in scalar
  context only returns the first <form>.  Returns an empty list if there
  are no forms to be found.
  
  The required arguments is the HTML document to parse ($html_document) and the
  URI used to retrieve the document ($base_uri).  The base URI is needed to resolve
  relative action URIs.  The provided HTML document should be a Unicode string
  (or US-ASCII).
  
  By default HTML::Form assumes that the original document was UTF-8 encoded and
  thus encode forms that don't specify an explict I<accept-charset> as UTF-8.
  The charset assumed can be overridden by providing the C<charset> option to
  parse().  It's a good idea to be explict about this parameter as well, thus
  the recommended simplest invocation becomes:
  
      my @forms = HTML::Form->parse(
          Encode::decode($encoding, $html_document_bytes),
          base => $base_uri,
  	charset => $encoding,
      );
  
  If the document was retrieved with LWP then the response object provide methods
  to obtain a proper value for C<base> and C<charset>:
  
      my $ua = LWP::UserAgent->new;
      my $response = $ua->get("http://www.example.com/form.html");
      my @forms = HTML::Form->parse($response->decoded_content,
  	base => $response->base,
  	charset => $response->content_charset,
      );
  
  In fact, the parse() method can parse from an C<HTTP::Response> object
  directly, so the example above can be more conveniently written as:
  
      my $ua = LWP::UserAgent->new;
      my $response = $ua->get("http://www.example.com/form.html");
      my @forms = HTML::Form->parse($response);
  
  Note that any object that implements a decoded_content(), base() and
  content_charset() method with similar behaviour as C<HTTP::Response> will do.
  
  Additional options might be passed in to control how the parse method
  behaves.  The following are all the options currently recognized:
  
  =over
  
  =item C<< base => $uri >>
  
  This is the URI used to retrive the original document.  This option is not optional ;-)
  
  =item C<< charset => $str >>
  
  Specify what charset the original document was encoded in.  This is used as
  the default for accept_charset.  If not provided this defaults to "UTF-8".
  
  =item C<< verbose => $bool >>
  
  Warn (print messages to STDERR) about any bad HTML form constructs found.
  You can trap these with $SIG{__WARN__}.
  
  =item C<< strict => $bool >>
  
  Initialize any form objects with the given strict attribute.
  
  =back
  
  =cut
  
  sub parse
  {
      my $class = shift;
      my $html = shift;
      unshift(@_, "base") if @_ == 1;
      my %opt = @_;
  
      require HTML::TokeParser;
      my $p = HTML::TokeParser->new(ref($html) ? $html->decoded_content(ref => 1) : \$html);
      die "Failed to create HTML::TokeParser object" unless $p;
  
      my $base_uri = delete $opt{base};
      my $charset = delete $opt{charset};
      my $strict = delete $opt{strict};
      my $verbose = delete $opt{verbose};
  
      if ($^W) {
  	Carp::carp("Unrecognized option $_ in HTML::Form->parse") for sort keys %opt;
      }
  
      unless (defined $base_uri) {
  	if (ref($html)) {
  	    $base_uri = $html->base;
  	}
  	else {
  	    Carp::croak("HTML::Form::parse: No \$base_uri provided");
  	}
      }
      unless (defined $charset) {
  	if (ref($html) and $html->can("content_charset")) {
  	    $charset = $html->content_charset;
  	}
  	unless ($charset) {
  	    $charset = "UTF-8";
  	}
      }
  
      my @forms;
      my $f;  # current form
  
      my %openselect; # index to the open instance of a select
  
      while (my $t = $p->get_tag) {
  	my($tag,$attr) = @$t;
  	if ($tag eq "form") {
  	    my $action = delete $attr->{'action'};
  	    $action = "" unless defined $action;
  	    $action = URI->new_abs($action, $base_uri);
  	    $f = $class->new($attr->{'method'},
  			     $action,
  			     $attr->{'enctype'});
              $f->accept_charset($attr->{'accept-charset'}) if $attr->{'accept-charset'};
  	    $f->{default_charset} = $charset;
  	    $f->{attr} = $attr;
  	    $f->strict(1) if $strict;
              %openselect = ();
  	    push(@forms, $f);
  	    my(%labels, $current_label);
  	    while (my $t = $p->get_tag) {
  		my($tag, $attr) = @$t;
  		last if $tag eq "/form";
  
  		# if we are inside a label tag, then keep
  		# appending any text to the current label
  		if(defined $current_label) {
  		    $current_label = join " ",
  		        grep { defined and length }
  		        $current_label,
  		        $p->get_phrase;
  		}
  
  		if ($tag eq "input") {
  		    $attr->{value_name} =
  		        exists $attr->{id} && exists $labels{$attr->{id}} ? $labels{$attr->{id}} :
  			defined $current_label                            ?  $current_label      :
  		        $p->get_phrase;
  		}
  
  		if ($tag eq "label") {
  		    $current_label = $p->get_phrase;
  		    $labels{ $attr->{for} } = $current_label
  		        if exists $attr->{for};
  		}
  		elsif ($tag eq "/label") {
  		    $current_label = undef;
  		}
  		elsif ($tag eq "input") {
  		    my $type = delete $attr->{type} || "text";
  		    $f->push_input($type, $attr, $verbose);
  		}
                  elsif ($tag eq "button") {
                      my $type = delete $attr->{type} || "submit";
                      $f->push_input($type, $attr, $verbose);
                  }
  		elsif ($tag eq "textarea") {
  		    $attr->{textarea_value} = $attr->{value}
  		        if exists $attr->{value};
  		    my $text = $p->get_text("/textarea");
  		    $attr->{value} = $text;
  		    $f->push_input("textarea", $attr, $verbose);
  		}
  		elsif ($tag eq "select") {
  		    # rename attributes reserved to come for the option tag
  		    for ("value", "value_name") {
  			$attr->{"select_$_"} = delete $attr->{$_}
  			    if exists $attr->{$_};
  		    }
  		    # count this new select option separately
  		    my $name = $attr->{name};
  		    $name = "" unless defined $name;
  		    $openselect{$name}++;
  
  		    while ($t = $p->get_tag) {
  			my $tag = shift @$t;
  			last if $tag eq "/select";
  			next if $tag =~ m,/?optgroup,;
  			next if $tag eq "/option";
  			if ($tag eq "option") {
  			    my %a = %{$t->[0]};
  			    # rename keys so they don't clash with %attr
  			    for (keys %a) {
  				next if $_ eq "value";
  				$a{"option_$_"} = delete $a{$_};
  			    }
  			    while (my($k,$v) = each %$attr) {
  				$a{$k} = $v;
  			    }
  			    $a{value_name} = $p->get_trimmed_text;
  			    $a{value} = delete $a{value_name}
  				unless defined $a{value};
  			    $a{idx} = $openselect{$name};
  			    $f->push_input("option", \%a, $verbose);
  			}
  			else {
  			    warn("Bad <select> tag '$tag' in $base_uri\n") if $verbose;
  			    if ($tag eq "/form" ||
  				$tag eq "input" ||
  				$tag eq "textarea" ||
  				$tag eq "select" ||
  				$tag eq "keygen")
  			    {
  				# MSIE implictly terminate the <select> here, so we
  				# try to do the same.  Actually the MSIE behaviour
  				# appears really strange:  <input> and <textarea>
  				# do implictly close, but not <select>, <keygen> or
  				# </form>.
  				my $type = ($tag =~ s,^/,,) ? "E" : "S";
  				$p->unget_token([$type, $tag, @$t]);
  				last;
  			    }
  			}
  		    }
  		}
  		elsif ($tag eq "keygen") {
  		    $f->push_input("keygen", $attr, $verbose);
  		}
  	    }
  	}
  	elsif ($form_tags{$tag}) {
  	    warn("<$tag> outside <form> in $base_uri\n") if $verbose;
  	}
      }
      for (@forms) {
  	$_->fixup;
      }
  
      wantarray ? @forms : $forms[0];
  }
  
  sub new {
      my $class = shift;
      my $self = bless {}, $class;
      $self->{method} = uc(shift  || "GET");
      $self->{action} = shift  || Carp::croak("No action defined");
      $self->{enctype} = lc(shift || "application/x-www-form-urlencoded");
      $self->{accept_charset} = "UNKNOWN";
      $self->{default_charset} = "UTF-8";
      $self->{inputs} = [@_];
      $self;
  }
  
  
  sub push_input
  {
      my($self, $type, $attr, $verbose) = @_;
      $type = lc $type;
      my $class = $type2class{$type};
      unless ($class) {
  	Carp::carp("Unknown input type '$type'") if $verbose;
  	$class = "TextInput";
      }
      $class = "HTML::Form::$class";
      my @extra;
      push(@extra, readonly => 1) if $type eq "hidden";
      push(@extra, strict => 1) if $self->{strict};
      if ($type eq "file" && exists $attr->{value}) {
  	# it's not safe to trust the value set by the server
  	# the user always need to explictly set the names of files to upload
  	$attr->{orig_value} = delete $attr->{value};
      }
      delete $attr->{type}; # don't confuse the type argument
      my $input = $class->new(type => $type, %$attr, @extra);
      $input->add_to_form($self);
  }
  
  
  =item $method = $form->method
  
  =item $form->method( $new_method )
  
  This method is gets/sets the I<method> name used for the
  C<HTTP::Request> generated.  It is a string like "GET" or "POST".
  
  =item $action = $form->action
  
  =item $form->action( $new_action )
  
  This method gets/sets the URI which we want to apply the request
  I<method> to.
  
  =item $enctype = $form->enctype
  
  =item $form->enctype( $new_enctype )
  
  This method gets/sets the encoding type for the form data.  It is a
  string like "application/x-www-form-urlencoded" or "multipart/form-data".
  
  =item $accept = $form->accept_charset
  
  =item $form->accept_charset( $new_accept )
  
  This method gets/sets the list of charset encodings that the server processing
  the form accepts. Current implementation supports only one-element lists.
  Default value is "UNKNOWN" which we interpret as a request to use document
  charset as specified by the 'charset' parameter of the parse() method. To
  encode character strings you should have modern perl with Encode module. On
  older perls the setting of this attribute has no effect.
  
  =cut
  
  BEGIN {
      # Set up some accesor
      for (qw(method action enctype accept_charset)) {
  	my $m = $_;
  	no strict 'refs';
  	*{$m} = sub {
  	    my $self = shift;
  	    my $old = $self->{$m};
  	    $self->{$m} = shift if @_;
  	    $old;
  	};
      }
      *uri = \&action;  # alias
  }
  
  =item $value = $form->attr( $name )
  
  =item $form->attr( $name, $new_value )
  
  This method give access to the original HTML attributes of the <form> tag.
  The $name should always be passed in lower case.
  
  Example:
  
     @f = HTML::Form->parse( $html, $foo );
     @f = grep $_->attr("id") eq "foo", @f;
     die "No form named 'foo' found" unless @f;
     $foo = shift @f;
  
  =cut
  
  sub attr {
      my $self = shift;
      my $name = shift;
      return undef unless defined $name;
  
      my $old = $self->{attr}{$name};
      $self->{attr}{$name} = shift if @_;
      return $old;
  }
  
  =item $bool = $form->strict
  
  =item $form->strict( $bool )
  
  Gets/sets the strict attribute of a form.  If the strict is turned on
  the methods that change values of the form will croak if you try to
  set illegal values or modify readonly fields.  The default is not to be strict.
  
  =cut
  
  sub strict {
      my $self = shift;
      my $old = $self->{strict};
      if (@_) {
  	$self->{strict} = shift;
  	for my $input (@{$self->{inputs}}) {
  	    $input->strict($self->{strict});
  	}
      }
      return $old;
  }
  
  
  =item @inputs = $form->inputs
  
  This method returns the list of inputs in the form.  If called in
  scalar context it returns the number of inputs contained in the form.
  See L</INPUTS> for what methods are available for the input objects
  returned.
  
  =cut
  
  sub inputs
  {
      my $self = shift;
      @{$self->{'inputs'}};
  }
  
  
  =item $input = $form->find_input( $selector )
  
  =item $input = $form->find_input( $selector, $type )
  
  =item $input = $form->find_input( $selector, $type, $index )
  
  This method is used to locate specific inputs within the form.  All
  inputs that match the arguments given are returned.  In scalar context
  only the first is returned, or C<undef> if none match.
  
  If $selector is specified, then the input's name, id, class attribute must
  match.  A selector prefixed with '#' must match the id attribute of the input.
  A selector prefixed with '.' matches the class attribute.  A selector prefixed
  with '^' or with no prefix matches the name attribute.
  
  If $type is specified, then the input must have the specified type.
  The following type names are used: "text", "password", "hidden",
  "textarea", "file", "image", "submit", "radio", "checkbox" and "option".
  
  The $index is the sequence number of the input matched where 1 is the
  first.  If combined with $name and/or $type then it select the I<n>th
  input with the given name and/or type.
  
  =cut
  
  sub find_input
  {
      my($self, $name, $type, $no) = @_;
      if (wantarray) {
  	my @res;
  	my $c;
  	for (@{$self->{'inputs'}}) {
  	    next if defined($name) && !$_->selected($name);
  	    next if $type && $type ne $_->{type};
  	    $c++;
  	    next if $no && $no != $c;
  	    push(@res, $_);
  	}
  	return @res;
  	
      }
      else {
  	$no ||= 1;
  	for (@{$self->{'inputs'}}) {
  	    next if defined($name) && !$_->selected($name);
  	    next if $type && $type ne $_->{type};
  	    next if --$no;
  	    return $_;
  	}
  	return undef;
      }
  }
  
  sub fixup
  {
      my $self = shift;
      for (@{$self->{'inputs'}}) {
  	$_->fixup;
      }
  }
  
  
  =item $value = $form->value( $selector )
  
  =item $form->value( $selector, $new_value )
  
  The value() method can be used to get/set the value of some input.  If
  strict is enabled and no input has the indicated name, then this method will croak.
  
  If multiple inputs have the same name, only the first one will be
  affected.
  
  The call:
  
      $form->value('foo')
  
  is basically a short-hand for:
  
      $form->find_input('foo')->value;
  
  =cut
  
  sub value
  {
      my $self = shift;
      my $key  = shift;
      my $input = $self->find_input($key);
      unless ($input) {
  	Carp::croak("No such field '$key'") if $self->{strict};
  	return undef unless @_;
  	$input = $self->push_input("text", { name => $key, value => "" });
      }
      local $Carp::CarpLevel = 1;
      $input->value(@_);
  }
  
  =item @names = $form->param
  
  =item @values = $form->param( $name )
  
  =item $form->param( $name, $value, ... )
  
  =item $form->param( $name, \@values )
  
  Alternative interface to examining and setting the values of the form.
  
  If called without arguments then it returns the names of all the
  inputs in the form.  The names will not repeat even if multiple inputs
  have the same name.  In scalar context the number of different names
  is returned.
  
  If called with a single argument then it returns the value or values
  of inputs with the given name.  If called in scalar context only the
  first value is returned.  If no input exists with the given name, then
  C<undef> is returned.
  
  If called with 2 or more arguments then it will set values of the
  named inputs.  This form will croak if no inputs have the given name
  or if any of the values provided does not fit.  Values can also be
  provided as a reference to an array.  This form will allow unsetting
  all values with the given name as well.
  
  This interface resembles that of the param() function of the CGI
  module.
  
  =cut
  
  sub param {
      my $self = shift;
      if (@_) {
          my $name = shift;
          my @inputs;
          for ($self->inputs) {
              my $n = $_->name;
              next if !defined($n) || $n ne $name;
              push(@inputs, $_);
          }
  
          if (@_) {
              # set
              die "No '$name' parameter exists" unless @inputs;
  	    my @v = @_;
  	    @v = @{$v[0]} if @v == 1 && ref($v[0]);
              while (@v) {
                  my $v = shift @v;
                  my $err;
                  for my $i (0 .. @inputs-1) {
                      eval {
                          $inputs[$i]->value($v);
                      };
                      unless ($@) {
                          undef($err);
                          splice(@inputs, $i, 1);
                          last;
                      }
                      $err ||= $@;
                  }
                  die $err if $err;
              }
  
  	    # the rest of the input should be cleared
  	    for (@inputs) {
  		$_->value(undef);
  	    }
          }
          else {
              # get
              my @v;
              for (@inputs) {
  		if (defined(my $v = $_->value)) {
  		    push(@v, $v);
  		}
              }
              return wantarray ? @v : $v[0];
          }
      }
      else {
          # list parameter names
          my @n;
          my %seen;
          for ($self->inputs) {
              my $n = $_->name;
              next if !defined($n) || $seen{$n}++;
              push(@n, $n);
          }
          return @n;
      }
  }
  
  
  =item $form->try_others( \&callback )
  
  This method will iterate over all permutations of unvisited enumerated
  values (<select>, <radio>, <checkbox>) and invoke the callback for
  each.  The callback is passed the $form as argument.  The return value
  from the callback is ignored and the try_others() method itself does
  not return anything.
  
  =cut
  
  sub try_others
  {
      my($self, $cb) = @_;
      my @try;
      for (@{$self->{'inputs'}}) {
  	my @not_tried_yet = $_->other_possible_values;
  	next unless @not_tried_yet;
  	push(@try, [\@not_tried_yet, $_]);
      }
      return unless @try;
      $self->_try($cb, \@try, 0);
  }
  
  sub _try
  {
      my($self, $cb, $try, $i) = @_;
      for (@{$try->[$i][0]}) {
  	$try->[$i][1]->value($_);
  	&$cb($self);
  	$self->_try($cb, $try, $i+1) if $i+1 < @$try;
      }
  }
  
  
  =item $request = $form->make_request
  
  Will return an C<HTTP::Request> object that reflects the current setting
  of the form.  You might want to use the click() method instead.
  
  =cut
  
  sub make_request
  {
      my $self = shift;
      my $method  = uc $self->{'method'};
      my $uri     = $self->{'action'};
      my $enctype = $self->{'enctype'};
      my @form    = $self->form;
  
      my $charset = $self->accept_charset eq "UNKNOWN" ? $self->{default_charset} : $self->accept_charset;
      if ($Encode_available) {
          foreach my $fi (@form) {
              $fi = Encode::encode($charset, $fi) unless ref($fi);
          }
      }
  
      if ($method eq "GET") {
  	require HTTP::Request;
  	$uri = URI->new($uri, "http");
  	$uri->query_form(@form);
  	return HTTP::Request->new(GET => $uri);
      }
      elsif ($method eq "POST") {
  	require HTTP::Request::Common;
  	return HTTP::Request::Common::POST($uri, \@form,
  					   Content_Type => $enctype);
      }
      else {
  	Carp::croak("Unknown method '$method'");
      }
  }
  
  
  =item $request = $form->click
  
  =item $request = $form->click( $selector )
  
  =item $request = $form->click( $x, $y )
  
  =item $request = $form->click( $selector, $x, $y )
  
  Will "click" on the first clickable input (which will be of type
  C<submit> or C<image>).  The result of clicking is an C<HTTP::Request>
  object that can then be passed to C<LWP::UserAgent> if you want to
  obtain the server response.
  
  If a $selector is specified, we will click on the first clickable input
  matching the selector, and the method will croak if no matching clickable
  input is found.  If $selector is I<not> specified, then it
  is ok if the form contains no clickable inputs.  In this case the
  click() method returns the same request as the make_request() method
  would do.  See description of the find_input() method above for how
  the $selector is specified.
  
  If there are multiple clickable inputs with the same name, then there
  is no way to get the click() method of the C<HTML::Form> to click on
  any but the first.  If you need this you would have to locate the
  input with find_input() and invoke the click() method on the given
  input yourself.
  
  A click coordinate pair can also be provided, but this only makes a
  difference if you clicked on an image.  The default coordinate is
  (1,1).  The upper-left corner of the image is (0,0), but some badly
  coded CGI scripts are known to not recognize this.  Therefore (1,1) was
  selected as a safer default.
  
  =cut
  
  sub click
  {
      my $self = shift;
      my $name;
      $name = shift if (@_ % 2) == 1;  # odd number of arguments
  
      # try to find first submit button to activate
      for (@{$self->{'inputs'}}) {
          next unless $_->can("click");
          next if $name && !$_->selected($name);
  	next if $_->disabled;
  	return $_->click($self, @_);
      }
      Carp::croak("No clickable input with name $name") if $name;
      $self->make_request;
  }
  
  
  =item @kw = $form->form
  
  Returns the current setting as a sequence of key/value pairs.  Note
  that keys might be repeated, which means that some values might be
  lost if the return values are assigned to a hash.
  
  In scalar context this method returns the number of key/value pairs
  generated.
  
  =cut
  
  sub form
  {
      my $self = shift;
      map { $_->form_name_value($self) } @{$self->{'inputs'}};
  }
  
  
  =item $form->dump
  
  Returns a textual representation of current state of the form.  Mainly
  useful for debugging.  If called in void context, then the dump is
  printed on STDERR.
  
  =cut
  
  sub dump
  {
      my $self = shift;
      my $method  = $self->{'method'};
      my $uri     = $self->{'action'};
      my $enctype = $self->{'enctype'};
      my $dump = "$method $uri";
      $dump .= " ($enctype)"
  	if $enctype ne "application/x-www-form-urlencoded";
      $dump .= " [$self->{attr}{name}]"
      	if exists $self->{attr}{name};
      $dump .= "\n";
      for ($self->inputs) {
  	$dump .= "  " . $_->dump . "\n";
      }
      print STDERR $dump unless defined wantarray;
      $dump;
  }
  
  
  #---------------------------------------------------
  package HTML::Form::Input;
  
  =back
  
  =head1 INPUTS
  
  An C<HTML::Form> objects contains a sequence of I<inputs>.  References to
  the inputs can be obtained with the $form->inputs or $form->find_input
  methods.
  
  Note that there is I<not> a one-to-one correspondence between input
  I<objects> and E<lt>inputE<gt> I<elements> in the HTML document.  An
  input object basically represents a name/value pair, so when multiple
  HTML elements contribute to the same name/value pair in the submitted
  form they are combined.
  
  The input elements that are mapped one-to-one are "text", "textarea",
  "password", "hidden", "file", "image", "submit" and "checkbox".  For
  the "radio" and "option" inputs the story is not as simple: All
  E<lt>input type="radio"E<gt> elements with the same name will
  contribute to the same input radio object.  The number of radio input
  objects will be the same as the number of distinct names used for the
  E<lt>input type="radio"E<gt> elements.  For a E<lt>selectE<gt> element
  without the C<multiple> attribute there will be one input object of
  type of "option".  For a E<lt>select multipleE<gt> element there will
  be one input object for each contained E<lt>optionE<gt> element.  Each
  one of these option objects will have the same name.
  
  The following methods are available for the I<input> objects:
  
  =over 4
  
  =cut
  
  sub new
  {
      my $class = shift;
      my $self = bless {@_}, $class;
      $self;
  }
  
  sub add_to_form
  {
      my($self, $form) = @_;
      push(@{$form->{'inputs'}}, $self);
      $self;
  }
  
  sub strict {
      my $self = shift;
      my $old = $self->{strict};
      if (@_) {
  	$self->{strict} = shift;
      }
      $old;
  }
  
  sub fixup {}
  
  
  =item $input->type
  
  Returns the type of this input.  The type is one of the following
  strings: "text", "password", "hidden", "textarea", "file", "image", "submit",
  "radio", "checkbox" or "option".
  
  =cut
  
  sub type
  {
      shift->{type};
  }
  
  =item $name = $input->name
  
  =item $input->name( $new_name )
  
  This method can be used to get/set the current name of the input.
  
  =item $input->id
  
  =item $input->class
  
  These methods can be used to get/set the current id or class attribute for the input.
  
  =item $input->selected( $selector )
  
  Returns TRUE if the given selector matched the input.  See the description of
  the find_input() method above for a description of the selector syntax.
  
  =item $value = $input->value
  
  =item $input->value( $new_value )
  
  This method can be used to get/set the current value of an
  input.
  
  If strict is enabled and the input only can take an enumerated list of values,
  then it is an error to try to set it to something else and the method will
  croak if you try.
  
  You will also be able to set the value of read-only inputs, but a
  warning will be generated if running under C<perl -w>.
  
  =cut
  
  sub name
  {
      my $self = shift;
      my $old = $self->{name};
      $self->{name} = shift if @_;
      $old;
  }
  
  sub id
  {
      my $self = shift;
      my $old = $self->{id};
      $self->{id} = shift if @_;
      $old;
  }
  
  sub class
  {
      my $self = shift;
      my $old = $self->{class};
      $self->{class} = shift if @_;
      $old;
  }
  
  sub selected {
      my($self, $sel) = @_;
      return undef unless defined $sel;
      my $attr =
          $sel =~ s/^\^// ? "name"  :
          $sel =~ s/^#//  ? "id"    :
          $sel =~ s/^\.// ? "class" :
  	                  "name";
      return 0 unless defined $self->{$attr};
      return $self->{$attr} eq $sel;
  }
  
  sub value
  {
      my $self = shift;
      my $old = $self->{value};
      $self->{value} = shift if @_;
      $old;
  }
  
  =item $input->possible_values
  
  Returns a list of all values that an input can take.  For inputs that
  do not have discrete values, this returns an empty list.
  
  =cut
  
  sub possible_values
  {
      return;
  }
  
  =item $input->other_possible_values
  
  Returns a list of all values not tried yet.
  
  =cut
  
  sub other_possible_values
  {
      return;
  }
  
  =item $input->value_names
  
  For some inputs the values can have names that are different from the
  values themselves.  The number of names returned by this method will
  match the number of values reported by $input->possible_values.
  
  When setting values using the value() method it is also possible to
  use the value names in place of the value itself.
  
  =cut
  
  sub value_names {
      return
  }
  
  =item $bool = $input->readonly
  
  =item $input->readonly( $bool )
  
  This method is used to get/set the value of the readonly attribute.
  You are allowed to modify the value of readonly inputs, but setting
  the value will generate some noise when warnings are enabled.  Hidden
  fields always start out readonly.
  
  =cut
  
  sub readonly {
      my $self = shift;
      my $old = $self->{readonly};
      $self->{readonly} = shift if @_;
      $old;
  }
  
  =item $bool = $input->disabled
  
  =item $input->disabled( $bool )
  
  This method is used to get/set the value of the disabled attribute.
  Disabled inputs do not contribute any key/value pairs for the form
  value.
  
  =cut
  
  sub disabled {
      my $self = shift;
      my $old = $self->{disabled};
      $self->{disabled} = shift if @_;
      $old;
  }
  
  =item $input->form_name_value
  
  Returns a (possible empty) list of key/value pairs that should be
  incorporated in the form value from this input.
  
  =cut
  
  sub form_name_value
  {
      my $self = shift;
      my $name = $self->{'name'};
      return unless defined $name;
      return if $self->disabled;
      my $value = $self->value;
      return unless defined $value;
      return ($name => $value);
  }
  
  sub dump
  {
      my $self = shift;
      my $name = $self->name;
      $name = "<NONAME>" unless defined $name;
      my $value = $self->value;
      $value = "<UNDEF>" unless defined $value;
      my $dump = "$name=$value";
  
      my $type = $self->type;
  
      $type .= " disabled" if $self->disabled;
      $type .= " readonly" if $self->readonly;
      return sprintf "%-30s %s", $dump, "($type)" unless $self->{menu};
  
      my @menu;
      my $i = 0;
      for (@{$self->{menu}}) {
  	my $opt = $_->{value};
  	$opt = "<UNDEF>" unless defined $opt;
  	$opt .= "/$_->{name}"
  	    if defined $_->{name} && length $_->{name} && $_->{name} ne $opt;
  	substr($opt,0,0) = "-" if $_->{disabled};
  	if (exists $self->{current} && $self->{current} == $i) {
  	    substr($opt,0,0) = "!" unless $_->{seen};
  	    substr($opt,0,0) = "*";
  	}
  	else {
  	    substr($opt,0,0) = ":" if $_->{seen};
  	}
  	push(@menu, $opt);
  	$i++;
      }
  
      return sprintf "%-30s %-10s %s", $dump, "($type)", "[" . join("|", @menu) . "]";
  }
  
  
  #---------------------------------------------------
  package HTML::Form::TextInput;
  @HTML::Form::TextInput::ISA=qw(HTML::Form::Input);
  
  #input/text
  #input/password
  #input/hidden
  #textarea
  
  sub value
  {
      my $self = shift;
      my $old = $self->{value};
      $old = "" unless defined $old;
      if (@_) {
          Carp::croak("Input '$self->{name}' is readonly")
  	    if $self->{strict} && $self->{readonly};
          my $new = shift;
          my $n = exists $self->{maxlength} ? $self->{maxlength} : undef;
          Carp::croak("Input '$self->{name}' has maxlength '$n'")
  	    if $self->{strict} && defined($n) && defined($new) && length($new) > $n;
  	$self->{value} = $new;
      }
      $old;
  }
  
  #---------------------------------------------------
  package HTML::Form::IgnoreInput;
  @HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input);
  
  #input/button
  #input/reset
  
  sub value { return }
  
  
  #---------------------------------------------------
  package HTML::Form::ListInput;
  @HTML::Form::ListInput::ISA=qw(HTML::Form::Input);
  
  #select/option   (val1, val2, ....)
  #input/radio     (undef, val1, val2,...)
  #input/checkbox  (undef, value)
  #select-multiple/option (undef, value)
  
  sub new
  {
      my $class = shift;
      my $self = $class->SUPER::new(@_);
  
      my $value = delete $self->{value};
      my $value_name = delete $self->{value_name};
      my $type = $self->{type};
  
      if ($type eq "checkbox") {
  	$value = "on" unless defined $value;
  	$self->{menu} = [
  	    { value => undef, name => "off", },
              { value => $value, name => $value_name, },
          ];
  	$self->{current} = (delete $self->{checked}) ? 1 : 0;
  	;
      }
      else {
  	$self->{option_disabled}++
  	    if $type eq "radio" && delete $self->{disabled};
  	$self->{menu} = [
              {value => $value, name => $value_name},
          ];
  	my $checked = $self->{checked} || $self->{option_selected};
  	delete $self->{checked};
  	delete $self->{option_selected};
  	if (exists $self->{multiple}) {
  	    unshift(@{$self->{menu}}, { value => undef, name => "off"});
  	    $self->{current} = $checked ? 1 : 0;
  	}
  	else {
  	    $self->{current} = 0 if $checked;
  	}
      }
      $self;
  }
  
  sub add_to_form
  {
      my($self, $form) = @_;
      my $type = $self->type;
  
      return $self->SUPER::add_to_form($form)
  	if $type eq "checkbox";
  
      if ($type eq "option" && exists $self->{multiple}) {
  	$self->{disabled} ||= delete $self->{option_disabled};
  	return $self->SUPER::add_to_form($form);
      }
  
      die "Assert" if @{$self->{menu}} != 1;
      my $m = $self->{menu}[0];
      $m->{disabled}++ if delete $self->{option_disabled};
  
      my $prev = $form->find_input($self->{name}, $self->{type}, $self->{idx});
      return $self->SUPER::add_to_form($form) unless $prev;
  
      # merge menues
      $prev->{current} = @{$prev->{menu}} if exists $self->{current};
      push(@{$prev->{menu}}, $m);
  }
  
  sub fixup
  {
      my $self = shift;
      if ($self->{type} eq "option" && !(exists $self->{current})) {
  	$self->{current} = 0;
      }
      $self->{menu}[$self->{current}]{seen}++ if exists $self->{current};
  }
  
  sub disabled
  {
      my $self = shift;
      my $type = $self->type;
  
      my $old = $self->{disabled} || _menu_all_disabled(@{$self->{menu}});
      if (@_) {
  	my $v = shift;
  	$self->{disabled} = $v;
          for (@{$self->{menu}}) {
              $_->{disabled} = $v;
          }
      }
      return $old;
  }
  
  sub _menu_all_disabled {
      for (@_) {
  	return 0 unless $_->{disabled};
      }
      return 1;
  }
  
  sub value
  {
      my $self = shift;
      my $old;
      $old = $self->{menu}[$self->{current}]{value} if exists $self->{current};
      $old = $self->{value} if exists $self->{value};
      if (@_) {
  	my $i = 0;
  	my $val = shift;
  	my $cur;
  	my $disabled;
  	for (@{$self->{menu}}) {
  	    if ((defined($val) && defined($_->{value}) && $val eq $_->{value}) ||
  		(!defined($val) && !defined($_->{value}))
  	       )
  	    {
  		$cur = $i;
  		$disabled = $_->{disabled};
  		last unless $disabled;
  	    }
  	    $i++;
  	}
  	if (!(defined $cur) || $disabled) {
  	    if (defined $val) {
  		# try to search among the alternative names as well
  		my $i = 0;
  		my $cur_ignorecase;
  		my $lc_val = lc($val);
  		for (@{$self->{menu}}) {
  		    if (defined $_->{name}) {
  			if ($val eq $_->{name}) {
  			    $disabled = $_->{disabled};
  			    $cur = $i;
  			    last unless $disabled;
  			}
  			if (!defined($cur_ignorecase) && $lc_val eq lc($_->{name})) {
  			    $cur_ignorecase = $i;
  			}
  		    }
  		    $i++;
  		}
  		unless (defined $cur) {
  		    $cur = $cur_ignorecase;
  		    if (defined $cur) {
  			$disabled = $self->{menu}[$cur]{disabled};
  		    }
  		    elsif ($self->{strict}) {
  			my $n = $self->name;
  		        Carp::croak("Illegal value '$val' for field '$n'");
  		    }
  		}
  	    }
  	    elsif ($self->{strict}) {
  		my $n = $self->name;
  	        Carp::croak("The '$n' field can't be unchecked");
  	    }
  	}
  	if ($self->{strict} && $disabled) {
  	    my $n = $self->name;
  	    Carp::croak("The value '$val' has been disabled for field '$n'");
  	}
  	if (defined $cur) {
  	    $self->{current} = $cur;
  	    $self->{menu}[$cur]{seen}++;
  	    delete $self->{value};
  	}
  	else {
  	    $self->{value} = $val;
  	    delete $self->{current};
  	}
      }
      $old;
  }
  
  =item $input->check
  
  Some input types represent toggles that can be turned on/off.  This
  includes "checkbox" and "option" inputs.  Calling this method turns
  this input on without having to know the value name.  If the input is
  already on, then nothing happens.
  
  This has the same effect as:
  
      $input->value($input->possible_values[1]);
  
  The input can be turned off with:
  
      $input->value(undef);
  
  =cut
  
  sub check
  {
      my $self = shift;
      $self->{current} = 1;
      $self->{menu}[1]{seen}++;
  }
  
  sub possible_values
  {
      my $self = shift;
      map $_->{value}, grep !$_->{disabled}, @{$self->{menu}};
  }
  
  sub other_possible_values
  {
      my $self = shift;
      map $_->{value}, grep !$_->{seen} && !$_->{disabled}, @{$self->{menu}};
  }
  
  sub value_names {
      my $self = shift;
      my @names;
      for (@{$self->{menu}}) {
  	my $n = $_->{name};
  	$n = $_->{value} unless defined $n;
  	push(@names, $n);
      }
      @names;
  }
  
  
  #---------------------------------------------------
  package HTML::Form::SubmitInput;
  @HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input);
  
  #input/image
  #input/submit
  
  =item $input->click($form, $x, $y)
  
  Some input types (currently "submit" buttons and "images") can be
  clicked to submit the form.  The click() method returns the
  corresponding C<HTTP::Request> object.
  
  =cut
  
  sub click
  {
      my($self,$form,$x,$y) = @_;
      for ($x, $y) { $_ = 1 unless defined; }
      local($self->{clicked}) = [$x,$y];
      return $form->make_request;
  }
  
  sub form_name_value
  {
      my $self = shift;
      return unless $self->{clicked};
      return $self->SUPER::form_name_value(@_);
  }
  
  
  #---------------------------------------------------
  package HTML::Form::ImageInput;
  @HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput);
  
  sub form_name_value
  {
      my $self = shift;
      my $clicked = $self->{clicked};
      return unless $clicked;
      return if $self->{disabled};
      my $name = $self->{name};
      $name = (defined($name) && length($name)) ? "$name." : "";
      return ("${name}x" => $clicked->[0],
  	    "${name}y" => $clicked->[1]
  	   );
  }
  
  #---------------------------------------------------
  package HTML::Form::FileInput;
  @HTML::Form::FileInput::ISA=qw(HTML::Form::TextInput);
  
  =back
  
  If the input is of type C<file>, then it has these additional methods:
  
  =over 4
  
  =item $input->file
  
  This is just an alias for the value() method.  It sets the filename to
  read data from.
  
  For security reasons this field will never be initialized from the parsing
  of a form.  This prevents the server from triggering stealth uploads of
  arbitrary files from the client machine.
  
  =cut
  
  sub file {
      my $self = shift;
      $self->value(@_);
  }
  
  =item $filename = $input->filename
  
  =item $input->filename( $new_filename )
  
  This get/sets the filename reported to the server during file upload.
  This attribute defaults to the value reported by the file() method.
  
  =cut
  
  sub filename {
      my $self = shift;
      my $old = $self->{filename};
      $self->{filename} = shift if @_;
      $old = $self->file unless defined $old;
      $old;
  }
  
  =item $content = $input->content
  
  =item $input->content( $new_content )
  
  This get/sets the file content provided to the server during file
  upload.  This method can be used if you do not want the content to be
  read from an actual file.
  
  =cut
  
  sub content {
      my $self = shift;
      my $old = $self->{content};
      $self->{content} = shift if @_;
      $old;
  }
  
  =item @headers = $input->headers
  
  =item input->headers($key => $value, .... )
  
  This get/set additional header fields describing the file uploaded.
  This can for instance be used to set the C<Content-Type> reported for
  the file.
  
  =cut
  
  sub headers {
      my $self = shift;
      my $old = $self->{headers} || [];
      $self->{headers} = [@_] if @_;
      @$old;
  }
  
  sub form_name_value {
      my($self, $form) = @_;
      return $self->SUPER::form_name_value($form)
  	if $form->method ne "POST" ||
  	   $form->enctype ne "multipart/form-data";
  
      my $name = $self->name;
      return unless defined $name;
      return if $self->{disabled};
  
      my $file = $self->file;
      my $filename = $self->filename;
      my @headers = $self->headers;
      my $content = $self->content;
      if (defined $content) {
  	$filename = $file unless defined $filename;
  	$file = undef;
  	unshift(@headers, "Content" => $content);
      }
      elsif (!defined($file) || length($file) == 0) {
  	return;
      }
  
      # legacy (this used to be the way to do it)
      if (ref($file) eq "ARRAY") {
  	my $f = shift @$file;
  	my $fn = shift @$file;
  	push(@headers, @$file);
  	$file = $f;
  	$filename = $fn unless defined $filename;
      }
  
      return ($name => [$file, $filename, @headers]);
  }
  
  package HTML::Form::KeygenInput;
  @HTML::Form::KeygenInput::ISA=qw(HTML::Form::Input);
  
  sub challenge {
      my $self = shift;
      return $self->{challenge};
  }
  
  sub keytype {
      my $self = shift;
      return lc($self->{keytype} || 'rsa');
  }
  
  1;
  
  __END__
  
  =back
  
  =head1 SEE ALSO
  
  L<LWP>, L<LWP::UserAgent>, L<HTML::Parser>
  
  =head1 COPYRIGHT
  
  Copyright 1998-2008 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
HTML_FORM

$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/Cookies.pm"} = <<'HTTP_COOKIES';
  package HTTP::Cookies;
  
  use strict;
  use HTTP::Date qw(str2time parse_date time2str);
  use HTTP::Headers::Util qw(_split_header_words join_header_words);
  
  use vars qw($VERSION $EPOCH_OFFSET);
  $VERSION = "6.00";
  
  # Legacy: because "use "HTTP::Cookies" used be the ONLY way
  #  to load the class HTTP::Cookies::Netscape.
  require HTTP::Cookies::Netscape;
  
  $EPOCH_OFFSET = 0;  # difference from Unix epoch
  if ($^O eq "MacOS") {
      require Time::Local;
      $EPOCH_OFFSET = Time::Local::timelocal(0,0,0,1,0,70);
  }
  
  # A HTTP::Cookies object is a hash.  The main attribute is the
  # COOKIES 3 level hash:  $self->{COOKIES}{$domain}{$path}{$key}.
  
  sub new
  {
      my $class = shift;
      my $self = bless {
  	COOKIES => {},
      }, $class;
      my %cnf = @_;
      for (keys %cnf) {
  	$self->{lc($_)} = $cnf{$_};
      }
      $self->load;
      $self;
  }
  
  
  sub add_cookie_header
  {
      my $self = shift;
      my $request = shift || return;
      my $url = $request->uri;
      my $scheme = $url->scheme;
      unless ($scheme =~ /^https?\z/) {
  	return;
      }
  
      my $domain = _host($request, $url);
      $domain = "$domain.local" unless $domain =~ /\./;
      my $secure_request = ($scheme eq "https");
      my $req_path = _url_path($url);
      my $req_port = $url->port;
      my $now = time();
      _normalize_path($req_path) if $req_path =~ /%/;
  
      my @cval;    # cookie values for the "Cookie" header
      my $set_ver;
      my $netscape_only = 0; # An exact domain match applies to any cookie
  
      while ($domain =~ /\./) {
          # Checking $domain for cookies"
  	my $cookies = $self->{COOKIES}{$domain};
  	next unless $cookies;
  	if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
  	    my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
  	    delete $self->{COOKIES}{$domain};
  	    $self->load_cookie($cookie_data->[1]);
  	    $cookies = $self->{COOKIES}{$domain};
  	    next unless $cookies;  # should not really happen
  	}
  
  	# Want to add cookies corresponding to the most specific paths
  	# first (i.e. longest path first)
  	my $path;
  	for $path (sort {length($b) <=> length($a) } keys %$cookies) {
  	    if (index($req_path, $path) != 0) {
  		next;
  	    }
  
  	    my($key,$array);
  	    while (($key,$array) = each %{$cookies->{$path}}) {
  		my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
  		if ($secure && !$secure_request) {
  		    next;
  		}
  		if ($expires && $expires < $now) {
  		    next;
  		}
  		if ($port) {
  		    my $found;
  		    if ($port =~ s/^_//) {
  			# The corresponding Set-Cookie attribute was empty
  			$found++ if $port eq $req_port;
  			$port = "";
  		    }
  		    else {
  			my $p;
  			for $p (split(/,/, $port)) {
  			    $found++, last if $p eq $req_port;
  			}
  		    }
  		    unless ($found) {
  			next;
  		    }
  		}
  		if ($version > 0 && $netscape_only) {
  		    next;
  		}
  
  		# set version number of cookie header.
  	        # XXX: What should it be if multiple matching
                  #      Set-Cookie headers have different versions themselves
  		if (!$set_ver++) {
  		    if ($version >= 1) {
  			push(@cval, "\$Version=$version");
  		    }
  		    elsif (!$self->{hide_cookie2}) {
  			$request->header(Cookie2 => '$Version="1"');
  		    }
  		}
  
  		# do we need to quote the value
  		if ($val =~ /\W/ && $version) {
  		    $val =~ s/([\\\"])/\\$1/g;
  		    $val = qq("$val");
  		}
  
  		# and finally remember this cookie
  		push(@cval, "$key=$val");
  		if ($version >= 1) {
  		    push(@cval, qq(\$Path="$path"))     if $path_spec;
  		    push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
  		    if (defined $port) {
  			my $p = '$Port';
  			$p .= qq(="$port") if length $port;
  			push(@cval, $p);
  		    }
  		}
  
  	    }
          }
  
      } continue {
  	# Try with a more general domain, alternately stripping
  	# leading name components and leading dots.  When this
  	# results in a domain with no leading dot, it is for
  	# Netscape cookie compatibility only:
  	#
  	# a.b.c.net	Any cookie
  	# .b.c.net	Any cookie
  	# b.c.net	Netscape cookie only
  	# .c.net	Any cookie
  
  	if ($domain =~ s/^\.+//) {
  	    $netscape_only = 1;
  	}
  	else {
  	    $domain =~ s/[^.]*//;
  	    $netscape_only = 0;
  	}
      }
  
      if (@cval) {
  	if (my $old = $request->header("Cookie")) {
  	    unshift(@cval, $old);
  	}
  	$request->header(Cookie => join("; ", @cval));
      }
  
      $request;
  }
  
  
  sub extract_cookies
  {
      my $self = shift;
      my $response = shift || return;
  
      my @set = _split_header_words($response->_header("Set-Cookie2"));
      my @ns_set = $response->_header("Set-Cookie");
  
      return $response unless @set || @ns_set;  # quick exit
  
      my $request = $response->request;
      my $url = $request->uri;
      my $req_host = _host($request, $url);
      $req_host = "$req_host.local" unless $req_host =~ /\./;
      my $req_port = $url->port;
      my $req_path = _url_path($url);
      _normalize_path($req_path) if $req_path =~ /%/;
  
      if (@ns_set) {
  	# The old Netscape cookie format for Set-Cookie
  	# http://curl.haxx.se/rfc/cookie_spec.html
  	# can for instance contain an unquoted "," in the expires
  	# field, so we have to use this ad-hoc parser.
  	my $now = time();
  
  	# Build a hash of cookies that was present in Set-Cookie2
  	# headers.  We need to skip them if we also find them in a
  	# Set-Cookie header.
  	my %in_set2;
  	for (@set) {
  	    $in_set2{$_->[0]}++;
  	}
  
  	my $set;
  	for $set (@ns_set) {
              $set =~ s/^\s+//;
  	    my @cur;
  	    my $param;
  	    my $expires;
  	    my $first_param = 1;
  	    for $param (split(/;\s*/, $set)) {
                  next unless length($param);
  		my($k,$v) = split(/\s*=\s*/, $param, 2);
  		if (defined $v) {
  		    $v =~ s/\s+$//;
  		    #print "$k => $v\n";
  		}
  		else {
  		    $k =~ s/\s+$//;
  		    #print "$k => undef";
  		}
  		if (!$first_param && lc($k) eq "expires") {
  		    my $etime = str2time($v);
  		    if (defined $etime) {
  			push(@cur, "Max-Age" => $etime - $now);
  			$expires++;
  		    }
  		    else {
  			# parse_date can deal with years outside the range of time_t,
  			my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
  			if ($year) {
  			    my $thisyear = (gmtime)[5] + 1900;
  			    if ($year < $thisyear) {
  				push(@cur, "Max-Age" => -1);  # any negative value will do
  				$expires++;
  			    }
  			    elsif ($year >= $thisyear + 10) {
  				# the date is at least 10 years into the future, just replace
  				# it with something approximate
  				push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
  				$expires++;
  			    }
  			}
  		    }
  		}
                  elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
                      # ignore
                  }
  		else {
  		    push(@cur, $k => $v);
  		}
  		$first_param = 0;
  	    }
              next unless @cur;
  	    next if $in_set2{$cur[0]};
  
  #	    push(@cur, "Port" => $req_port);
  	    push(@cur, "Discard" => undef) unless $expires;
  	    push(@cur, "Version" => 0);
  	    push(@cur, "ns-cookie" => 1);
  	    push(@set, \@cur);
  	}
      }
  
    SET_COOKIE:
      for my $set (@set) {
  	next unless @$set >= 2;
  
  	my $key = shift @$set;
  	my $val = shift @$set;
  
  	my %hash;
  	while (@$set) {
  	    my $k = shift @$set;
  	    my $v = shift @$set;
  	    my $lc = lc($k);
  	    # don't loose case distinction for unknown fields
  	    $k = $lc if $lc =~ /^(?:discard|domain|max-age|
                                      path|port|secure|version)$/x;
  	    if ($k eq "discard" || $k eq "secure") {
  		$v = 1 unless defined $v;
  	    }
  	    next if exists $hash{$k};  # only first value is significant
  	    $hash{$k} = $v;
  	};
  
  	my %orig_hash = %hash;
  	my $version   = delete $hash{version};
  	$version = 1 unless defined($version);
  	my $discard   = delete $hash{discard};
  	my $secure    = delete $hash{secure};
  	my $maxage    = delete $hash{'max-age'};
  	my $ns_cookie = delete $hash{'ns-cookie'};
  
  	# Check domain
  	my $domain  = delete $hash{domain};
  	$domain = lc($domain) if defined $domain;
  	if (defined($domain)
  	    && $domain ne $req_host && $domain ne ".$req_host") {
  	    if ($domain !~ /\./ && $domain ne "local") {
  		next SET_COOKIE;
  	    }
  	    $domain = ".$domain" unless $domain =~ /^\./;
  	    if ($domain =~ /\.\d+$/) {
  		next SET_COOKIE;
  	    }
  	    my $len = length($domain);
  	    unless (substr($req_host, -$len) eq $domain) {
  		next SET_COOKIE;
  	    }
  	    my $hostpre = substr($req_host, 0, length($req_host) - $len);
  	    if ($hostpre =~ /\./ && !$ns_cookie) {
  		next SET_COOKIE;
  	    }
  	}
  	else {
  	    $domain = $req_host;
  	}
  
  	my $path = delete $hash{path};
  	my $path_spec;
  	if (defined $path && $path ne '') {
  	    $path_spec++;
  	    _normalize_path($path) if $path =~ /%/;
  	    if (!$ns_cookie &&
                  substr($req_path, 0, length($path)) ne $path) {
  		next SET_COOKIE;
  	    }
  	}
  	else {
  	    $path = $req_path;
  	    $path =~ s,/[^/]*$,,;
  	    $path = "/" unless length($path);
  	}
  
  	my $port;
  	if (exists $hash{port}) {
  	    $port = delete $hash{port};
  	    if (defined $port) {
  		$port =~ s/\s+//g;
  		my $found;
  		for my $p (split(/,/, $port)) {
  		    unless ($p =~ /^\d+$/) {
  			next SET_COOKIE;
  		    }
  		    $found++ if $p eq $req_port;
  		}
  		unless ($found) {
  		    next SET_COOKIE;
  		}
  	    }
  	    else {
  		$port = "_$req_port";
  	    }
  	}
  	$self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
  	    if $self->set_cookie_ok(\%orig_hash);
      }
  
      $response;
  }
  
  sub set_cookie_ok
  {
      1;
  }
  
  
  sub set_cookie
  {
      my $self = shift;
      my($version,
         $key, $val, $path, $domain, $port,
         $path_spec, $secure, $maxage, $discard, $rest) = @_;
  
      # path and key can not be empty (key can't start with '$')
      return $self if !defined($path) || $path !~ m,^/, ||
  	            !defined($key)  || $key  =~ m,^\$,;
  
      # ensure legal port
      if (defined $port) {
  	return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
      }
  
      my $expires;
      if (defined $maxage) {
  	if ($maxage <= 0) {
  	    delete $self->{COOKIES}{$domain}{$path}{$key};
  	    return $self;
  	}
  	$expires = time() + $maxage;
      }
      $version = 0 unless defined $version;
  
      my @array = ($version, $val,$port,
  		 $path_spec,
  		 $secure, $expires, $discard);
      push(@array, {%$rest}) if defined($rest) && %$rest;
      # trim off undefined values at end
      pop(@array) while !defined $array[-1];
  
      $self->{COOKIES}{$domain}{$path}{$key} = \@array;
      $self;
  }
  
  
  sub save
  {
      my $self = shift;
      my $file = shift || $self->{'file'} || return;
      local(*FILE);
      open(FILE, ">$file") or die "Can't open $file: $!";
      print FILE "#LWP-Cookies-1.0\n";
      print FILE $self->as_string(!$self->{ignore_discard});
      close(FILE);
      1;
  }
  
  
  sub load
  {
      my $self = shift;
      my $file = shift || $self->{'file'} || return;
      local(*FILE, $_);
      local $/ = "\n";  # make sure we got standard record separator
      open(FILE, $file) or return;
      my $magic = <FILE>;
      unless ($magic =~ /^\#LWP-Cookies-(\d+\.\d+)/) {
  	warn "$file does not seem to contain cookies";
  	return;
      }
      while (<FILE>) {
  	next unless s/^Set-Cookie3:\s*//;
  	chomp;
  	my $cookie;
  	for $cookie (_split_header_words($_)) {
  	    my($key,$val) = splice(@$cookie, 0, 2);
  	    my %hash;
  	    while (@$cookie) {
  		my $k = shift @$cookie;
  		my $v = shift @$cookie;
  		$hash{$k} = $v;
  	    }
  	    my $version   = delete $hash{version};
  	    my $path      = delete $hash{path};
  	    my $domain    = delete $hash{domain};
  	    my $port      = delete $hash{port};
  	    my $expires   = str2time(delete $hash{expires});
  
  	    my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
  	    my $secure    = exists $hash{secure};    delete $hash{secure};
  	    my $discard   = exists $hash{discard};   delete $hash{discard};
  
  	    my @array =	($version,$val,$port,
  			 $path_spec,$secure,$expires,$discard);
  	    push(@array, \%hash) if %hash;
  	    $self->{COOKIES}{$domain}{$path}{$key} = \@array;
  	}
      }
      close(FILE);
      1;
  }
  
  
  sub revert
  {
      my $self = shift;
      $self->clear->load;
      $self;
  }
  
  
  sub clear
  {
      my $self = shift;
      if (@_ == 0) {
  	$self->{COOKIES} = {};
      }
      elsif (@_ == 1) {
  	delete $self->{COOKIES}{$_[0]};
      }
      elsif (@_ == 2) {
  	delete $self->{COOKIES}{$_[0]}{$_[1]};
      }
      elsif (@_ == 3) {
  	delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
      }
      else {
  	require Carp;
          Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
      }
      $self;
  }
  
  
  sub clear_temporary_cookies
  {
      my($self) = @_;
  
      $self->scan(sub {
          if($_[9] or        # "Discard" flag set
             not $_[8]) {    # No expire field?
              $_[8] = -1;            # Set the expire/max_age field
              $self->set_cookie(@_); # Clear the cookie
          }
        });
  }
  
  
  sub DESTROY
  {
      my $self = shift;
      local($., $@, $!, $^E, $?);
      $self->save if $self->{'autosave'};
  }
  
  
  sub scan
  {
      my($self, $cb) = @_;
      my($domain,$path,$key);
      for $domain (sort keys %{$self->{COOKIES}}) {
  	for $path (sort keys %{$self->{COOKIES}{$domain}}) {
  	    for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
  		my($version,$val,$port,$path_spec,
  		   $secure,$expires,$discard,$rest) =
  		       @{$self->{COOKIES}{$domain}{$path}{$key}};
  		$rest = {} unless defined($rest);
  		&$cb($version,$key,$val,$path,$domain,$port,
  		     $path_spec,$secure,$expires,$discard,$rest);
  	    }
  	}
      }
  }
  
  
  sub as_string
  {
      my($self, $skip_discard) = @_;
      my @res;
      $self->scan(sub {
  	my($version,$key,$val,$path,$domain,$port,
  	   $path_spec,$secure,$expires,$discard,$rest) = @_;
  	return if $discard && $skip_discard;
  	my @h = ($key, $val);
  	push(@h, "path", $path);
  	push(@h, "domain" => $domain);
  	push(@h, "port" => $port) if defined $port;
  	push(@h, "path_spec" => undef) if $path_spec;
  	push(@h, "secure" => undef) if $secure;
  	push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
  	push(@h, "discard" => undef) if $discard;
  	my $k;
  	for $k (sort keys %$rest) {
  	    push(@h, $k, $rest->{$k});
  	}
  	push(@h, "version" => $version);
  	push(@res, "Set-Cookie3: " . join_header_words(\@h));
      });
      join("\n", @res, "");
  }
  
  sub _host
  {
      my($request, $url) = @_;
      if (my $h = $request->header("Host")) {
  	$h =~ s/:\d+$//;  # might have a port as well
  	return lc($h);
      }
      return lc($url->host);
  }
  
  sub _url_path
  {
      my $url = shift;
      my $path;
      if($url->can('epath')) {
         $path = $url->epath;    # URI::URL method
      }
      else {
         $path = $url->path;           # URI::_generic method
      }
      $path = "/" unless length $path;
      $path;
  }
  
  sub _normalize_path  # so that plain string compare can be used
  {
      my $x;
      $_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
  	         $x = uc($1);
                   $x eq "2F" || $x eq "25" ? "%$x" :
                                              pack("C", hex($x));
                /eg;
      $_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Cookies - HTTP cookie jars
  
  =head1 SYNOPSIS
  
    use HTTP::Cookies;
    $cookie_jar = HTTP::Cookies->new(
      file => "$ENV{'HOME'}/lwp_cookies.dat",
      autosave => 1,
    );
  
    use LWP;
    my $browser = LWP::UserAgent->new;
    $browser->cookie_jar($cookie_jar);
  
  Or for an empty and temporary cookie jar:
  
    use LWP;
    my $browser = LWP::UserAgent->new;
    $browser->cookie_jar( {} );
  
  =head1 DESCRIPTION
  
  This class is for objects that represent a "cookie jar" -- that is, a
  database of all the HTTP cookies that a given LWP::UserAgent object
  knows about.
  
  Cookies are a general mechanism which server side connections can use
  to both store and retrieve information on the client side of the
  connection.  For more information about cookies refer to
  <URL:http://curl.haxx.se/rfc/cookie_spec.html> and
  <URL:http://www.cookiecentral.com/>.  This module also implements the
  new style cookies described in I<RFC 2965>.
  The two variants of cookies are supposed to be able to coexist happily.
  
  Instances of the class I<HTTP::Cookies> are able to store a collection
  of Set-Cookie2: and Set-Cookie: headers and are able to use this
  information to initialize Cookie-headers in I<HTTP::Request> objects.
  The state of a I<HTTP::Cookies> object can be saved in and restored from
  files.
  
  =head1 METHODS
  
  The following methods are provided:
  
  =over 4
  
  =item $cookie_jar = HTTP::Cookies->new
  
  The constructor takes hash style parameters.  The following
  parameters are recognized:
  
    file:            name of the file to restore cookies from and save cookies to
    autosave:        save during destruction (bool)
    ignore_discard:  save even cookies that are requested to be discarded (bool)
    hide_cookie2:    do not add Cookie2 header to requests
  
  Future parameters might include (not yet implemented):
  
    max_cookies               300
    max_cookies_per_domain    20
    max_cookie_size           4096
  
    no_cookies   list of domain names that we never return cookies to
  
  =item $cookie_jar->add_cookie_header( $request )
  
  The add_cookie_header() method will set the appropriate Cookie:-header
  for the I<HTTP::Request> object given as argument.  The $request must
  have a valid url attribute before this method is called.
  
  =item $cookie_jar->extract_cookies( $response )
  
  The extract_cookies() method will look for Set-Cookie: and
  Set-Cookie2: headers in the I<HTTP::Response> object passed as
  argument.  Any of these headers that are found are used to update
  the state of the $cookie_jar.
  
  =item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
  
  The set_cookie() method updates the state of the $cookie_jar.  The
  $key, $val, $domain, $port and $path arguments are strings.  The
  $path_spec, $secure, $discard arguments are boolean values. The $maxage
  value is a number indicating number of seconds that this cookie will
  live.  A value <= 0 will delete this cookie.  %rest defines
  various other attributes like "Comment" and "CommentURL".
  
  =item $cookie_jar->save
  
  =item $cookie_jar->save( $file )
  
  This method file saves the state of the $cookie_jar to a file.
  The state can then be restored later using the load() method.  If a
  filename is not specified we will use the name specified during
  construction.  If the attribute I<ignore_discard> is set, then we
  will even save cookies that are marked to be discarded.
  
  The default is to save a sequence of "Set-Cookie3" lines.
  "Set-Cookie3" is a proprietary LWP format, not known to be compatible
  with any browser.  The I<HTTP::Cookies::Netscape> sub-class can
  be used to save in a format compatible with Netscape.
  
  =item $cookie_jar->load
  
  =item $cookie_jar->load( $file )
  
  This method reads the cookies from the file and adds them to the
  $cookie_jar.  The file must be in the format written by the save()
  method.
  
  =item $cookie_jar->revert
  
  This method empties the $cookie_jar and re-loads the $cookie_jar
  from the last save file.
  
  =item $cookie_jar->clear
  
  =item $cookie_jar->clear( $domain )
  
  =item $cookie_jar->clear( $domain, $path )
  
  =item $cookie_jar->clear( $domain, $path, $key )
  
  Invoking this method without arguments will empty the whole
  $cookie_jar.  If given a single argument only cookies belonging to
  that domain will be removed.  If given two arguments, cookies
  belonging to the specified path within that domain are removed.  If
  given three arguments, then the cookie with the specified key, path
  and domain is removed.
  
  =item $cookie_jar->clear_temporary_cookies
  
  Discard all temporary cookies. Scans for all cookies in the jar
  with either no expire field or a true C<discard> flag. To be
  called when the user agent shuts down according to RFC 2965.
  
  =item $cookie_jar->scan( \&callback )
  
  The argument is a subroutine that will be invoked for each cookie
  stored in the $cookie_jar.  The subroutine will be invoked with
  the following arguments:
  
    0  version
    1  key
    2  val
    3  path
    4  domain
    5  port
    6  path_spec
    7  secure
    8  expires
    9  discard
   10  hash
  
  =item $cookie_jar->as_string
  
  =item $cookie_jar->as_string( $skip_discardables )
  
  The as_string() method will return the state of the $cookie_jar
  represented as a sequence of "Set-Cookie3" header lines separated by
  "\n".  If $skip_discardables is TRUE, it will not return lines for
  cookies with the I<Discard> attribute.
  
  =back
  
  =head1 SEE ALSO
  
  L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
  
  =head1 COPYRIGHT
  
  Copyright 1997-2002 Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_COOKIES

$fatpacked{"HTTP/Cookies/Microsoft.pm"} = <<'HTTP_COOKIES_MICROSOFT';
  package HTTP::Cookies::Microsoft;
  
  use strict;
  
  use vars qw(@ISA $VERSION);
  
  $VERSION = "6.00";
  
  require HTTP::Cookies;
  @ISA=qw(HTTP::Cookies);
  
  sub load_cookies_from_file
  {
  	my ($file) = @_;
  	my @cookies;
  	my ($key, $value, $domain_path, $flags, $lo_expire, $hi_expire);
  	my ($lo_create, $hi_create, $sep);
  
  	open(COOKIES, $file) || return;
  
  	while ($key = <COOKIES>)
  	{
  		chomp($key);
  		chomp($value     = <COOKIES>);
  		chomp($domain_path= <COOKIES>);
  		chomp($flags     = <COOKIES>);		# 0x0001 bit is for secure
  		chomp($lo_expire = <COOKIES>);
  		chomp($hi_expire = <COOKIES>);
  		chomp($lo_create = <COOKIES>);
  		chomp($hi_create = <COOKIES>);
  		chomp($sep       = <COOKIES>);
  
  		if (!defined($key) || !defined($value) || !defined($domain_path) ||
  			!defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
  			!defined($hi_create) || !defined($lo_create) || !defined($sep) ||
  			($sep ne '*'))
  		{
  			last;
  		}
  
  		if ($domain_path =~ /^([^\/]+)(\/.*)$/)
  		{
  			my $domain = $1;
  			my $path = $2;
  
  			push(@cookies, {KEY => $key, VALUE => $value, DOMAIN => $domain,
  					PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
  					LOXP => $lo_expire, HICREATE => $hi_create,
  					LOCREATE => $lo_create});
  		}
  	}
  
  	return \@cookies;
  }
  
  sub get_user_name
  {
  	use Win32;
  	use locale;
  	my $user = lc(Win32::LoginName());
  
  	return $user;
  }
  
  # MSIE stores create and expire times as Win32 FILETIME,
  # which is 64 bits of 100 nanosecond intervals since Jan 01 1601
  #
  # But Cookies code expects time in 32-bit value expressed
  # in seconds since Jan 01 1970
  #
  sub epoch_time_offset_from_win32_filetime
  {
  	my ($high, $low) = @_;
  
  	#--------------------------------------------------------
  	# USEFUL CONSTANT
  	#--------------------------------------------------------
  	# 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
  	#
  	# 100 nanosecond intervals == 0.1 microsecond intervals
  	
  	my $filetime_low32_1970 = 0xd53e8000;
  	my $filetime_high32_1970 = 0x019db1de;
  
  	#------------------------------------
  	# ALGORITHM
  	#------------------------------------
  	# To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
  	#
  	# 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
  	# 2. Divide by 10 to get to microseconds (1/millionth second)
  	# 3. Divide by 1000000 (10 ^ 6) to get to seconds
  	#
  	# We can combine Step 2 & 3 into one divide.
  	#
  	# After much trial and error, I came up with the following code which
  	# avoids using Math::BigInt or floating pt, but still gives correct answers
  
  	# If the filetime is before the epoch, return 0
  	if (($high < $filetime_high32_1970) ||
  	    (($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
      	{
  		return 0;
  	}
  
  	# Can't multiply by 0x100000000, (1 << 32),
  	# without Perl issuing an integer overflow warning
  	#
  	# So use two multiplies by 0x10000 instead of one multiply by 0x100000000
  	#
  	# The result is the same.
  	#
  	my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
  	my $time = (($high * 0x10000) * 0x10000) + $low;
  
  	$time -= $date1970;
  	$time /= 10000000;
  
  	return $time;
  }
  
  sub load_cookie
  {
  	my($self, $file) = @_;
          my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
  	my $cookie_data;
  
          if (-f $file)
          {
  		# open the cookie file and get the data
  		$cookie_data = load_cookies_from_file($file);
  
  		foreach my $cookie (@{$cookie_data})
  		{
  			my $secure = ($cookie->{FLAGS} & 1) != 0;
  			my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
  
  			$self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE}, 
  					  $cookie->{PATH}, $cookie->{DOMAIN}, undef,
  					  0, $secure, $expires-$now, 0);
  		}
  	}
  }
  
  sub load
  {
  	my($self, $cookie_index) = @_;
  	my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
  	my $cookie_dir = '';
  	my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
  	my $user_name = get_user_name();
  	my $data;
  
  	$cookie_index ||= $self->{'file'} || return;
  	if ($cookie_index =~ /[\\\/][^\\\/]+$/)
  	{
  		$cookie_dir = $` . "\\";
  	}
  
  	local(*INDEX, $_);
  
  	open(INDEX, $cookie_index) || return;
  	binmode(INDEX);
  	if (256 != read(INDEX, $data, 256))
  	{
  		warn "$cookie_index file is not large enough";
  		close(INDEX);
  		return;
  	}
  
  	# Cookies' index.dat file starts with 32 bytes of signature
  	# followed by an offset to the first record, stored as a little-endian DWORD
  	my ($sig, $size) = unpack('a32 V', $data);
  	
  	if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || # check that sig is valid (only tested in IE6.0)
  		(0x4000 != $size))
  	{
  		warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
  		close(INDEX);
  		return;
  	}
  
  	if (0 == seek(INDEX, $size, 0)) # move the file ptr to start of the first record
  	{
  		close(INDEX);
  		return;
  	}
  
  	# Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
  	# so read in two 0x80 byte sectors and adjust if not a Cookie.
  	while (256 == read(INDEX, $data, 256))
  	{
  		# each record starts with a 4-byte signature
  		# and a count (little-endian DWORD) of 0x80 byte sectors for the record
  		($sig, $size) = unpack('a4 V', $data);
  
  		# Cookies are found in 'URL ' records
  		if ('URL ' ne $sig)
  		{
  			# skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
  			if (($sig eq 'HASH') || ($sig eq 'LEAK'))
  			{
  				# '-2' takes into account the two 0x80 byte sectors we've just read in
  				if (($size > 0) && ($size != 2))
  				{
  				    if (0 == seek(INDEX, ($size-2)*0x80, 1))
  				    {
  					    # Seek failed. Something's wrong. Gonna stop.
  					    last;
  				    }
  				}
  			}
  			next;
  		}
  
  		#$REMOVE Need to check if URL records in Cookies' index.dat will
  		#        ever use more than two 0x80 byte sectors
  		if ($size > 2)
  		{
  			my $more_data = ($size-2)*0x80;
  
  			if ($more_data != read(INDEX, $data, $more_data, 256))
  			{
  				last;
  			}
  		}
  
                  (my $user_name2 = $user_name) =~ s/ /_/g;
  		if ($data =~ /Cookie\:\Q$user_name\E\@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)\@[\x21-\xFF]+\.txt)/)
  		{
  			my $cookie_file = $cookie_dir . $2; # form full pathname
  
  			if (!$delay_load)
  			{
  				$self->load_cookie($cookie_file);
  			}
  			else
  			{
  				my $domain = $1;
  
  				# grab only the domain name, drop everything from the first dir sep on
  				if ($domain =~ m{[\\/]})
  				{
  					$domain = $`;
  				}
  
  				# set the delayload cookie for this domain with 
  				# the cookie_file as cookie for later-loading info
  				$self->set_cookie(undef, 'cookie', $cookie_file,
  						      '//+delayload', $domain, undef,
  						      0, 0, $now+86400, 0);
  			}
  		}
  	}
  
  	close(INDEX);
  
  	1;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Cookies::Microsoft - access to Microsoft cookies files
  
  =head1 SYNOPSIS
  
   use LWP;
   use HTTP::Cookies::Microsoft;
   use Win32::TieRegistry(Delimiter => "/");
   my $cookies_dir = $Registry->
        {"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
  
   $cookie_jar = HTTP::Cookies::Microsoft->new(
                     file     => "$cookies_dir\\index.dat",
                     'delayload' => 1,
                 );
   my $browser = LWP::UserAgent->new;
   $browser->cookie_jar( $cookie_jar );
  
  =head1 DESCRIPTION
  
  This is a subclass of C<HTTP::Cookies> which
  loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
  cookie files.
  
  See the documentation for L<HTTP::Cookies>.
  
  =head1 METHODS
  
  The following methods are provided:
  
  =over 4
  
  =item $cookie_jar = HTTP::Cookies::Microsoft->new;
  
  The constructor takes hash style parameters. In addition
  to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
  recognizes the following:
  
    delayload:       delay loading of cookie data until a request
                     is actually made. This results in faster
                     runtime unless you use most of the cookies
                     since only the domain's cookie data
                     is loaded on demand.
  
  =back
  
  =head1 CAVEATS
  
  Please note that the code DOESN'T support saving to the MSIE
  cookie file format.
  
  =head1 AUTHOR
  
  Johnny Lee <typo_pl@hotmail.com>
  
  =head1 COPYRIGHT
  
  Copyright 2002 Johnny Lee
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
HTTP_COOKIES_MICROSOFT

$fatpacked{"HTTP/Cookies/Netscape.pm"} = <<'HTTP_COOKIES_NETSCAPE';
  package HTTP::Cookies::Netscape;
  
  use strict;
  use vars qw(@ISA $VERSION);
  
  $VERSION = "6.00";
  
  require HTTP::Cookies;
  @ISA=qw(HTTP::Cookies);
  
  sub load
  {
      my($self, $file) = @_;
      $file ||= $self->{'file'} || return;
      local(*FILE, $_);
      local $/ = "\n";  # make sure we got standard record separator
      my @cookies;
      open(FILE, $file) || return;
      my $magic = <FILE>;
      unless ($magic =~ /^\#(?: Netscape)? HTTP Cookie File/) {
  	warn "$file does not look like a netscape cookies file" if $^W;
  	close(FILE);
  	return;
      }
      my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
      while (<FILE>) {
  	next if /^\s*\#/;
  	next if /^\s*$/;
  	tr/\n\r//d;
  	my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $_);
  	$secure = ($secure eq "TRUE");
  	$self->set_cookie(undef,$key,$val,$path,$domain,undef,
  			  0,$secure,$expires-$now, 0);
      }
      close(FILE);
      1;
  }
  
  sub save
  {
      my($self, $file) = @_;
      $file ||= $self->{'file'} || return;
      local(*FILE, $_);
      open(FILE, ">$file") || return;
  
      # Use old, now broken link to the old cookie spec just in case something
      # else (not us!) requires the comment block exactly this way.
      print FILE <<EOT;
  # Netscape HTTP Cookie File
  # http://www.netscape.com/newsref/std/cookie_spec.html
  # This is a generated file!  Do not edit.
  
  EOT
  
      my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
      $self->scan(sub {
  	my($version,$key,$val,$path,$domain,$port,
  	   $path_spec,$secure,$expires,$discard,$rest) = @_;
  	return if $discard && !$self->{ignore_discard};
  	$expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
  	return if $now > $expires;
  	$secure = $secure ? "TRUE" : "FALSE";
  	my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
  	print FILE join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
      });
      close(FILE);
      1;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  HTTP::Cookies::Netscape - access to Netscape cookies files
  
  =head1 SYNOPSIS
  
   use LWP;
   use HTTP::Cookies::Netscape;
   $cookie_jar = HTTP::Cookies::Netscape->new(
     file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
   );
   my $browser = LWP::UserAgent->new;
   $browser->cookie_jar( $cookie_jar );
  
  =head1 DESCRIPTION
  
  This is a subclass of C<HTTP::Cookies> that reads (and optionally
  writes) Netscape/Mozilla cookie files.
  
  See the documentation for L<HTTP::Cookies>.
  
  =head1 CAVEATS
  
  Please note that the Netscape/Mozilla cookie file format can't store
  all the information available in the Set-Cookie2 headers, so you will
  probably lose some information if you save in this format.
  
  At time of writing, this module seems to work fine with Mozilla      
  Phoenix/Firebird.
  
  =head1 SEE ALSO
  
  L<HTTP::Cookies::Microsoft>
  
  =head1 COPYRIGHT
  
  Copyright 2002-2003 Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
HTTP_COOKIES_NETSCAPE

$fatpacked{"HTTP/Daemon.pm"} = <<'HTTP_DAEMON';
  package HTTP::Daemon;
  
  use strict;
  use vars qw($VERSION @ISA $PROTO $DEBUG);
  
  $VERSION = "6.00";
  
  use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
  @ISA=qw(IO::Socket::INET);
  
  $PROTO = "HTTP/1.1";
  
  
  sub new
  {
      my($class, %args) = @_;
      $args{Listen} ||= 5;
      $args{Proto}  ||= 'tcp';
      return $class->SUPER::new(%args);
  }
  
  
  sub accept
  {
      my $self = shift;
      my $pkg = shift || "HTTP::Daemon::ClientConn";
      my ($sock, $peer) = $self->SUPER::accept($pkg);
      if ($sock) {
          ${*$sock}{'httpd_daemon'} = $self;
          return wantarray ? ($sock, $peer) : $sock;
      }
      else {
          return;
      }
  }
  
  
  sub url
  {
      my $self = shift;
      my $url = $self->_default_scheme . "://";
      my $addr = $self->sockaddr;
      if (!$addr || $addr eq INADDR_ANY) {
   	require Sys::Hostname;
   	$url .= lc Sys::Hostname::hostname();
      }
      else {
  	$url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
      }
      my $port = $self->sockport;
      $url .= ":$port" if $port != $self->_default_port;
      $url .= "/";
      $url;
  }
  
  
  sub _default_port {
      80;
  }
  
  
  sub _default_scheme {
      "http";
  }
  
  
  sub product_tokens
  {
      "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  }
  
  
  
  package HTTP::Daemon::ClientConn;
  
  use vars qw(@ISA $DEBUG);
  use IO::Socket ();
  @ISA=qw(IO::Socket::INET);
  *DEBUG = \$HTTP::Daemon::DEBUG;
  
  use HTTP::Request  ();
  use HTTP::Response ();
  use HTTP::Status;
  use HTTP::Date qw(time2str);
  use LWP::MediaTypes qw(guess_media_type);
  use Carp ();
  
  my $CRLF = "\015\012";   # "\r\n" is not portable
  my $HTTP_1_0 = _http_version("HTTP/1.0");
  my $HTTP_1_1 = _http_version("HTTP/1.1");
  
  
  sub get_request
  {
      my($self, $only_headers) = @_;
      if (${*$self}{'httpd_nomore'}) {
          $self->reason("No more requests from this connection");
  	return;
      }
  
      $self->reason("");
      my $buf = ${*$self}{'httpd_rbuf'};
      $buf = "" unless defined $buf;
  
      my $timeout = $ {*$self}{'io_socket_timeout'};
      my $fdset = "";
      vec($fdset, $self->fileno, 1) = 1;
      local($_);
  
    READ_HEADER:
      while (1) {
  	# loop until we have the whole header in $buf
  	$buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
  	if ($buf =~ /\012/) {  # potential, has at least one line
  	    if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
  		if ($buf =~ /\015?\012\015?\012/) {
  		    last READ_HEADER;  # we have it
  		}
  		elsif (length($buf) > 16*1024) {
  		    $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
  		    $self->reason("Very long header");
  		    return;
  		}
  	    }
  	    else {
  		last READ_HEADER;  # HTTP/0.9 client
  	    }
  	}
  	elsif (length($buf) > 16*1024) {
  	    $self->send_error(414); # REQUEST_URI_TOO_LARGE
  	    $self->reason("Very long first line");
  	    return;
  	}
  	print STDERR "Need more data for complete header\n" if $DEBUG;
  	return unless $self->_need_more($buf, $timeout, $fdset);
      }
      if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
  	${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
  	$self->send_error(400);  # BAD_REQUEST
  	$self->reason("Bad request line: $buf");
  	return;
      }
      my $method = $1;
      my $uri = $2;
      my $proto = $3 || "HTTP/0.9";
      $uri = "http://$uri" if $method eq "CONNECT";
      $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
      my $r = HTTP::Request->new($method, $uri);
      $r->protocol($proto);
      ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
      ${*$self}{'httpd_head'} = ($method eq "HEAD");
  
      if ($proto >= $HTTP_1_0) {
  	# we expect to find some headers
  	my($key, $val);
        HEADER:
  	while ($buf =~ s/^([^\012]*)\012//) {
  	    $_ = $1;
  	    s/\015$//;
  	    if (/^([^:\s]+)\s*:\s*(.*)/) {
  		$r->push_header($key, $val) if $key;
  		($key, $val) = ($1, $2);
  	    }
  	    elsif (/^\s+(.*)/) {
  		$val .= " $1";
  	    }
  	    else {
  		last HEADER;
  	    }
  	}
  	$r->push_header($key, $val) if $key;
      }
  
      my $conn = $r->header('Connection');
      if ($proto >= $HTTP_1_1) {
  	${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
      }
      else {
  	${*$self}{'httpd_nomore'}++ unless $conn &&
                                             lc($conn) =~ /\bkeep-alive\b/;
      }
  
      if ($only_headers) {
  	${*$self}{'httpd_rbuf'} = $buf;
          return $r;
      }
  
      # Find out how much content to read
      my $te  = $r->header('Transfer-Encoding');
      my $ct  = $r->header('Content-Type');
      my $len = $r->header('Content-Length');
  
      # Act on the Expect header, if it's there
      for my $e ( $r->header('Expect') ) {
          if( lc($e) eq '100-continue' ) {
              $self->send_status_line(100);
              $self->send_crlf;
          }
          else {
              $self->send_error(417);
              $self->reason("Unsupported Expect header value");
              return;
          }
      }
  
      if ($te && lc($te) eq 'chunked') {
  	# Handle chunked transfer encoding
  	my $body = "";
        CHUNK:
  	while (1) {
  	    print STDERR "Chunked\n" if $DEBUG;
  	    if ($buf =~ s/^([^\012]*)\012//) {
  		my $chunk_head = $1;
  		unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
  		    $self->send_error(400);
  		    $self->reason("Bad chunk header $chunk_head");
  		    return;
  		}
  		my $size = hex($1);
  		last CHUNK if $size == 0;
  
  		my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
  		# must read until we have a complete chunk
  		while ($missing > 0) {
  		    print STDERR "Need $missing more bytes\n" if $DEBUG;
  		    my $n = $self->_need_more($buf, $timeout, $fdset);
  		    return unless $n;
  		    $missing -= $n;
  		}
  		$body .= substr($buf, 0, $size);
  		substr($buf, 0, $size+2) = '';
  
  	    }
  	    else {
  		# need more data in order to have a complete chunk header
  		return unless $self->_need_more($buf, $timeout, $fdset);
  	    }
  	}
  	$r->content($body);
  
  	# pretend it was a normal entity body
  	$r->remove_header('Transfer-Encoding');
  	$r->header('Content-Length', length($body));
  
  	my($key, $val);
        FOOTER:
  	while (1) {
  	    if ($buf !~ /\012/) {
  		# need at least one line to look at
  		return unless $self->_need_more($buf, $timeout, $fdset);
  	    }
  	    else {
  		$buf =~ s/^([^\012]*)\012//;
  		$_ = $1;
  		s/\015$//;
  		if (/^([\w\-]+)\s*:\s*(.*)/) {
  		    $r->push_header($key, $val) if $key;
  		    ($key, $val) = ($1, $2);
  		}
  		elsif (/^\s+(.*)/) {
  		    $val .= " $1";
  		}
  		elsif (!length) {
  		    last FOOTER;
  		}
  		else {
  		    $self->reason("Bad footer syntax");
  		    return;
  		}
  	    }
  	}
  	$r->push_header($key, $val) if $key;
  
      }
      elsif ($te) {
  	$self->send_error(501); 	# Unknown transfer encoding
  	$self->reason("Unknown transfer encoding '$te'");
  	return;
  
      }
      elsif ($len) {
  	# Plain body specified by "Content-Length"
  	my $missing = $len - length($buf);
  	while ($missing > 0) {
  	    print "Need $missing more bytes of content\n" if $DEBUG;
  	    my $n = $self->_need_more($buf, $timeout, $fdset);
  	    return unless $n;
  	    $missing -= $n;
  	}
  	if (length($buf) > $len) {
  	    $r->content(substr($buf,0,$len));
  	    substr($buf, 0, $len) = '';
  	}
  	else {
  	    $r->content($buf);
  	    $buf='';
  	}
      }
      elsif ($ct && $ct =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) {
  	# Handle multipart content type
  	my $boundary = "$CRLF--$2--";
  	my $index;
  	while (1) {
  	    $index = index($buf, $boundary);
  	    last if $index >= 0;
  	    # end marker not yet found
  	    return unless $self->_need_more($buf, $timeout, $fdset);
  	}
  	$index += length($boundary);
  	$r->content(substr($buf, 0, $index));
  	substr($buf, 0, $index) = '';
  
      }
      ${*$self}{'httpd_rbuf'} = $buf;
  
      $r;
  }
  
  
  sub _need_more
  {
      my $self = shift;
      #my($buf,$timeout,$fdset) = @_;
      if ($_[1]) {
  	my($timeout, $fdset) = @_[1,2];
  	print STDERR "select(,,,$timeout)\n" if $DEBUG;
  	my $n = select($fdset,undef,undef,$timeout);
  	unless ($n) {
  	    $self->reason(defined($n) ? "Timeout" : "select: $!");
  	    return;
  	}
      }
      print STDERR "sysread()\n" if $DEBUG;
      my $n = sysread($self, $_[0], 2048, length($_[0]));
      $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
      $n;
  }
  
  
  sub read_buffer
  {
      my $self = shift;
      my $old = ${*$self}{'httpd_rbuf'};
      if (@_) {
  	${*$self}{'httpd_rbuf'} = shift;
      }
      $old;
  }
  
  
  sub reason
  {
      my $self = shift;
      my $old = ${*$self}{'httpd_reason'};
      if (@_) {
          ${*$self}{'httpd_reason'} = shift;
      }
      $old;
  }
  
  
  sub proto_ge
  {
      my $self = shift;
      ${*$self}{'httpd_client_proto'} >= _http_version(shift);
  }
  
  
  sub _http_version
  {
      local($_) = shift;
      return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
      $1 * 1000 + $2;
  }
  
  
  sub antique_client
  {
      my $self = shift;
      ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
  }
  
  
  sub force_last_request
  {
      my $self = shift;
      ${*$self}{'httpd_nomore'}++;
  }
  
  sub head_request
  {
      my $self = shift;
      ${*$self}{'httpd_head'};
  }
  
  
  sub send_status_line
  {
      my($self, $status, $message, $proto) = @_;
      return if $self->antique_client;
      $status  ||= RC_OK;
      $message ||= status_message($status) || "";
      $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
      print $self "$proto $status $message$CRLF";
  }
  
  
  sub send_crlf
  {
      my $self = shift;
      print $self $CRLF;
  }
  
  
  sub send_basic_header
  {
      my $self = shift;
      return if $self->antique_client;
      $self->send_status_line(@_);
      print $self "Date: ", time2str(time), $CRLF;
      my $product = $self->daemon->product_tokens;
      print $self "Server: $product$CRLF" if $product;
  }
  
  
  sub send_header
  {
      my $self = shift;
      while (@_) {
  	my($k, $v) = splice(@_, 0, 2);
  	$v = "" unless defined($v);
  	print $self "$k: $v$CRLF";
      }
  }
  
  
  sub send_response
  {
      my $self = shift;
      my $res = shift;
      if (!ref $res) {
  	$res ||= RC_OK;
  	$res = HTTP::Response->new($res, @_);
      }
      my $content = $res->content;
      my $chunked;
      unless ($self->antique_client) {
  	my $code = $res->code;
  	$self->send_basic_header($code, $res->message, $res->protocol);
  	if ($code =~ /^(1\d\d|[23]04)$/) {
  	    # make sure content is empty
  	    $res->remove_header("Content-Length");
  	    $content = "";
  	}
  	elsif ($res->request && $res->request->method eq "HEAD") {
  	    # probably OK
  	}
  	elsif (ref($content) eq "CODE") {
  	    if ($self->proto_ge("HTTP/1.1")) {
  		$res->push_header("Transfer-Encoding" => "chunked");
  		$chunked++;
  	    }
  	    else {
  		$self->force_last_request;
  	    }
  	}
  	elsif (length($content)) {
  	    $res->header("Content-Length" => length($content));
  	}
  	else {
  	    $self->force_last_request;
              $res->header('connection','close'); 
  	}
  	print $self $res->headers_as_string($CRLF);
  	print $self $CRLF;  # separates headers and content
      }
      if ($self->head_request) {
  	# no content
      }
      elsif (ref($content) eq "CODE") {
  	while (1) {
  	    my $chunk = &$content();
  	    last unless defined($chunk) && length($chunk);
  	    if ($chunked) {
  		printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
  	    }
  	    else {
  		print $self $chunk;
  	    }
  	}
  	print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
      }
      elsif (length $content) {
  	print $self $content;
      }
  }
  
  
  sub send_redirect
  {
      my($self, $loc, $status, $content) = @_;
      $status ||= RC_MOVED_PERMANENTLY;
      Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
      $self->send_basic_header($status);
      my $base = $self->daemon->url;
      $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
      $loc = $loc->abs($base);
      print $self "Location: $loc$CRLF";
      if ($content) {
  	my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  	print $self "Content-Type: $ct$CRLF";
      }
      print $self $CRLF;
      print $self $content if $content && !$self->head_request;
      $self->force_last_request;  # no use keeping the connection open
  }
  
  
  sub send_error
  {
      my($self, $status, $error) = @_;
      $status ||= RC_BAD_REQUEST;
      Carp::croak("Status '$status' is not an error") unless is_error($status);
      my $mess = status_message($status);
      $error  ||= "";
      $mess = <<EOT;
  <title>$status $mess</title>
  <h1>$status $mess</h1>
  $error
  EOT
      unless ($self->antique_client) {
          $self->send_basic_header($status);
          print $self "Content-Type: text/html$CRLF";
  	print $self "Content-Length: " . length($mess) . $CRLF;
          print $self $CRLF;
      }
      print $self $mess unless $self->head_request;
      $status;
  }
  
  
  sub send_file_response
  {
      my($self, $file) = @_;
      if (-d $file) {
  	$self->send_dir($file);
      }
      elsif (-f _) {
  	# plain file
  	local(*F);
  	sysopen(F, $file, 0) or 
  	  return $self->send_error(RC_FORBIDDEN);
  	binmode(F);
  	my($ct,$ce) = guess_media_type($file);
  	my($size,$mtime) = (stat _)[7,9];
  	unless ($self->antique_client) {
  	    $self->send_basic_header;
  	    print $self "Content-Type: $ct$CRLF";
  	    print $self "Content-Encoding: $ce$CRLF" if $ce;
  	    print $self "Content-Length: $size$CRLF" if $size;
  	    print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
  	    print $self $CRLF;
  	}
  	$self->send_file(\*F) unless $self->head_request;
  	return RC_OK;
      }
      else {
  	$self->send_error(RC_NOT_FOUND);
      }
  }
  
  
  sub send_dir
  {
      my($self, $dir) = @_;
      $self->send_error(RC_NOT_FOUND) unless -d $dir;
      $self->send_error(RC_NOT_IMPLEMENTED);
  }
  
  
  sub send_file
  {
      my($self, $file) = @_;
      my $opened = 0;
      local(*FILE);
      if (!ref($file)) {
  	open(FILE, $file) || return undef;
  	binmode(FILE);
  	$file = \*FILE;
  	$opened++;
      }
      my $cnt = 0;
      my $buf = "";
      my $n;
      while ($n = sysread($file, $buf, 8*1024)) {
  	last if !$n;
  	$cnt += $n;
  	print $self $buf;
      }
      close($file) if $opened;
      $cnt;
  }
  
  
  sub daemon
  {
      my $self = shift;
      ${*$self}{'httpd_daemon'};
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Daemon - a simple http server class
  
  =head1 SYNOPSIS
  
    use HTTP::Daemon;
    use HTTP::Status;
  
    my $d = HTTP::Daemon->new || die;
    print "Please contact me at: <URL:", $d->url, ">\n";
    while (my $c = $d->accept) {
        while (my $r = $c->get_request) {
  	  if ($r->method eq 'GET' and $r->uri->path eq "/xyzzy") {
                # remember, this is *not* recommended practice :-)
  	      $c->send_file_response("/etc/passwd");
  	  }
  	  else {
  	      $c->send_error(RC_FORBIDDEN)
  	  }
        }
        $c->close;
        undef($c);
    }
  
  =head1 DESCRIPTION
  
  Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
  listen on a socket for incoming requests. The C<HTTP::Daemon> is a
  subclass of C<IO::Socket::INET>, so you can perform socket operations
  directly on it too.
  
  The accept() method will return when a connection from a client is
  available.  The returned value will be an C<HTTP::Daemon::ClientConn>
  object which is another C<IO::Socket::INET> subclass.  Calling the
  get_request() method on this object will read data from the client and
  return an C<HTTP::Request> object.  The ClientConn object also provide
  methods to send back various responses.
  
  This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  user of the C<HTTP::Daemon> is responsible for forking if that is
  desirable.  Also note that the user is responsible for generating
  responses that conform to the HTTP/1.1 protocol.
  
  The following methods of C<HTTP::Daemon> are new (or enhanced) relative
  to the C<IO::Socket::INET> base class:
  
  =over 4
  
  =item $d = HTTP::Daemon->new
  
  =item $d = HTTP::Daemon->new( %opts )
  
  The constructor method takes the same arguments as the
  C<IO::Socket::INET> constructor, but unlike its base class it can also
  be called without any arguments.  The daemon will then set up a listen
  queue of 5 connections and allocate some random port number.
  
  A server that wants to bind to some specific address on the standard
  HTTP port will be constructed like this:
  
    $d = HTTP::Daemon->new(
             LocalAddr => 'www.thisplace.com',
             LocalPort => 80,
         );
  
  See L<IO::Socket::INET> for a description of other arguments that can
  be used configure the daemon during construction.
  
  =item $c = $d->accept
  
  =item $c = $d->accept( $pkg )
  
  =item ($c, $peer_addr) = $d->accept
  
  This method works the same the one provided by the base class, but it
  returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
  package name is provided as argument, then the returned object will be
  blessed into the given class.  It is probably a good idea to make that
  class a subclass of C<HTTP::Daemon::ClientConn>.
  
  The accept method will return C<undef> if timeouts have been enabled
  and no connection is made within the given time.  The timeout() method
  is described in L<IO::Socket>.
  
  In list context both the client object and the peer address will be
  returned; see the description of the accept method L<IO::Socket> for
  details.
  
  =item $d->url
  
  Returns a URL string that can be used to access the server root.
  
  =item $d->product_tokens
  
  Returns the name that this server will use to identify itself.  This
  is the string that is sent with the C<Server> response header.  The
  main reason to have this method is that subclasses can override it if
  they want to use another product name.
  
  The default is the string "libwww-perl-daemon/#.##" where "#.##" is
  replaced with the version number of this module.
  
  =back
  
  The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
  subclass. Instances of this class are returned by the accept() method
  of C<HTTP::Daemon>.  The following methods are provided:
  
  =over 4
  
  =item $c->get_request
  
  =item $c->get_request( $headers_only )
  
  This method reads data from the client and turns it into an
  C<HTTP::Request> object which is returned.  It returns C<undef>
  if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
  object ($c) should be discarded, and you should not try call this
  method again on it.  The $c->reason method might give you some
  information about why $c->get_request failed.
  
  The get_request() method will normally not return until the whole
  request has been received from the client.  This might not be what you
  want if the request is an upload of a large file (and with chunked
  transfer encoding HTTP can even support infinite request messages -
  uploading live audio for instance).  If you pass a TRUE value as the
  $headers_only argument, then get_request() will return immediately
  after parsing the request headers and you are responsible for reading
  the rest of the request content.  If you are going to call
  $c->get_request again on the same connection you better read the
  correct number of bytes.
  
  =item $c->read_buffer
  
  =item $c->read_buffer( $new_value )
  
  Bytes read by $c->get_request, but not used are placed in the I<read
  buffer>.  The next time $c->get_request is called it will consume the
  bytes in this buffer before reading more data from the network
  connection itself.  The read buffer is invalid after $c->get_request
  has failed.
  
  If you handle the reading of the request content yourself you need to
  empty this buffer before you read more and you need to place
  unconsumed bytes here.  You also need this buffer if you implement
  services like I<101 Switching Protocols>.
  
  This method always returns the old buffer content and can optionally
  replace the buffer content if you pass it an argument.
  
  =item $c->reason
  
  When $c->get_request returns C<undef> you can obtain a short string
  describing why it happened by calling $c->reason.
  
  =item $c->proto_ge( $proto )
  
  Return TRUE if the client announced a protocol with version number
  greater or equal to the given argument.  The $proto argument can be a
  string like "HTTP/1.1" or just "1.1".
  
  =item $c->antique_client
  
  Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
  code and no headers should be returned to such a client.  This should
  be the same as !$c->proto_ge("HTTP/1.0").
  
  =item $c->head_request
  
  Return TRUE if the last request was a C<HEAD> request.  No content
  body must be generated for these requests.
  
  =item $c->force_last_request
  
  Make sure that $c->get_request will not try to read more requests off
  this connection.  If you generate a response that is not self
  delimiting, then you should signal this fact by calling this method.
  
  This attribute is turned on automatically if the client announces
  protocol HTTP/1.0 or worse and does not include a "Connection:
  Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
  or better clients send the "Connection: close" request header.
  
  =item $c->send_status_line
  
  =item $c->send_status_line( $code )
  
  =item $c->send_status_line( $code, $mess )
  
  =item $c->send_status_line( $code, $mess, $proto )
  
  Send the status line back to the client.  If $code is omitted 200 is
  assumed.  If $mess is omitted, then a message corresponding to $code
  is inserted.  If $proto is missing the content of the
  $HTTP::Daemon::PROTO variable is used.
  
  =item $c->send_crlf
  
  Send the CRLF sequence to the client.
  
  =item $c->send_basic_header
  
  =item $c->send_basic_header( $code )
  
  =item $c->send_basic_header( $code, $mess )
  
  =item $c->send_basic_header( $code, $mess, $proto )
  
  Send the status line and the "Date:" and "Server:" headers back to
  the client.  This header is assumed to be continued and does not end
  with an empty CRLF line.
  
  See the description of send_status_line() for the description of the
  accepted arguments.
  
  =item $c->send_header( $field, $value )
  
  =item $c->send_header( $field1, $value1, $field2, $value2, ... )
  
  Send one or more header lines.
  
  =item $c->send_response( $res )
  
  Write a C<HTTP::Response> object to the
  client as a response.  We try hard to make sure that the response is
  self delimiting so that the connection can stay persistent for further
  request/response exchanges.
  
  The content attribute of the C<HTTP::Response> object can be a normal
  string or a subroutine reference.  If it is a subroutine, then
  whatever this callback routine returns is written back to the
  client as the response content.  The routine will be called until it
  return an undefined or empty value.  If the client is HTTP/1.1 aware
  then we will use chunked transfer encoding for the response.
  
  =item $c->send_redirect( $loc )
  
  =item $c->send_redirect( $loc, $code )
  
  =item $c->send_redirect( $loc, $code, $entity_body )
  
  Send a redirect response back to the client.  The location ($loc) can
  be an absolute or relative URL. The $code must be one the redirect
  status codes, and defaults to "301 Moved Permanently"
  
  =item $c->send_error
  
  =item $c->send_error( $code )
  
  =item $c->send_error( $code, $error_message )
  
  Send an error response back to the client.  If the $code is missing a
  "Bad Request" error is reported.  The $error_message is a string that
  is incorporated in the body of the HTML entity body.
  
  =item $c->send_file_response( $filename )
  
  Send back a response with the specified $filename as content.  If the
  file is a directory we try to generate an HTML index of it.
  
  =item $c->send_file( $filename )
  
  =item $c->send_file( $fd )
  
  Copy the file to the client.  The file can be a string (which
  will be interpreted as a filename) or a reference to an C<IO::Handle>
  or glob.
  
  =item $c->daemon
  
  Return a reference to the corresponding C<HTTP::Daemon> object.
  
  =back
  
  =head1 SEE ALSO
  
  RFC 2616
  
  L<IO::Socket::INET>, L<IO::Socket>
  
  =head1 COPYRIGHT
  
  Copyright 1996-2003, Gisle Aas
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
HTTP_DAEMON

$fatpacked{"HTTP/Date.pm"} = <<'HTTP_DATE';
  package HTTP::Date;
  
  $VERSION = "6.00";
  
  require 5.004;
  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+\))?	       # ASCII representation of timezone in parens.
  	    \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
  returned will B<not> have the number 1900 subtracted from it and the
  $month numbers start with 1.
  
  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.
  
  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.00";
  
  # 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};
      }
      $c;
  }
  
  
  sub _header
  {
      my($self, $field, $val, $op) = @_;
  
      unless ($field =~ /^:/) {
  	$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
  	my $old = $field;
  	$field = lc $field;
  	unless(defined $standard_case{$field}) {
  	    # generate a %standard_case entry for this field
  	    $old =~ s/\b(\w)/\u$1/g;
  	    $standard_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
      } keys %$self ];
  }
  
  
  sub header_field_names {
      my $self = shift;
      return map $standard_case{$_} || $_, @{ $self->_sorted_field_names },
  	if wantarray;
      return keys %$self;
  }
  
  
  sub scan
  {
      my($self, $sub) = @_;
      my $key;
      for $key (@{ $self->_sorted_field_names }) {
  	next if substr($key, 0, 1) eq '_';
  	my $vals = $self->{$key};
  	if (ref($vals) eq 'ARRAY') {
  	    my $val;
  	    for $val (@$vals) {
  		$sub->($standard_case{$key} || $key, $val);
  	    }
  	}
  	else {
  	    $sub->($standard_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} || $key;
  		$field =~ s/^://;
  		if ( index($val, "\n") >= 0 ) {
  		    $val = _process_newline($val, $endl);
  		}
  		push @result, $field . ': ' . $val;
  	    }
  	}
  	else {
  	    my $field = $standard_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; # intial 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.00";
  
  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 necessary 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.02";
  
  require HTTP::Headers;
  require Carp;
  
  my $CRLF = "\015\012";   # "\r\n" is not portable
  $HTTP::URI_CLASS ||= $ENV{PERL_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-32-LE" if /^\xFF\xFE\x00\x00/;
  	return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
  	return "UTF-16-LE" if /^\xFF\xFE/;
  	return "UTF-16-BE" 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-32-BE" if /^\x00\x00\x00</;
  	    return "UTF-32-LE" if /^<\x00\x00\x00/;
  	    return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
  	    return "UTF-16-LE" 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
  	my $charset;
  	require HTML::Parser;
  	my $p = HTML::Parser->new(
  	    start_h => [sub {
  		my($tag, $attr, $self) = @_;
  		$charset = $attr->{charset};
  		unless ($charset) {
  		    # look at $attr->{content} ...
  		    if (my $c = $attr->{content}) {
  			require HTTP::Headers::Util;
  			my @v = HTTP::Headers::Util::split_header_words($c);
  			return unless @v;
  			my($ct, undef, %ct_param) = @{$v[0]};
  			$charset = $ct_param{charset};
  		    }
  		    return unless $charset;
  		}
  		if ($charset =~ /^utf-?16/i) {
  		    # converted document, assume UTF-8
  		    $charset = "UTF-8";
  		}
  		$self->eof;
  	    }, "tagname, attr, self"],
  	    report_tags => [qw(meta)],
  	    utf8_mode => 1,
  	);
  	$p->parse($$cref);
  	return $charset if $charset;
      }
      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") {
  		    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 = "(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 { 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--\r?\n.*//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 an @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 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/Negotiate.pm"} = <<'HTTP_NEGOTIATE';
  package HTTP::Negotiate;
  
  $VERSION = "6.00";
  sub Version { $VERSION; }
  
  require 5.002;
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(choose);
  
  require HTTP::Headers;
  
  $DEBUG = 0;
  
  sub choose ($;$)
  {
      my($variants, $request) = @_;
      my(%accept);
  
      unless (defined $request) {
  	# Create a request object from the CGI environment variables
  	$request = HTTP::Headers->new;
  	$request->header('Accept', $ENV{HTTP_ACCEPT})
  	  if $ENV{HTTP_ACCEPT};
  	$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
  	  if $ENV{HTTP_ACCEPT_CHARSET};
  	$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
  	  if $ENV{HTTP_ACCEPT_ENCODING};
  	$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
  	  if $ENV{HTTP_ACCEPT_LANGUAGE};
      }
  
      # Get all Accept values from the request.  Build a hash initialized
      # like this:
      #
      #   %accept = ( type =>     { 'audio/*'     => { q => 0.2, mbx => 20000 },
      #                             'audio/basic' => { q => 1 },
      #                           },
      #               language => { 'no'          => { q => 1 },
      #                           }
      #             );
  
      $request->scan(sub {
  	my($key, $val) = @_;
  
  	my $type;
  	if ($key =~ s/^Accept-//) {
  	    $type = lc($key);
  	}
  	elsif ($key eq "Accept") {
  	    $type = "type";
  	}
  	else {
  	    return;
  	}
  
  	$val =~ s/\s+//g;
  	my $default_q = 1;
  	for my $name (split(/,/, $val)) {
  	    my(%param, $param);
  	    if ($name =~ s/;(.*)//) {
  		for $param (split(/;/, $1)) {
  		    my ($pk, $pv) = split(/=/, $param, 2);
  		    $param{lc $pk} = $pv;
  		}
  	    }
  	    $name = lc $name;
  	    if (defined $param{'q'}) {
  		$param{'q'} = 1 if $param{'q'} > 1;
  		$param{'q'} = 0 if $param{'q'} < 0;
  	    }
  	    else {
  		$param{'q'} = $default_q;
  
  		# This makes sure that the first ones are slightly better off
  		# and therefore more likely to be chosen.
  		$default_q -= 0.0001;
  	    }
  	    $accept{$type}{$name} = \%param;
  	}
      });
  
      # Check if any of the variants specify a language.  We do this
      # because it influences how we treat those without (they default to
      # 0.5 instead of 1).
      my $any_lang = 0;
      for $var (@$variants) {
  	if ($var->[5]) {
  	    $any_lang = 1;
  	    last;
  	}
      }
  
      if ($DEBUG) {
  	print "Negotiation parameters in the request\n";
  	for $type (keys %accept) {
  	    print " $type:\n";
  	    for $name (keys %{$accept{$type}}) {
  		print "    $name\n";
  		for $pv (keys %{$accept{$type}{$name}}) {
  		    print "      $pv = $accept{$type}{$name}{$pv}\n";
  		}
  	    }
  	}
      }
  
      my @Q = ();  # This is where we collect the results of the
  		 # quality calculations
  
      # Calculate quality for all the variants that are available.
      for (@$variants) {
  	my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
  	$qs = 1 unless defined $qs;
          $ct = '' unless defined $ct;
  	$bs = 0 unless defined $bs;
  	$lang = lc($lang) if $lang; # lg tags are always case-insensitive
  	if ($DEBUG) {
  	    print "\nEvaluating $id (ct='$ct')\n";
  	    printf "  qs   = %.3f\n", $qs;
  	    print  "  enc  = $enc\n"  if $enc && !ref($enc);
  	    print  "  enc  = @$enc\n" if $enc && ref($enc);
  	    print  "  cs   = $cs\n"   if $cs;
  	    print  "  lang = $lang\n" if $lang;
  	    print  "  bs   = $bs\n"   if $bs;
  	}
  
  	# Calculate encoding quality
  	my $qe = 1;
  	# If the variant has no assigned Content-Encoding, or if no
  	# Accept-Encoding field is present, then the value assigned
  	# is "qe=1".  If *all* of the variant's content encodings
  	# are listed in the Accept-Encoding field, then the value
  	# assigned is "qw=1".  If *any* of the variant's content
  	# encodings are not listed in the provided Accept-Encoding
  	# field, then the value assigned is "qe=0"
  	if (exists $accept{'encoding'} && $enc) {
  	    my @enc = ref($enc) ? @$enc : ($enc);
  	    for (@enc) {
  		print "Is encoding $_ accepted? " if $DEBUG;
  		unless(exists $accept{'encoding'}{$_}) {
  		    print "no\n" if $DEBUG;
  		    $qe = 0;
  		    last;
  		}
  		else {
  		    print "yes\n" if $DEBUG;
  		}
  	    }
  	}
  
  	# Calculate charset quality
  	my $qc  = 1;
  	# If the variant's media-type has no charset parameter,
  	# or the variant's charset is US-ASCII, or if no Accept-Charset
  	# field is present, then the value assigned is "qc=1".  If the
  	# variant's charset is listed in the Accept-Charset field,
  	# then the value assigned is "qc=1.  Otherwise, if the variant's
  	# charset is not listed in the provided Accept-Encoding field,
  	# then the value assigned is "qc=0".
  	if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
  	    $qc = 0 unless $accept{'charset'}{$cs};
  	}
  
  	# Calculate language quality
  	my $ql  = 1;
  	if ($lang && exists $accept{'language'}) {
  	    my @lang = ref($lang) ? @$lang : ($lang);
  	    # If any of the variant's content languages are listed
  	    # in the Accept-Language field, the the value assigned is
  	    # the largest of the "q" parameter values for those language
  	    # tags.
  	    my $q = undef;
  	    for (@lang) {
  		next unless exists $accept{'language'}{$_};
  		my $this_q = $accept{'language'}{$_}{'q'};
  		$q = $this_q unless defined $q;
  		$q = $this_q if $this_q > $q;
  	    }
  	    if(defined $q) {
  	        $DEBUG and print " -- Exact language match at q=$q\n";
  	    }
  	    else {
  		# If there was no exact match and at least one of
  		# the Accept-Language field values is a complete
  		# subtag prefix of the content language tag(s), then
  		# the "q" parameter value of the largest matching
  		# prefix is used.
  		$DEBUG and print " -- No exact language match\n";
  		my $selected = undef;
  		for $al (keys %{ $accept{'language'} }) {
  		    if (index($al, "$lang-") == 0) {
  		        # $lang starting with $al isn't enough, or else
  		        #  Accept-Language: hu (Hungarian) would seem
  		        #  to accept a document in hup (Hupa)
  		        $DEBUG and print " -- $al ISA $lang\n";
  			$selected = $al unless defined $selected;
  			$selected = $al if length($al) > length($selected);
  		    }
  		    else {
  		        $DEBUG and print " -- $lang  isn't a $al\n";
  		    }
  		}
  		$q = $accept{'language'}{$selected}{'q'} if $selected;
  
  		# If none of the variant's content language tags or
  		# tag prefixes are listed in the provided
  		# Accept-Language field, then the value assigned
  		# is "ql=0.001"
  		$q = 0.001 unless defined $q;
  	    }
  	    $ql = $q;
  	}
  	else {
  	    $ql = 0.5 if $any_lang && exists $accept{'language'};
  	}
  
  	my $q   = 1;
  	my $mbx = undef;
  	# If no Accept field is given, then the value assigned is "q=1".
  	# If at least one listed media range matches the variant's media
  	# type, then the "q" parameter value assigned to the most specific
  	# of those matched is used (e.g. "text/html;version=3.0" is more
  	# specific than "text/html", which is more specific than "text/*",
  	# which in turn is more specific than "*/*"). If not media range
  	# in the provided Accept field matches the variant's media type,
  	# then the value assigned is "q=0".
  	if (exists $accept{'type'} && $ct) {
  	    # First we clean up our content-type
  	    $ct =~ s/\s+//g;
  	    my $params = "";
  	    $params = $1 if $ct =~ s/;(.*)//;
  	    my($type, $subtype) = split("/", $ct, 2);
  	    my %param = ();
  	    for $param (split(/;/, $params)) {
  		my($pk,$pv) = split(/=/, $param, 2);
  		$param{$pk} = $pv;
  	    }
  
  	    my $sel_q = undef;
  	    my $sel_mbx = undef;
  	    my $sel_specificness = 0;
  
  	    ACCEPT_TYPE:
  	    for $at (keys %{ $accept{'type'} }) {
  		print "Consider $at...\n" if $DEBUG;
  		my($at_type, $at_subtype) = split("/", $at, 2);
  		# Is it a match on the type
  		next if $at_type    ne '*' && $at_type    ne $type;
  		next if $at_subtype ne '*' && $at_subtype ne $subtype;
  		my $specificness = 0;
  		$specificness++ if $at_type ne '*';
  		$specificness++ if $at_subtype ne '*';
  		# Let's see if content-type parameters also match
  		while (($pk, $pv) = each %param) {
  		    print "Check if $pk = $pv is true\n" if $DEBUG;
  		    next unless exists $accept{'type'}{$at}{$pk};
  		    next ACCEPT_TYPE
  		      unless $accept{'type'}{$at}{$pk} eq $pv;
  		    print "yes it is!!\n" if $DEBUG;
  		    $specificness++;
  		}
  		print "Hurray, type match with specificness = $specificness\n"
  		  if $DEBUG;
  
  		if (!defined($sel_q) || $sel_specificness < $specificness) {
  		    $sel_q   = $accept{'type'}{$at}{'q'};
  		    $sel_mbx = $accept{'type'}{$at}{'mbx'};
  		    $sel_specificness = $specificness;
  		}
  	    }
  	    $q   = $sel_q || 0;
  	    $mbx = $sel_mbx;
  	}
  
  	my $Q;
  	if (!defined($mbx) || $mbx >= $bs) {
  	    $Q = $qs * $qe * $qc * $ql * $q;
  	}
  	else {
  	    $Q = 0;
  	    print "Variant's size is too large ==> Q=0\n" if $DEBUG;
  	}
  
  	if ($DEBUG) {
  	    $mbx = "undef" unless defined $mbx;
  	    printf "Q=%.4f", $Q;
  	    print "  (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
  	}
  
  	push(@Q, [$id, $Q, $bs]);
      }
  
  
      @Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
  
      return @Q if wantarray;
      return undef unless @Q;
      return undef if $Q[0][1] == 0;
      $Q[0][0];
  }
  
  1;
  
  __END__
  
  
  =head1 NAME
  
  HTTP::Negotiate - choose a variant to serve
  
  =head1 SYNOPSIS
  
   use HTTP::Negotiate qw(choose);
  
   #  ID       QS     Content-Type   Encoding Char-Set        Lang   Size
   $variants =
    [['var1',  1.000, 'text/html',   undef,   'iso-8859-1',   'en',   3000],
     ['var2',  0.950, 'text/plain',  'gzip',  'us-ascii',     'no',    400],
     ['var3',  0.3,   'image/gif',   undef,   undef,          undef, 43555],
    ];
  
   @preferred = choose($variants, $request_headers);
   $the_one   = choose($variants);
  
  =head1 DESCRIPTION
  
  This module provides a complete implementation of the HTTP content
  negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
  chapter 12.  Content negotiation allows for the selection of a
  preferred content representation based upon attributes of the
  negotiable variants and the value of the various Accept* header fields
  in the request.
  
  The variants are ordered by preference by calling the function
  choose().
  
  The first parameter is reference to an array of the variants to
  choose among.
  Each element in this array is an array with the values [$id, $qs,
  $content_type, $content_encoding, $charset, $content_language,
  $content_length] whose meanings are described
  below. The $content_encoding and $content_language can be either a
  single scalar value or an array reference if there are several values.
  
  The second optional parameter is either a HTTP::Headers or a HTTP::Request
  object which is searched for "Accept*" headers.  If this
  parameter is missing, then the accept specification is initialized
  from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
  HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
  
  In an array context, choose() returns a list of [variant
  identifier, calculated quality, size] tuples.  The values are sorted by
  quality, highest quality first.  If the calculated quality is the same
  for two variants, then they are sorted by size (smallest first). I<E.g.>:
  
    (['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
  
  Note that also zero quality variants are included in the return list
  even if these should never be served to the client.
  
  In a scalar context, it returns the identifier of the variant with the
  highest score or C<undef> if none have non-zero quality.
  
  If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
  noise is generated on STDOUT during evaluation of choose().
  
  =head1 VARIANTS
  
  A variant is described by a list of the following values.  If the
  attribute does not make sense or is unknown for a variant, then use
  C<undef> instead.
  
  =over 3
  
  =item identifier
  
  This is a string that you use as the name for the variant.  This
  identifier for the preferred variants returned by choose().
  
  =item qs
  
  This is a number between 0.000 and 1.000 that describes the "source
  quality".  This is what F<draft-ietf-http-v11-spec-00.ps> says about this
  value:
  
  Source quality is measured by the content provider as representing the
  amount of degradation from the original source.  For example, a
  picture in JPEG form would have a lower qs when translated to the XBM
  format, and much lower qs when translated to an ASCII-art
  representation.  Note, however, that this is a function of the source
  - an original piece of ASCII-art may degrade in quality if it is
  captured in JPEG form.  The qs values should be assigned to each
  variant by the content provider; if no qs value has been assigned, the
  default is generally "qs=1".
  
  =item content-type
  
  This is the media type of the variant.  The media type does not
  include a charset attribute, but might contain other parameters.
  Examples are:
  
    text/html
    text/html;version=2.0
    text/plain
    image/gif
    image/jpg
  
  =item content-encoding
  
  This is one or more content encodings that has been applied to the
  variant.  The content encoding is generally used as a modifier to the
  content media type.  The most common content encodings are:
  
    gzip
    compress
  
  =item content-charset
  
  This is the character set used when the variant contains text.
  The charset value should generally be C<undef> or one of these:
  
    us-ascii
    iso-8859-1 ... iso-8859-9
    iso-2022-jp
    iso-2022-jp-2
    iso-2022-kr
    unicode-1-1
    unicode-1-1-utf-7
    unicode-1-1-utf-8
  
  =item content-language
  
  This describes one or more languages that are used in the variant.
  Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
  language is in this context a natural language spoken, written, or
  otherwise conveyed by human beings for communication of information to
  other human beings.  Computer languages are explicitly excluded.
  
  The language tags are defined by RFC 3066.  Examples
  are:
  
    no               Norwegian
    en               International English
    en-US            US English
    en-cockney
  
  =item content-length
  
  This is the number of bytes used to represent the content.
  
  =back
  
  =head1 ACCEPT HEADERS
  
  The following Accept* headers can be used for describing content
  preferences in a request (This description is an edited extract from
  F<draft-ietf-http-v11-spec-00.ps>):
  
  =over 3
  
  =item Accept
  
  This header can be used to indicate a list of media ranges which are
  acceptable as a response to the request.  The "*" character is used to
  group media types into ranges, with "*/*" indicating all media types
  and "type/*" indicating all subtypes of that type.
  
  The parameter q is used to indicate the quality factor, which
  represents the user's preference for that range of media types.  The
  parameter mbx gives the maximum acceptable size of the response
  content. The default values are: q=1 and mbx=infinity. If no Accept
  header is present, then the client accepts all media types with q=1.
  
  For example:
  
    Accept: audio/*;q=0.2;mbx=200000, audio/basic
  
  would mean: "I prefer audio/basic (of any size), but send me any audio
  type if it is the best available after an 80% mark-down in quality and
  its size is less than 200000 bytes"
  
  
  =item Accept-Charset
  
  Used to indicate what character sets are acceptable for the response.
  The "us-ascii" character set is assumed to be acceptable for all user
  agents.  If no Accept-Charset field is given, the default is that any
  charset is acceptable.  Example:
  
    Accept-Charset: iso-8859-1, unicode-1-1
  
  
  =item Accept-Encoding
  
  Restricts the Content-Encoding values which are acceptable in the
  response.  If no Accept-Encoding field is present, the server may
  assume that the client will accept any content encoding.  An empty
  Accept-Encoding means that no content encoding is acceptable.  Example:
  
    Accept-Encoding: compress, gzip
  
  
  =item Accept-Language
  
  This field is similar to Accept, but restricts the set of natural
  languages that are preferred in a response.  Each language may be
  given an associated quality value which represents an estimate of the
  user's comprehension of that language.  For example:
  
    Accept-Language: no, en-gb;q=0.8, de;q=0.55
  
  would mean: "I prefer Norwegian, but will accept British English (with
  80% comprehension) or German (with 55% comprehension).
  
  =back
  
  
  =head1 COPYRIGHT
  
  Copyright 1996,2001 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =head1 AUTHOR
  
  Gisle Aas <gisle@aas.no>
  
  =cut
HTTP_NEGOTIATE

$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.00";
  
  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;
  	}
      }
  
      $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 a 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 a 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 a 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.01";
  
  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
  {
      require HTTP::Status;
      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 meaning 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 a 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.00";
  
  # 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)
      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',
      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
      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
  );
  
  my $mnemonicCode = '';
  my ($code, $message);
  while (($code, $message) = each %StatusCode) {
      # create mnemonic subroutines
      $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 a 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_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_UNPROCESSABLE_ENTITY            (422)
     HTTP_LOCKED                          (423)
     HTTP_FAILED_DEPENDENCY               (424)
     HTTP_NO_CODE                         (425)
     HTTP_UPGRADE_REQUIRED                (426)
     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)
  
  =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
  return TRUE for both client error or a server error status codes.
  
  =item is_client_error( $code )
  
  Return TRUE if C<$code> is an 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 an 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 explict imports and
  the C<:constants> tag instead of relying on this.
HTTP_STATUS

$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
  # vim: ts=4 sts=4 sw=4 et:
  package HTTP::Tiny;
  use strict;
  use warnings;
  # ABSTRACT: A small, simple, correct HTTP/1.1 client
  our $VERSION = '0.016'; # VERSION
  
  use Carp ();
  
  
  my @attributes;
  BEGIN {
      @attributes = qw(agent default_headers max_redirect max_size proxy timeout);
      no strict 'refs';
      for my $accessor ( @attributes ) {
          *{$accessor} = sub {
              @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
          };
      }
  }
  
  sub new {
      my($class, %args) = @_;
      (my $agent = $class) =~ s{::}{-}g;
      my $self = {
          agent        => $agent . "/" . ($class->VERSION || 0),
          max_redirect => 5,
          timeout      => 60,
      };
      for my $key ( @attributes ) {
          $self->{$key} = $args{$key} if exists $args{$key}
      }
  
      # Never override proxy argument as this breaks backwards compat.
      if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
          if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
              $self->{proxy} = $http_proxy;
          }
          else {
              Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
          }
      }
  
      return bless $self, $class;
  }
  
  
  for my $sub_name ( qw/get head put post delete/ ) {
      my $req_method = uc $sub_name;
      no strict 'refs';
      eval <<"HERE";
      sub $sub_name {
          my (\$self, \$url, \$args) = \@_;
          \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
          or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
          return \$self->request('$req_method', \$url, \$args || {});
      }
  HERE
  }
  
  
  sub post_form {
      my ($self, $url, $data, $args) = @_;
      (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
          or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  
      my $headers = {};
      while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
          $headers->{lc $key} = $value;
      }
      delete $args->{headers};
  
      return $self->request('POST', $url, {
              %$args,
              content => $self->www_form_urlencode($data),
              headers => {
                  %$headers,
                  'content-type' => 'application/x-www-form-urlencoded'
              },
          }
      );
  }
  
  
  sub mirror {
      my ($self, $url, $file, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
      if ( -e $file and my $mtime = (stat($file))[9] ) {
          $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
      }
      my $tempfile = $file . int(rand(2**31));
      open my $fh, ">", $tempfile
          or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
      binmode $fh;
      $args->{data_callback} = sub { print {$fh} $_[0] };
      my $response = $self->request('GET', $url, $args);
      close $fh
          or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
      if ( $response->{success} ) {
          rename $tempfile, $file
              or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
          my $lm = $response->{headers}{'last-modified'};
          if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
              utime $mtime, $mtime, $file;
          }
      }
      $response->{success} ||= $response->{status} eq '304';
      unlink $tempfile;
      return $response;
  }
  
  
  my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
  
  sub request {
      my ($self, $method, $url, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
      $args ||= {}; # we keep some state in this during _request
  
      # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
      my $response;
      for ( 0 .. 1 ) {
          $response = eval { $self->_request($method, $url, $args) };
          last unless $@ && $idempotent{$method}
              && $@ =~ m{^(?:Socket closed|Unexpected end)};
      }
  
      if (my $e = "$@") {
          $response = {
              success => q{},
              status  => 599,
              reason  => 'Internal Exception',
              content => $e,
              headers => {
                  'content-type'   => 'text/plain',
                  'content-length' => length $e,
              }
          };
      }
      return $response;
  }
  
  
  sub www_form_urlencode {
      my ($self, $data) = @_;
      (@_ == 2 && ref $data)
          or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
      (ref $data eq 'HASH' || ref $data eq 'ARRAY')
          or Carp::croak("form data must be a hash or array reference");
  
      my @params = ref $data eq 'HASH' ? %$data : @$data;
      @params % 2 == 0
          or Carp::croak("form data reference must have an even number of terms\n");
  
      my @terms;
      while( @params ) {
          my ($key, $value) = splice(@params, 0, 2);
          if ( ref $value eq 'ARRAY' ) {
              unshift @params, map { $key => $_ } @$value;
          }
          else {
              push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
          }
      }
  
      return join("&", sort @terms);
  }
  
  #--------------------------------------------------------------------------#
  # private methods
  #--------------------------------------------------------------------------#
  
  my %DefaultPort = (
      http => 80,
      https => 443,
  );
  
  sub _request {
      my ($self, $method, $url, $args) = @_;
  
      my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
  
      my $request = {
          method    => $method,
          scheme    => $scheme,
          host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
          uri       => $path_query,
          headers   => {},
      };
  
      my $handle  = HTTP::Tiny::Handle->new(timeout => $self->{timeout});
  
      if ($self->{proxy}) {
          $request->{uri} = "$scheme://$request->{host_port}$path_query";
          die(qq/HTTPS via proxy is not supported\n/)
              if $request->{scheme} eq 'https';
          $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
      }
      else {
          $handle->connect($scheme, $host, $port);
      }
  
      $self->_prepare_headers_and_cb($request, $args);
      $handle->write_request($request);
  
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
          $handle->close;
          return $self->_request(@redir_args, $args);
      }
  
      if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
          # response has no message body
      }
      else {
          my $data_cb = $self->_prepare_data_cb($response, $args);
          $handle->read_body($data_cb, $response);
      }
  
      $handle->close;
      $response->{success} = substr($response->{status},0,1) eq '2';
      return $response;
  }
  
  sub _prepare_headers_and_cb {
      my ($self, $request, $args) = @_;
  
      for ($self->{default_headers}, $args->{headers}) {
          next unless defined;
          while (my ($k, $v) = each %$_) {
              $request->{headers}{lc $k} = $v;
          }
      }
      $request->{headers}{'host'}         = $request->{host_port};
      $request->{headers}{'connection'}   = "close";
      $request->{headers}{'user-agent'} ||= $self->{agent};
  
      if (defined $args->{content}) {
          $request->{headers}{'content-type'} ||= "application/octet-stream";
          if (ref $args->{content} eq 'CODE') {
              $request->{headers}{'transfer-encoding'} = 'chunked'
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = $args->{content};
          }
          else {
              my $content = $args->{content};
              if ( $] ge '5.008' ) {
                  utf8::downgrade($content, 1)
                      or die(qq/Wide character in request message body\n/);
              }
              $request->{headers}{'content-length'} = length $content
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = sub { substr $content, 0, length $content, '' };
          }
          $request->{trailer_cb} = $args->{trailer_callback}
              if ref $args->{trailer_callback} eq 'CODE';
      }
      return;
  }
  
  sub _prepare_data_cb {
      my ($self, $response, $args) = @_;
      my $data_cb = $args->{data_callback};
      $response->{content} = '';
  
      if (!$data_cb || $response->{status} !~ /^2/) {
          if (defined $self->{max_size}) {
              $data_cb = sub {
                  $_[1]->{content} .= $_[0];
                  die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
                    if length $_[1]->{content} > $self->{max_size};
              };
          }
          else {
              $data_cb = sub { $_[1]->{content} .= $_[0] };
          }
      }
      return $data_cb;
  }
  
  sub _maybe_redirect {
      my ($self, $request, $response, $args) = @_;
      my $headers = $response->{headers};
      my ($status, $method) = ($response->{status}, $request->{method});
      if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
          and $headers->{location}
          and ++$args->{redirects} <= $self->{max_redirect}
      ) {
          my $location = ($headers->{location} =~ /^\//)
              ? "$request->{scheme}://$request->{host_port}$headers->{location}"
              : $headers->{location} ;
          return (($status eq '303' ? 'GET' : $method), $location);
      }
      return;
  }
  
  sub _split_url {
      my $url = pop;
  
      # URI regex adapted from the URI module
      my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
        or die(qq/Cannot parse URL: '$url'\n/);
  
      $scheme     = lc $scheme;
      $path_query = "/$path_query" unless $path_query =~ m<\A/>;
  
      my $host = (length($authority)) ? lc $authority : 'localhost';
         $host =~ s/\A[^@]*@//;   # userinfo
      my $port = do {
         $host =~ s/:([0-9]*)\z// && length $1
           ? $1
           : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
      };
  
      return ($scheme, $host, $port, $path_query);
  }
  
  # Date conversions adapted from HTTP::Date
  my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
  my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
  sub _http_date {
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
      return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
          substr($DoW,$wday*4,3),
          $mday, substr($MoY,$mon*4,3), $year+1900,
          $hour, $min, $sec
      );
  }
  
  sub _parse_http_date {
      my ($self, $str) = @_;
      require Time::Local;
      my @tl_parts;
      if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
          @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
      }
      return eval {
          my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
          $t < 0 ? undef : $t;
      };
  }
  
  # URI escaping adapted from URI::Escape
  # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
  # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
  my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  $escapes{' '}="+";
  my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
  
  sub _uri_escape {
      my ($self, $str) = @_;
      if ( $] ge '5.008' ) {
          utf8::encode($str);
      }
      else {
          $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
              if ( length $str == do { use bytes; length $str } );
          $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
      }
      $str =~ s/($unsafe_char)/$escapes{$1}/ge;
      return $str;
  }
  
  package
      HTTP::Tiny::Handle; # hide from PAUSE/indexers
  use strict;
  use warnings;
  
  use Errno      qw[EINTR EPIPE];
  use IO::Socket qw[SOCK_STREAM];
  
  sub BUFSIZE () { 32768 }
  
  my $Printable = sub {
      local $_ = shift;
      s/\r/\\r/g;
      s/\n/\\n/g;
      s/\t/\\t/g;
      s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
      $_;
  };
  
  my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
  
  sub new {
      my ($class, %args) = @_;
      return bless {
          rbuf             => '',
          timeout          => 60,
          max_line_size    => 16384,
          max_header_lines => 64,
          %args
      }, $class;
  }
  
  my $ssl_verify_args = {
      check_cn => "when_only",
      wildcards_in_alt => "anywhere",
      wildcards_in_cn => "anywhere"
  };
  
  sub connect {
      @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
      my ($self, $scheme, $host, $port) = @_;
  
      if ( $scheme eq 'https' ) {
          eval "require IO::Socket::SSL"
              unless exists $INC{'IO/Socket/SSL.pm'};
          die(qq/IO::Socket::SSL must be installed for https support\n/)
              unless $INC{'IO/Socket/SSL.pm'};
      }
      elsif ( $scheme ne 'http' ) {
        die(qq/Unsupported URL scheme '$scheme'\n/);
      }
  
      $self->{fh} = 'IO::Socket::INET'->new(
          PeerHost  => $host,
          PeerPort  => $port,
          Proto     => 'tcp',
          Type      => SOCK_STREAM,
          Timeout   => $self->{timeout}
      ) or die(qq/Could not connect to '$host:$port': $@\n/);
  
      binmode($self->{fh})
        or die(qq/Could not binmode() socket: '$!'\n/);
  
      if ( $scheme eq 'https') {
          IO::Socket::SSL->start_SSL($self->{fh});
          ref($self->{fh}) eq 'IO::Socket::SSL'
              or die(qq/SSL connection failed for $host\n/);
          $self->{fh}->verify_hostname( $host, $ssl_verify_args )
              or die(qq/SSL certificate not valid for $host\n/);
      }
  
      $self->{host} = $host;
      $self->{port} = $port;
  
      return $self;
  }
  
  sub close {
      @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
      my ($self) = @_;
      CORE::close($self->{fh})
        or die(qq/Could not close socket: '$!'\n/);
  }
  
  sub write {
      @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
      my ($self, $buf) = @_;
  
      if ( $] ge '5.008' ) {
          utf8::downgrade($buf, 1)
              or die(qq/Wide character in write()\n/);
      }
  
      my $len = length $buf;
      my $off = 0;
  
      local $SIG{PIPE} = 'IGNORE';
  
      while () {
          $self->can_write
            or die(qq/Timed out while waiting for socket to become ready for writing\n/);
          my $r = syswrite($self->{fh}, $buf, $len, $off);
          if (defined $r) {
              $len -= $r;
              $off += $r;
              last unless $len > 0;
          }
          elsif ($! == EPIPE) {
              die(qq/Socket closed by remote server: $!\n/);
          }
          elsif ($! != EINTR) {
              die(qq/Could not write to socket: '$!'\n/);
          }
      }
      return $off;
  }
  
  sub read {
      @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
      my ($self, $len, $allow_partial) = @_;
  
      my $buf  = '';
      my $got = length $self->{rbuf};
  
      if ($got) {
          my $take = ($got < $len) ? $got : $len;
          $buf  = substr($self->{rbuf}, 0, $take, '');
          $len -= $take;
      }
  
      while ($len > 0) {
          $self->can_read
            or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
          my $r = sysread($self->{fh}, $buf, $len, length $buf);
          if (defined $r) {
              last unless $r;
              $len -= $r;
          }
          elsif ($! != EINTR) {
              die(qq/Could not read from socket: '$!'\n/);
          }
      }
      if ($len && !$allow_partial) {
          die(qq/Unexpected end of stream\n/);
      }
      return $buf;
  }
  
  sub readline {
      @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
      my ($self) = @_;
  
      while () {
          if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
              return $1;
          }
          if (length $self->{rbuf} >= $self->{max_line_size}) {
              die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
          }
          $self->can_read
            or die(qq/Timed out while waiting for socket to become ready for reading\n/);
          my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
          if (defined $r) {
              last unless $r;
          }
          elsif ($! != EINTR) {
              die(qq/Could not read from socket: '$!'\n/);
          }
      }
      die(qq/Unexpected end of stream while looking for line\n/);
  }
  
  sub read_header_lines {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
      my ($self, $headers) = @_;
      $headers ||= {};
      my $lines   = 0;
      my $val;
  
      while () {
           my $line = $self->readline;
  
           if (++$lines >= $self->{max_header_lines}) {
               die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
           }
           elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
               my ($field_name) = lc $1;
               if (exists $headers->{$field_name}) {
                   for ($headers->{$field_name}) {
                       $_ = [$_] unless ref $_ eq "ARRAY";
                       push @$_, $2;
                       $val = \$_->[-1];
                   }
               }
               else {
                   $val = \($headers->{$field_name} = $2);
               }
           }
           elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
               $val
                 or die(qq/Unexpected header continuation line\n/);
               next unless length $1;
               $$val .= ' ' if length $$val;
               $$val .= $1;
           }
           elsif ($line =~ /\A \x0D?\x0A \z/x) {
              last;
           }
           else {
              die(q/Malformed header line: / . $Printable->($line) . "\n");
           }
      }
      return $headers;
  }
  
  sub write_request {
      @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
      my($self, $request) = @_;
      $self->write_request_header(@{$request}{qw/method uri headers/});
      $self->write_body($request) if $request->{cb};
      return;
  }
  
  my %HeaderCase = (
      'content-md5'      => 'Content-MD5',
      'etag'             => 'ETag',
      'te'               => 'TE',
      'www-authenticate' => 'WWW-Authenticate',
      'x-xss-protection' => 'X-XSS-Protection',
  );
  
  sub write_header_lines {
      (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
      my($self, $headers) = @_;
  
      my $buf = '';
      while (my ($k, $v) = each %$headers) {
          my $field_name = lc $k;
          if (exists $HeaderCase{$field_name}) {
              $field_name = $HeaderCase{$field_name};
          }
          else {
              $field_name =~ /\A $Token+ \z/xo
                or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
              $field_name =~ s/\b(\w)/\u$1/g;
              $HeaderCase{lc $field_name} = $field_name;
          }
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              /[^\x0D\x0A]/
                or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
              $buf .= "$field_name: $_\x0D\x0A";
          }
      }
      $buf .= "\x0D\x0A";
      return $self->write($buf);
  }
  
  sub read_body {
      @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
      my ($self, $cb, $response) = @_;
      my $te = $response->{headers}{'transfer-encoding'} || '';
      if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
          $self->read_chunked_body($cb, $response);
      }
      else {
          $self->read_content_body($cb, $response);
      }
      return;
  }
  
  sub write_body {
      @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
      my ($self, $request) = @_;
      if ($request->{headers}{'content-length'}) {
          return $self->write_content_body($request);
      }
      else {
          return $self->write_chunked_body($request);
      }
  }
  
  sub read_content_body {
      @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
      my ($self, $cb, $response, $content_length) = @_;
      $content_length ||= $response->{headers}{'content-length'};
  
      if ( $content_length ) {
          my $len = $content_length;
          while ($len > 0) {
              my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
              $cb->($self->read($read, 0), $response);
              $len -= $read;
          }
      }
      else {
          my $chunk;
          $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
      }
  
      return;
  }
  
  sub write_content_body {
      @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my ($len, $content_length) = (0, $request->{headers}{'content-length'});
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_content()\n/);
          }
  
          $len += $self->write($data);
      }
  
      $len == $content_length
        or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
  
      return $len;
  }
  
  sub read_chunked_body {
      @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
      my ($self, $cb, $response) = @_;
  
      while () {
          my $head = $self->readline;
  
          $head =~ /\A ([A-Fa-f0-9]+)/x
            or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
  
          my $len = hex($1)
            or last;
  
          $self->read_content_body($cb, $response, $len);
  
          $self->read(2) eq "\x0D\x0A"
            or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
      }
      $self->read_header_lines($response->{headers});
      return;
  }
  
  sub write_chunked_body {
      @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my $len = 0;
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_chunked_body()\n/);
          }
  
          $len += length $data;
  
          my $chunk  = sprintf '%X', length $data;
             $chunk .= "\x0D\x0A";
             $chunk .= $data;
             $chunk .= "\x0D\x0A";
  
          $self->write($chunk);
      }
      $self->write("0\x0D\x0A");
      $self->write_header_lines($request->{trailer_cb}->())
          if ref $request->{trailer_cb} eq 'CODE';
      return $len;
  }
  
  sub read_response_header {
      @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
      my ($self) = @_;
  
      my $line = $self->readline;
  
      $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
        or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
  
      my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
  
      die (qq/Unsupported HTTP protocol: $protocol\n/)
          unless $version =~ /0*1\.0*[01]/;
  
      return {
          status   => $status,
          reason   => $reason,
          headers  => $self->read_header_lines,
          protocol => $protocol,
      };
  }
  
  sub write_request_header {
      @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
      my ($self, $method, $request_uri, $headers) = @_;
  
      return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
           + $self->write_header_lines($headers);
  }
  
  sub _do_timeout {
      my ($self, $type, $timeout) = @_;
      $timeout = $self->{timeout}
          unless defined $timeout && $timeout >= 0;
  
      my $fd = fileno $self->{fh};
      defined $fd && $fd >= 0
        or die(qq/select(2): 'Bad file descriptor'\n/);
  
      my $initial = time;
      my $pending = $timeout;
      my $nfound;
  
      vec(my $fdset = '', $fd, 1) = 1;
  
      while () {
          $nfound = ($type eq 'read')
              ? select($fdset, undef, undef, $pending)
              : select(undef, $fdset, undef, $pending) ;
          if ($nfound == -1) {
              $! == EINTR
                or die(qq/select(2): '$!'\n/);
              redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
              $nfound = 0;
          }
          last;
      }
      $! = 0;
      return $nfound;
  }
  
  sub can_read {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
      my $self = shift;
      return $self->_do_timeout('read', @_)
  }
  
  sub can_write {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
      my $self = shift;
      return $self->_do_timeout('write', @_)
  }
  
  1;
  
  
  
  __END__
  =pod
  
  =head1 NAME
  
  HTTP::Tiny - A small, simple, correct HTTP/1.1 client
  
  =head1 VERSION
  
  version 0.016
  
  =head1 SYNOPSIS
  
      use HTTP::Tiny;
  
      my $response = HTTP::Tiny->new->get('http://example.com/');
  
      die "Failed!\n" unless $response->{success};
  
      print "$response->{status} $response->{reason}\n";
  
      while (my ($k, $v) = each %{$response->{headers}}) {
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              print "$k: $_\n";
          }
      }
  
      print $response->{content} if length $response->{content};
  
  =head1 DESCRIPTION
  
  This is a very simple HTTP/1.1 client, designed for doing simple GET
  requests without the overhead of a large framework like L<LWP::UserAgent>.
  
  It is more correct and more complete than L<HTTP::Lite>.  It supports
  proxies (currently only non-authenticating ones) and redirection.  It
  also correctly resumes after EINTR.
  
  =head1 METHODS
  
  =head2 new
  
      $http = HTTP::Tiny->new( %attributes );
  
  This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  
  =over 4
  
  =item *
  
  agent
  
  A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
  
  =item *
  
  default_headers
  
  A hashref of default headers to apply to requests
  
  =item *
  
  max_redirect
  
  Maximum number of redirects allowed (defaults to 5)
  
  =item *
  
  max_size
  
  Maximum response size (only when not using a data callback).  If defined,
  responses larger than this will die with an error message
  
  =item *
  
  proxy
  
  URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
  
  =item *
  
  timeout
  
  Request timeout in seconds (default is 60)
  
  =back
  
  =head2 get|head|put|post|delete
  
      $response = $http->get($url);
      $response = $http->get($url, \%options);
      $response = $http->head($url);
  
  These methods are shorthand for calling C<request()> for the given method.  The
  URL must have unsafe characters escaped and international domain names encoded.
  See C<request()> for valid options and a description of the response.
  
  =head2 post_form
  
      $response = $http->post_form($url, $form_data);
      $response = $http->post_form($url, $form_data, \%options);
  
  This method executes a C<POST> request and sends the key/value pairs from a
  form data hash or array reference to the given URL with a C<content-type> of
  C<application/x-www-form-urlencoded>.  See documentation for the
  C<www_form_urlencode> method for details on the encoding.
  
  The URL must have unsafe characters escaped and international domain names
  encoded.  See C<request()> for valid options and a description of the response.
  Any C<content-type> header or content in the options hashref will be ignored.
  
  =head2 mirror
  
      $response = $http->mirror($url, $file, \%options)
      if ( $response->{success} ) {
          print "$file is up to date\n";
      }
  
  Executes a C<GET> request for the URL and saves the response body to the file
  name provided.  The URL must have unsafe characters escaped and international
  domain names encoded.  If the file already exists, the request will includes an
  C<If-Modified-Since> header with the modification timestamp of the file.  You
  may specificy a different C<If-Modified-Since> header yourself in the C<<
  $options->{headers} >> hash.
  
  The C<success> field of the response will be true if the status code is 2XX
  or 304 (unmodified).
  
  If the file was modified and the server response includes a properly
  formatted C<Last-Modified> header, the file modification time will
  be updated accordingly.
  
  =head2 request
  
      $response = $http->request($method, $url);
      $response = $http->request($method, $url, \%options);
  
  Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  international domain names encoded.  A hashref of options may be appended to
  modify the request.
  
  Valid options are:
  
  =over 4
  
  =item *
  
  headers
  
  A hashref containing headers to include with the request.  If the value for
  a header is an array reference, the header will be output multiple times with
  each value in the array.  These headers over-write any default headers.
  
  =item *
  
  content
  
  A scalar to include as the body of the request OR a code reference
  that will be called iteratively to produce the body of the response
  
  =item *
  
  trailer_callback
  
  A code reference that will be called if it exists to provide a hashref
  of trailing headers (only used with chunked transfer-encoding)
  
  =item *
  
  data_callback
  
  A code reference that will be called for each chunks of the response
  body received.
  
  =back
  
  If the C<content> option is a code reference, it will be called iteratively
  to provide the content body of the request.  It should return the empty
  string or undef when the iterator is exhausted.
  
  If the C<data_callback> option is provided, it will be called iteratively until
  the entire response body is received.  The first argument will be a string
  containing a chunk of the response body, the second argument will be the
  in-progress response hash reference, as described below.  (This allows
  customizing the action of the callback based on the C<status> or C<headers>
  received prior to the content body.)
  
  The C<request> method returns a hashref containing the response.  The hashref
  will have the following keys:
  
  =over 4
  
  =item *
  
  success
  
  Boolean indicating whether the operation returned a 2XX status code
  
  =item *
  
  status
  
  The HTTP status code of the response
  
  =item *
  
  reason
  
  The response phrase returned by the server
  
  =item *
  
  content
  
  The body of the response.  If the response does not have any content
  or if a data callback is provided to consume the response body,
  this will be the empty string
  
  =item *
  
  headers
  
  A hashref of header fields.  All header field names will be normalized
  to be lower case. If a header is repeated, the value will be an arrayref;
  it will otherwise be a scalar string containing the value
  
  =back
  
  On an exception during the execution of the request, the C<status> field will
  contain 599, and the C<content> field will contain the text of the exception.
  
  =head2 www_form_urlencode
  
      $params = $http->www_form_urlencode( $data );
      $response = $http->get("http://example.com/query?$params");
  
  This method converts the key/value pairs from a data hash or array reference
  into a C<x-www-form-urlencoded> string.  The keys and values from the data
  reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  array reference, the key will be repeated with each of the values of the array
  reference.  The key/value pairs in the resulting string will be sorted by key
  and value.
  
  =for Pod::Coverage agent
  default_headers
  max_redirect
  max_size
  proxy
  timeout
  
  =head1 LIMITATIONS
  
  HTTP::Tiny is I<conditionally compliant> with the
  L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
  It attempts to meet all "MUST" requirements of the specification, but does not
  implement all "SHOULD" requirements.
  
  Some particular limitations of note include:
  
  =over
  
  =item *
  
  HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
  that user-defined headers and content are compliant with the HTTP/1.1
  specification.
  
  =item *
  
  Users must ensure that URLs are properly escaped for unsafe characters and that
  international domain names are properly encoded to ASCII. See L<URI::Escape>,
  L<URI::_punycode> and L<Net::IDN::Encode>.
  
  =item *
  
  Redirection is very strict against the specification.  Redirection is only
  automatic for response codes 301, 302 and 307 if the request method is 'GET' or
  'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
  mandated by the specification.  There is no automatic support for status 305
  ("Use proxy") redirections.
  
  =item *
  
  Persistent connections are not supported.  The C<Connection> header will
  always be set to C<close>.
  
  =item *
  
  Direct C<https> connections are supported only if L<IO::Socket::SSL> is
  installed.  There is no support for C<https> connections via proxy.
  Any SSL certificate that matches the host is accepted -- SSL certificates
  are not verified against certificate authorities.
  
  =item *
  
  Cookies are not directly supported.  Users that set a C<Cookie> header
  should also set C<max_redirect> to zero to ensure cookies are not
  inappropriately re-transmitted.
  
  =item *
  
  Only the C<http_proxy> environment variable is supported in the format
  C<http://HOST:PORT/>.  If a C<proxy> argument is passed to C<new> (including
  undef), then the C<http_proxy> environment variable is ignored.
  
  =item *
  
  There is no provision for delaying a request body using an C<Expect> header.
  Unexpected C<1XX> responses are silently ignored as per the specification.
  
  =item *
  
  Only 'chunked' C<Transfer-Encoding> is supported.
  
  =item *
  
  There is no support for a Request-URI of '*' for the 'OPTIONS' request.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<LWP::UserAgent>
  
  =back
  
  =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests by email to C<bug-http-tiny at rt.cpan.org>, or through
  the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>. You will be automatically notified of any
  progress on the request by the system.
  
  =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/p5-http-tiny>
  
    git clone https://github.com/dagolden/p5-http-tiny.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Christian Hansen <chansen@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Christian Hansen.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
HTTP_TINY

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

$fatpacked{"JSON.pm"} = <<'JSON';
  package JSON;
  
  
  use strict;
  use Carp ();
  use base qw(Exporter);
  @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
  
  BEGIN {
      $JSON::VERSION = '2.27';
      $JSON::DEBUG   = 0 unless (defined $JSON::DEBUG);
  }
  
  my $Module_XS  = 'JSON::XS';
  my $Module_PP  = 'JSON::PP';
  my $XS_Version = '2.27';
  
  
  # XS and PP common methods
  
  my @PublicMethods = qw/
      ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref 
      allow_blessed convert_blessed filter_json_object filter_json_single_key_object 
      shrink max_depth max_size encode decode decode_prefix allow_unknown
  /;
  
  my @Properties = qw/
      ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref
      allow_blessed convert_blessed shrink max_depth max_size allow_unknown
  /;
  
  my @XSOnlyMethods = qw//; # Currently nothing
  
  my @PPOnlyMethods = qw/
      indent_length sort_by
      allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
  /; # JSON::PP specific
  
  
  # used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
  my $_INSTALL_DONT_DIE  = 1; # When _load_xs fails to load XS, don't die.
  my $_INSTALL_ONLY      = 2; # Don't call _set_methods()
  my $_ALLOW_UNSUPPORTED = 0;
  my $_UNIV_CONV_BLESSED = 0;
  
  
  # Check the environment variable to decide worker module. 
  
  unless ($JSON::Backend) {
      $JSON::DEBUG and  Carp::carp("Check used worker module...");
  
      my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
  
      if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
          _load_xs($_INSTALL_DONT_DIE) or _load_pp();
      }
      elsif ($backend eq '0' or $backend eq 'JSON::PP') {
          _load_pp();
      }
      elsif ($backend eq '2' or $backend eq 'JSON::XS') {
          _load_xs();
      }
      else {
          Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
      }
  }
  
  
  sub import {
      my $pkg = shift;
      my @what_to_export;
      my $no_export;
  
      for my $tag (@_) {
          if ($tag eq '-support_by_pp') {
              if (!$_ALLOW_UNSUPPORTED++) {
                  JSON::Backend::XS
                      ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
              }
              next;
          }
          elsif ($tag eq '-no_export') {
              $no_export++, next;
          }
          elsif ( $tag eq '-convert_blessed_universally' ) {
              eval q|
                  require B;
                  *UNIVERSAL::TO_JSON = sub {
                      my $b_obj = B::svref_2object( $_[0] );
                      return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
                              : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
                              : undef
                              ;
                  }
              | if ( !$_UNIV_CONV_BLESSED++ );
              next;
          }
          push @what_to_export, $tag;
      }
  
      return if ($no_export);
  
      __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
  }
  
  
  # OBSOLETED
  
  sub jsonToObj {
      my $alternative = 'from_json';
      if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
          shift @_; $alternative = 'decode';
      }
      Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead.";
      return JSON::from_json(@_);
  };
  
  sub objToJson {
      my $alternative = 'to_json';
      if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
          shift @_; $alternative = 'encode';
      }
      Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
      JSON::to_json(@_);
  };
  
  
  # INTERFACES
  
  sub to_json ($@) {
      if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
          Carp::croak "to_json should not be called as a method.";
      }
      my $json = new JSON;
  
      if (@_ == 2 and ref $_[1] eq 'HASH') {
          my $opt  = $_[1];
          for my $method (keys %$opt) {
              $json->$method( $opt->{$method} );
          }
      }
  
      $json->encode($_[0]);
  }
  
  
  sub from_json ($@) {
      if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
          Carp::croak "from_json should not be called as a method.";
      }
      my $json = new JSON;
  
      if (@_ == 2 and ref $_[1] eq 'HASH') {
          my $opt  = $_[1];
          for my $method (keys %$opt) {
              $json->$method( $opt->{$method} );
          }
      }
  
      return $json->decode( $_[0] );
  }
  
  
  sub true  { $JSON::true  }
  
  sub false { $JSON::false }
  
  sub null  { undef; }
  
  
  sub require_xs_version { $XS_Version; }
  
  sub backend {
      my $proto = shift;
      $JSON::Backend;
  }
  
  #*module = *backend;
  
  
  sub is_xs {
      return $_[0]->module eq $Module_XS;
  }
  
  
  sub is_pp {
      return $_[0]->module eq $Module_PP;
  }
  
  
  sub pureperl_only_methods { @PPOnlyMethods; }
  
  
  sub property {
      my ($self, $name, $value) = @_;
  
      if (@_ == 1) {
          my %props;
          for $name (@Properties) {
              my $method = 'get_' . $name;
              if ($name eq 'max_size') {
                  my $value = $self->$method();
                  $props{$name} = $value == 1 ? 0 : $value;
                  next;
              }
              $props{$name} = $self->$method();
          }
          return \%props;
      }
      elsif (@_ > 3) {
          Carp::croak('property() can take only the option within 2 arguments.');
      }
      elsif (@_ == 2) {
          if ( my $method = $self->can('get_' . $name) ) {
              if ($name eq 'max_size') {
                  my $value = $self->$method();
                  return $value == 1 ? 0 : $value;
              }
              $self->$method();
          }
      }
      else {
          $self->$name($value);
      }
  
  }
  
  
  
  # INTERNAL
  
  sub _load_xs {
      my $opt = shift;
  
      $JSON::DEBUG and Carp::carp "Load $Module_XS.";
  
      # if called after install module, overload is disable.... why?
      JSON::Boolean::_overrride_overload($Module_XS);
      JSON::Boolean::_overrride_overload($Module_PP);
  
      eval qq|
          use $Module_XS $XS_Version ();
      |;
  
      if ($@) {
          if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
              $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
              return 0;
          }
          Carp::croak $@;
      }
  
      unless (defined $opt and $opt & $_INSTALL_ONLY) {
          _set_module( $JSON::Backend = $Module_XS );
          my $data = join("", <DATA>); # this code is from Jcode 2.xx.
          close(DATA);
          eval $data;
          JSON::Backend::XS->init;
      }
  
      return 1;
  };
  
  
  sub _load_pp {
      my $opt = shift;
  
      $JSON::DEBUG and Carp::carp "Load $Module_PP.";
  
      # if called after install module, overload is disable.... why?
      JSON::Boolean::_overrride_overload($Module_XS);
      JSON::Boolean::_overrride_overload($Module_PP);
  
      eval qq| require $Module_PP |;
      if ($@) {
          Carp::croak $@;
      }
  
      unless (defined $opt and $opt & $_INSTALL_ONLY) {
          _set_module( $JSON::Backend = $Module_PP );
          JSON::Backend::PP->init;
      }
  };
  
  
  sub _set_module {
      my $module = shift;
  
      local $^W;
      no strict qw(refs);
  
      $JSON::true  = ${"$module\::true"};
      $JSON::false = ${"$module\::false"};
  
      push @JSON::ISA, $module;
      push @{"$module\::Boolean::ISA"}, qw(JSON::Boolean);
  
      *{"JSON::is_bool"} = \&{"$module\::is_bool"};
  
      for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
          *{"JSON::$method"} = sub {
              Carp::carp("$method is not supported in $module.");
              $_[0];
          };
      }
  
      return 1;
  }
  
  
  
  #
  # JSON Boolean
  #
  
  package JSON::Boolean;
  
  my %Installed;
  
  sub _overrride_overload {
      return if ($Installed{ $_[0] }++);
  
      my $boolean = $_[0] . '::Boolean';
  
      eval sprintf(q|
          package %s;
          use overload (
              '""' => 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;
                  }
              },
          );
      |, $boolean);
  
      if ($@) { Carp::croak $@; }
  
      return 1;
  }
  
  
  #
  # Helper classes for Backend Module (PP)
  #
  
  package JSON::Backend::PP;
  
  sub init {
      local $^W;
      no strict qw(refs);
      *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
      *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
      *{"JSON::PP::is_xs"}  = sub { 0 };
      *{"JSON::PP::is_pp"}  = sub { 1 };
      return 1;
  }
  
  #
  # To save memory, the below lines are read only when XS backend is used.
  #
  
  package JSON;
  
  1;
  __DATA__
  
  
  #
  # Helper classes for Backend Module (XS)
  #
  
  package JSON::Backend::XS;
  
  use constant INDENT_LENGTH_FLAG => 15 << 12;
  
  use constant UNSUPPORTED_ENCODE_FLAG => {
      ESCAPE_SLASH      => 0x00000010,
      ALLOW_BIGNUM      => 0x00000020,
      AS_NONBLESSED     => 0x00000040,
      EXPANDED          => 0x10000000, # for developer's
  };
  
  use constant UNSUPPORTED_DECODE_FLAG => {
      LOOSE             => 0x00000001,
      ALLOW_BIGNUM      => 0x00000002,
      ALLOW_BAREKEY     => 0x00000004,
      ALLOW_SINGLEQUOTE => 0x00000008,
      EXPANDED          => 0x20000000, # for developer's
  };
  
  
  sub init {
      local $^W;
      no strict qw(refs);
      *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"};
      *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"};
      *{"JSON::XS::is_xs"}  = sub { 1 };
      *{"JSON::XS::is_pp"}  = sub { 0 };
      return 1;
  }
  
  
  sub support_by_pp {
      my ($class, @methods) = @_;
  
      local $^W;
      no strict qw(refs);
  
      my $JSON_XS_encode_orignal     = \&JSON::XS::encode;
      my $JSON_XS_decode_orignal     = \&JSON::XS::decode;
      my $JSON_XS_incr_parse_orignal = \&JSON::XS::incr_parse;
  
      *JSON::XS::decode     = \&JSON::Backend::XS::Supportable::_decode;
      *JSON::XS::encode     = \&JSON::Backend::XS::Supportable::_encode;
      *JSON::XS::incr_parse = \&JSON::Backend::XS::Supportable::_incr_parse;
  
      *{JSON::XS::_original_decode}     = $JSON_XS_decode_orignal;
      *{JSON::XS::_original_encode}     = $JSON_XS_encode_orignal;
      *{JSON::XS::_original_incr_parse} = $JSON_XS_incr_parse_orignal;
  
      push @JSON::Backend::XS::Supportable::ISA, 'JSON';
  
      my $pkg = 'JSON::Backend::XS::Supportable';
  
      *{JSON::new} = sub {
          my $proto = new JSON::XS; $$proto = 0;
          bless  $proto, $pkg;
      };
  
  
      for my $method (@methods) {
          my $flag = uc($method);
          my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0);
             $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0);
  
          next unless($type);
  
          $pkg->_make_unsupported_method($method => $type);
      }
  
      push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean);
      push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean);
  
      $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
  
      return 1;
  }
  
  
  
  
  #
  # Helper classes for XS
  #
  
  package JSON::Backend::XS::Supportable;
  
  $Carp::Internal{'JSON::Backend::XS::Supportable'} = 1;
  
  sub _make_unsupported_method {
      my ($pkg, $method, $type) = @_;
  
      local $^W;
      no strict qw(refs);
  
      *{"$pkg\::$method"} = sub {
          local $^W;
          if (defined $_[1] ? $_[1] : 1) {
              ${$_[0]} |= $type;
          }
          else {
              ${$_[0]} &= ~$type;
          }
          $_[0];
      };
  
      *{"$pkg\::get_$method"} = sub {
          ${$_[0]} & $type ? 1 : '';
      };
  
  }
  
  
  sub _set_for_pp {
      require JSON::PP;
      my $type  = shift;
      my $pp    = new JSON::PP;
      my $prop = $_[0]->property;
  
      for my $name (keys %$prop) {
          $pp->$name( $prop->{$name} ? $prop->{$name} : 0 );
      }
  
      my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG
                                          : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG;
      my $flags       = ${$_[0]} || 0;
  
      for my $name (keys %$unsupported) {
          next if ($name eq 'EXPANDED'); # for developer's
          my $enable = ($flags & $unsupported->{$name}) ? 1 : 0;
          my $method = lc $name;
          $pp->$method($enable);
      }
  
      $pp->indent_length( $_[0]->get_indent_length );
  
      return $pp;
  }
  
  sub _encode { # using with PP encod
      if (${$_[0]}) {
          _set_for_pp('encode' => @_)->encode($_[1]);
      }
      else {
          $_[0]->_original_encode( $_[1] );
      }
  }
  
  
  sub _decode { # if unsupported-flag is set, use PP
      if (${$_[0]}) {
          _set_for_pp('decode' => @_)->decode($_[1]);
      }
      else {
          $_[0]->_original_decode( $_[1] );
      }
  }
  
  
  sub decode_prefix { # if unsupported-flag is set, use PP
      _set_for_pp('decode' => @_)->decode_prefix($_[1]);
  }
  
  
  sub _incr_parse {
      if (${$_[0]}) {
          _set_for_pp('decode' => @_)->incr_parse($_[1]);
      }
      else {
          $_[0]->_original_incr_parse( $_[1] );
      }
  }
  
  
  sub get_indent_length {
      ${$_[0]} << 4 >> 16;
  }
  
  
  sub indent_length {
      my $length = $_[1];
  
      if (!defined $length or $length > 15 or $length < 0) {
          Carp::carp "The acceptable range of indent_length() is 0 to 15.";
      }
      else {
          local $^W;
          $length <<= 12;
          ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG;
          ${$_[0]} |= $length;
          *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode;
      }
  
      $_[0];
  }
  
  
  1;
  __END__
  
  =head1 NAME
  
  JSON - JSON (JavaScript Object Notation) encoder/decoder
  
  =head1 SYNOPSIS
  
   use JSON; # imports encode_json, decode_json, to_json and from_json.
   
   # simple and fast interfaces (expect/generate UTF-8)
   
   $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
   $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
   
   # OO-interface
   
   $json = JSON->new->allow_nonref;
   
   $json_text   = $json->encode( $perl_scalar );
   $perl_scalar = $json->decode( $json_text );
   
   $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
   
   # If you want to use PP only support features, call with '-support_by_pp'
   # When XS unsupported feature is enable, using PP (de|en)code instead of XS ones.
   
   use JSON -support_by_pp;
   
   # option-acceptable interfaces (expect/generate UNICODE by default)
   
   $json_text   = to_json( $perl_scalar, { ascii => 1, pretty => 1 } );
   $perl_scalar = from_json( $json_text, { utf8  => 1 } );
   
   # Between (en|de)code_json and (to|from)_json, if you want to write
   # a code which communicates to an outer world (encoded in UTF-8),
   # recommend to use (en|de)code_json.
   
  =head1 VERSION
  
      2.27
  
  This version is compatible with JSON::XS B<2.27> and later.
  
  
  =head1 DESCRIPTION
  
   ************************** CAUTION ********************************
   * This is 'JSON module version 2' and there are many differences  *
   * to version 1.xx                                                 *
   * Please check your applications useing old version.              *
   *   See to 'INCOMPATIBLE CHANGES TO OLD VERSION'                  *
   *******************************************************************
  
  JSON (JavaScript Object Notation) is a simple data format.
  See to L<http://www.json.org/> and C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>).
  
  This module converts Perl data structures to JSON and vice versa using either
  L<JSON::XS> or L<JSON::PP>.
  
  JSON::XS is the fastest and most proper JSON module on CPAN which must be
  compiled and installed in your environment.
  JSON::PP is a pure-Perl module which is bundled in this distribution and
  has a strong compatibility to JSON::XS.
  
  This module try to use JSON::XS by default and fail to it, use JSON::PP instead.
  So its features completely depend on JSON::XS or JSON::PP.
  
  See to L<BACKEND MODULE DECISION>.
  
  To distinguish the module name 'JSON' and the format type JSON,
  the former is quoted by CE<lt>E<gt> (its results vary with your using media),
  and the latter is left just as it is.
  
  Module name : C<JSON>
  
  Format type : JSON
  
  =head2 FEATURES
  
  =over
  
  =item * correct unicode handling
  
  This module (i.e. backend modules) knows how to handle Unicode, documents
  how and when it does so, and even documents what "correct" means.
  
  Even though there are limitations, this feature is available since Perl version 5.6.
  
  JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions
  C<JSON> sholud call JSON::PP as the backend which can be used since Perl 5.005.
  
  With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem,
  JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available.
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> for more information.
  
  See also to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>
  and L<JSON::XS/ENCODING/CODESET_FLAG_NOTES>.
  
  
  =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
  L</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).
  
  See to L<JSON::XS/FEATURES> and L<JSON::PP/FEATURES>.
  
  =item * fast
  
  This module returns a JSON::XS object itself if available.
  Compared to other JSON modules and other serialisers such as Storable,
  JSON::XS usually compares favourably in terms of speed, too.
  
  If not available, C<JSON> returns a JSON::PP object instead of JSON::XS and
  it is very slow as pure-Perl.
  
  =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
  
  =head1 FUNCTIONAL INTERFACE
  
  Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
  C<to_json> and C<from_json> are additional functions.
  
  =head2 encode_json
  
      $json_text = encode_json $perl_scalar
  
  Converts the given Perl data structure to a UTF-8 encoded, binary string.
  
  This function call is functionally identical to:
  
      $json_text = JSON->new->utf8->encode($perl_scalar)
  
  =head2 decode_json
  
      $perl_scalar = decode_json $json_text
  
  The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
  to parse that as an UTF-8 encoded JSON text, returning the resulting
  reference.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON->new->utf8->decode($json_text)
  
  
  =head2 to_json
  
     $json_text = to_json($perl_scalar)
  
  Converts the given Perl data structure to a json string.
  
  This function call is functionally identical to:
  
     $json_text = JSON->new->encode($perl_scalar)
  
  Takes a hash reference as the second.
  
     $json_text = to_json($perl_scalar, $flag_hashref)
  
  So,
  
     $json_text = encode_json($perl_scalar, {utf8 => 1, pretty => 1})
  
  equivalent to:
  
     $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
  
  If you want to write a modern perl code which communicates to outer world,
  you should use C<encode_json> (supposed that JSON data are encoded in UTF-8).
  
  =head2 from_json
  
     $perl_scalar = from_json($json_text)
  
  The opposite of C<to_json>: expects a json string and tries
  to parse it, returning the resulting reference.
  
  This function call is functionally identical to:
  
      $perl_scalar = JSON->decode($json_text)
  
  Takes a hash reference as the second.
  
      $perl_scalar = from_json($json_text, $flag_hashref)
  
  So,
  
      $perl_scalar = from_json($json_text, {utf8 => 1})
  
  equivalent to:
  
      $perl_scalar = JSON->new->utf8(1)->decode($json_text)
  
  If you want to write a modern perl code which communicates to outer world,
  you should use C<decode_json> (supposed that JSON data are encoded in UTF-8).
  
  =head2 JSON::is_bool
  
      $is_boolean = JSON::is_bool($scalar)
  
  Returns true if the passed scalar represents either JSON::true or
  JSON::false, two constants that act like C<1> and C<0> respectively
  and are also used to represent JSON C<true> and C<false> in Perl strings.
  
  =head2 JSON::true
  
  Returns JSON true value which is blessed object.
  It C<isa> JSON::Boolean object.
  
  =head2 JSON::false
  
  Returns JSON false value which is blessed object.
  It C<isa> JSON::Boolean object.
  
  =head2 JSON::null
  
  Returns C<undef>.
  
  See L<MAPPING>, below, for more information on how JSON values are mapped to
  Perl.
  
  =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
  
  This section supposes that your perl vresion is 5.8 or later.
  
  If you know a JSON text from an outer world - a network, a file content, and so on,
  is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
  with C<utf8> enable. And the decoded result will contain UNICODE characters.
  
    # from network
    my $json        = JSON->new->utf8;
    my $json_text   = CGI->new->param( 'json_data' );
    my $perl_scalar = $json->decode( $json_text );
    
    # from file content
    local $/;
    open( my $fh, '<', 'json.data' );
    $json_text   = <$fh>;
    $perl_scalar = decode_json( $json_text );
  
  If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
  
    use Encode;
    local $/;
    open( my $fh, '<', 'json.data' );
    my $encoding = 'cp932';
    my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
    
    # or you can write the below code.
    #
    # open( my $fh, "<:encoding($encoding)", 'json.data' );
    # $unicode_json_text = <$fh>;
  
  In this case, C<$unicode_json_text> is of course UNICODE string.
  So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable or C<from_json>.
  
    $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
    # or
    $perl_scalar = from_json( $unicode_json_text );
  
  Or C<encode 'utf8'> and C<decode_json>:
  
    $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
    # this way is not efficient.
  
  And now, you want to convert your C<$perl_scalar> into JSON data and
  send it to an outer world - a network or a file content, and so on.
  
  Your data usually contains UNICODE strings and you want the converted data to be encoded
  in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
  
    print encode_json( $perl_scalar ); # to a network? file? or display?
    # or
    print $json->utf8->encode( $perl_scalar );
  
  If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
  for some reason, then its characters are regarded as B<latin1> for perl
  (because it does not concern with your $encoding).
  You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
  Instead of them, you use C<JSON> module object with C<utf8> disable or C<to_json>.
  Note that the resulted text is a UNICODE string but no problem to print it.
  
    # $perl_scalar contains $encoding encoded string values
    $unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
    # or 
    $unicode_json_text = to_json( $perl_scalar );
    # $unicode_json_text consists of characters less than 0x100
    print $unicode_json_text;
  
  Or C<decode $encoding> all string values and C<encode_json>:
  
    $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
    # ... do it to each string values, then encode_json
    $json_text = encode_json( $perl_scalar );
  
  This method is a proper way but probably not efficient.
  
  See to L<Encode>, L<perluniintro>.
  
  
  =head1 COMMON OBJECT-ORIENTED INTERFACE
  
  =head2 new
  
      $json = new JSON
  
  Returns a new C<JSON> object inherited from either JSON::XS or JSON::PP
  that can be used to de/encode JSON strings.
  
  All boolean flags described below are by default I<disabled>.
  
  The mutators for flags all return the JSON object again and thus calls can
  be chained:
  
     my $json = JSON->new->utf8->space_after->encode({a => [1,2]})
     => {"a": [1, 2]}
  
  =head2 ascii
  
      $json = $json->ascii([$enable])
      
      $enabled = $json->get_ascii
  
  If $enable is true (or missing), then the encode method will not generate characters outside
  the code range 0..127. Any Unicode characters outside that range will be escaped using either
  a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
  
  If $enable is false, then the encode method will not escape Unicode characters unless
  required by the JSON syntax or other flags. This results in a faster and more compact format.
  
  This feature depends on the used Perl version and environment.
  
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
  
    JSON->new->ascii(1)->encode([chr 0x10401])
    => ["\ud801\udc01"]
  
  =head2 latin1
  
      $json = $json->latin1([$enable])
      
      $enabled = $json->get_latin1
  
  If $enable is true (or missing), then the encode method will encode the resulting JSON
  text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
  
  If $enable is false, then the encode method will not escape Unicode characters
  unless required by the JSON syntax or other flags.
  
    JSON->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  =head2 utf8
  
      $json = $json->utf8([$enable])
      
      $enabled = $json->get_utf8
  
  If $enable is true (or missing), then the encode method will encode the JSON result
  into UTF-8, as required by many protocols, while the decode method expects to be handled
  an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
  characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
  
  In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
  encoding families, as described in RFC4627.
  
  If $enable is false, then the encode method will return the JSON string as a (non-encoded)
  Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
  (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
  
  
  Example, output UTF-16BE-encoded JSON:
  
    use Encode;
    $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
  
  See to L<JSON::PP/UNICODE HANDLING ON PERLS> if the backend is PP.
  
  
  =head2 pretty
  
      $json = $json->pretty([$enable])
  
  This enables (or disables) all of the C<indent>, C<space_before> and
  C<space_after> (and in the future possibly more) flags in one call to
  generate the most readable (or most compact) form possible.
  
  Equivalent to:
  
     $json->indent->space_before->space_after
  
  The indent space length is three and JSON::XS cannot change the indent
  space length.
  
  =head2 indent
  
      $json = $json->indent([$enable])
      
      $enabled = $json->get_indent
  
  If C<$enable> is true (or missing), then the C<encode> method will use a multiline
  format as output, putting every array member or object/hash key-value pair
  into its own line, identing them properly.
  
  If C<$enable> is false, no newlines or indenting will be produced, and the
  resulting JSON text is guarenteed not to contain any C<newlines>.
  
  This setting has no effect when decoding JSON texts.
  
  The indent space length is three.
  With JSON::PP, you can also access C<indent_length> to change indent space length.
  
  
  =head2 space_before
  
      $json = $json->space_before([$enable])
      
      $enabled = $json->get_space_before
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space before the C<:> separating keys from values in JSON objects.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before enabled, space_after and indent disabled:
  
     {"key" :"value"}
  
  
  =head2 space_after
  
      $json = $json->space_after([$enable])
      
      $enabled = $json->get_space_after
  
  If C<$enable> is true (or missing), then the C<encode> method will add an extra
  optional space after the C<:> separating keys from values in JSON objects
  and extra whitespace after the C<,> separating key-value pairs and array
  members.
  
  If C<$enable> is false, then the C<encode> method will not add any extra
  space at those places.
  
  This setting has no effect when decoding JSON texts.
  
  Example, space_before and indent disabled, space_after enabled:
  
     {"key": "value"}
  
  
  =head2 relaxed
  
      $json = $json->relaxed([$enable])
      
      $enabled = $json->get_relaxed
  
  If C<$enable> is true (or missing), then C<decode> will accept some
  extensions to normal JSON syntax (see below). C<encode> will not be
  affected in anyway. I<Be aware that this option makes you accept invalid
  JSON texts as if they were valid!>. I suggest only to use this option to
  parse application-specific files written by humans (configuration files,
  resource files etc.)
  
  If C<$enable> is false (the default), then C<decode> will only accept
  valid JSON texts.
  
  Currently accepted extensions are:
  
  =over 4
  
  =item * list items can have an end-comma
  
  JSON I<separates> array elements and key-value pairs with commas. This
  can be annoying if you write JSON texts manually and want to be able to
  quickly append elements, so this extension accepts comma at the end of
  such items not just between them:
  
     [
        1,
        2, <- this comma not normally allowed
     ]
     {
        "k1": "v1",
        "k2": "v2", <- this comma not normally allowed
     }
  
  =item * shell-style '#'-comments
  
  Whenever JSON allows whitespace, shell-style comments are additionally
  allowed. They are terminated by the first carriage-return or line-feed
  character, after which more white-space and comments are allowed.
  
    [
       1, # this comment not allowed in JSON
          # neither this one...
    ]
  
  =back
  
  
  =head2 canonical
  
      $json = $json->canonical([$enable])
      
      $enabled = $json->get_canonical
  
  If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
  by sorting their keys. This is adding a comparatively high overhead.
  
  If C<$enable> is false, then the C<encode> method will output key-value
  pairs in the order Perl stores them (which will likely change between runs
  of the same script).
  
  This option is useful if you want the same data structure to be encoded as
  the same JSON text (given the same overall settings). If it is disabled,
  the same hash might be encoded differently even if contains the same data,
  as key-value pairs have no inherent ordering in Perl.
  
  This setting has no effect when decoding JSON texts.
  
  =head2 allow_nonref
  
      $json = $json->allow_nonref([$enable])
      
      $enabled = $json->get_allow_nonref
  
  If C<$enable> is true (or missing), then the C<encode> method can convert a
  non-reference into its corresponding string, number or null JSON value,
  which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
  values instead of croaking.
  
  If C<$enable> is false, then the C<encode> method will croak if it isn't
  passed an arrayref or hashref, as JSON texts must either be an object
  or array. Likewise, C<decode> will croak if given something that is not a
  JSON object or array.
  
     JSON->new->allow_nonref->encode ("Hello, World!")
     => "Hello, World!"
  
  =head2 allow_unknown
  
      $json = $json->allow_unknown ([$enable])
      
      $enabled = $json->get_allow_unknown
  
  If $enable is true (or missing), then "encode" will *not* throw an
  exception when it encounters values it cannot represent in JSON (for
  example, filehandles) but instead will encode a JSON "null" value.
  Note that blessed objects are not included here and are handled
  separately by c<allow_nonref>.
  
  If $enable is false (the default), then "encode" will throw an
  exception when it encounters anything it cannot encode as JSON.
  
  This option does not affect "decode" in any way, and it is
  recommended to leave it off unless you know your communications
  partner.
  
  =head2 allow_blessed
  
      $json = $json->allow_blessed([$enable])
      
      $enabled = $json->get_allow_blessed
  
  If C<$enable> is true (or missing), then the C<encode> method will not
  barf when it encounters a blessed reference. Instead, the value of the
  B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
  disabled or no C<TO_JSON> method found) or a representation of the
  object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
  encoded. Has no effect on C<decode>.
  
  If C<$enable> is false (the default), then C<encode> will throw an
  exception when it encounters a blessed object.
  
  
  =head2 convert_blessed
  
      $json = $json->convert_blessed([$enable])
      
      $enabled = $json->get_convert_blessed
  
  If C<$enable> is true (or missing), then C<encode>, upon encountering a
  blessed object, will check for the availability of the C<TO_JSON> method
  on the object's class. If found, it will be called in scalar context
  and the resulting scalar will be encoded instead of the object. If no
  C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
  to do.
  
  The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
  returns other blessed objects, those will be handled in the same
  way. C<TO_JSON> must take care of not causing an endless recursion cycle
  (== crash) in this case. The name of C<TO_JSON> was chosen because other
  methods called by the Perl core (== not by the user of the object) are
  usually in upper case letters and to avoid collisions with the C<to_json>
  function or method.
  
  This setting does not yet influence C<decode> in any way.
  
  If C<$enable> is false, then the C<allow_blessed> setting will decide what
  to do when a blessed object is found.
  
  =over
  
  =item convert_blessed_universally mode
  
  If use C<JSON> with C<-convert_blessed_universally>, the C<UNIVERSAL::TO_JSON>
  subroutine is defined as the below code:
  
     *UNIVERSAL::TO_JSON = sub {
         my $b_obj = B::svref_2object( $_[0] );
         return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
                 : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
                 : undef
                 ;
     }
  
  This will cause that C<encode> method converts simple blessed objects into
  JSON objects as non-blessed object.
  
     JSON -convert_blessed_universally;
     $json->allow_blessed->convert_blessed->encode( $blessed_object )
  
  This feature is experimental and may be removed in the future.
  
  =back
  
  =head2 filter_json_object
  
      $json = $json->filter_json_object([$coderef])
  
  When C<$coderef> is specified, it will be called from C<decode> each
  time it decodes a JSON object. The only argument passed to the coderef
  is a reference to the newly-created hash. If the code references returns
  a single scalar (which need not be a reference), this value
  (i.e. a copy of that scalar to avoid aliasing) is inserted into the
  deserialised data structure. If it returns an empty list
  (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
  hash will be inserted. This setting can slow down decoding considerably.
  
  When C<$coderef> is omitted or undefined, any existing callback will
  be removed and C<decode> will not change the deserialised hash in any
  way.
  
  Example, convert all JSON objects into the integer 5:
  
     my $js = JSON->new->filter_json_object (sub { 5 });
     # returns [5]
     $js->decode ('[{}]'); # the given subroutine takes a hash reference.
     # throw an exception because allow_nonref is not enabled
     # so a lone 5 is not allowed.
     $js->decode ('{"a":1, "b":2}');
  
  
  =head2 filter_json_single_key_object
  
      $json = $json->filter_json_single_key_object($key [=> $coderef])
  
  Works remotely similar to C<filter_json_object>, but is only called for
  JSON objects having a single key named C<$key>.
  
  This C<$coderef> is called before the one specified via
  C<filter_json_object>, if any. It gets passed the single value in the JSON
  object. If it returns a single value, it will be inserted into the data
  structure. If it returns nothing (not even C<undef> but the empty list),
  the callback from C<filter_json_object> will be called next, as if no
  single-key callback were specified.
  
  If C<$coderef> is omitted or undefined, the corresponding callback will be
  disabled. There can only ever be one callback for a given key.
  
  As this callback gets called less often then the C<filter_json_object>
  one, decoding speed will not usually suffer as much. Therefore, single-key
  objects make excellent targets to serialise Perl objects into, especially
  as single-key JSON objects are as close to the type-tagged value concept
  as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
  support this in any way, so you need to make sure your data never looks
  like a serialised Perl hash.
  
  Typical names for the single object key are C<__class_whatever__>, or
  C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
  things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
  with real hashes.
  
  Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
  into the corresponding C<< $WIDGET{<id>} >> object:
  
     # return whatever is in $WIDGET{5}:
     JSON
        ->new
        ->filter_json_single_key_object (__widget__ => sub {
              $WIDGET{ $_[0] }
           })
        ->decode ('{"__widget__": 5')
  
     # this can be used with a TO_JSON method in some "widget" class
     # for serialisation to json:
     sub WidgetBase::TO_JSON {
        my ($self) = @_;
  
        unless ($self->{id}) {
           $self->{id} = ..get..some..id..;
           $WIDGET{$self->{id}} = $self;
        }
  
        { __widget__ => $self->{id} }
     }
  
  
  =head2 shrink
  
      $json = $json->shrink([$enable])
      
      $enabled = $json->get_shrink
  
  With JSON::XS, this flag 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).
  
  With JSON::PP, it is noop about resizing strings but tries
  C<utf8::downgrade> to the returned string by C<encode>. See to L<utf8>.
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE> and L<JSON::PP/METHODS>.
  
  =head2 max_depth
  
      $json = $json->max_depth([$maximum_nesting_depth])
      
      $max_depth = $json->get_max_depth
  
  Sets the maximum nesting level (default C<512>) accepted while encoding
  or decoding. If a higher nesting level is detected in JSON text or a Perl
  data structure, then the encoder and decoder will stop and croak at that
  point.
  
  Nesting level is defined by number of hash- or arrayrefs that the encoder
  needs to traverse to reach a given point or the number of C<{> or C<[>
  characters without their matching closing parenthesis crossed to reach a
  given character in a string.
  
  If no argument is given, the highest possible setting will be used, which
  is rarely useful.
  
  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. (JSON::XS)
  
  With JSON::PP as the backend, when a large value (100 or more) was set and
  it de/encodes a deep nested object/text, it may raise a warning
  'Deep recursion on subroutin' at the perl runtime phase.
  
  See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =head2 max_size
  
      $json = $json->max_size([$maximum_string_size])
      
      $max_size = $json->get_max_size
  
  Set the maximum length a JSON text may have (in bytes) where decoding is
  being attempted. The default is C<0>, meaning no limit. When C<decode>
  is called on a string that is longer then this many bytes, it will not
  attempt to decode the string but throw an exception. This setting has no
  effect on C<encode> (yet).
  
  If no argument is given, the limit check will be deactivated (same as when
  C<0> is specified).
  
  See L<JSON::XS/SECURITY CONSIDERATIONS>, below, for more info on why this is useful.
  
  =head2 encode
  
      $json_text = $json->encode($perl_scalar)
  
  Converts the given Perl data structure (a simple scalar or a reference
  to a hash or array) to its JSON representation. Simple scalars will be
  converted into JSON string or number sequences, while references to arrays
  become JSON arrays and references to hashes become JSON objects. Undefined
  Perl values (e.g. C<undef>) become JSON C<null> values.
  References to the integers C<0> and C<1> are converted into C<true> and C<false>.
  
  =head2 decode
  
      $perl_scalar = $json->decode($json_text)
  
  The opposite of C<encode>: expects a JSON text and tries to parse it,
  returning the resulting simple scalar or reference. Croaks on error.
  
  JSON numbers and strings become simple Perl scalars. JSON arrays become
  Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
  C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
  C<null> becomes C<undef>.
  
  =head2 decode_prefix
  
      ($perl_scalar, $characters) = $json->decode_prefix($json_text)
  
  This works like the C<decode> method, but instead of raising an exception
  when there is trailing garbage after the first JSON object, it will
  silently stop parsing there and return the number of characters consumed
  so far.
  
     JSON->new->decode_prefix ("[1] the tail")
     => ([], 3)
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
  
  =head2 property
  
      $boolean = $json->property($property_name)
  
  Returns a boolean value about above some properties.
  
  The available properties are C<ascii>, C<latin1>, C<utf8>,
  C<indent>,C<space_before>, C<space_after>, C<relaxed>, C<canonical>,
  C<allow_nonref>, C<allow_unknown>, C<allow_blessed>, C<convert_blessed>,
  C<shrink>, C<max_depth> and C<max_size>.
  
     $boolean = $json->property('utf8');
      => 0
     $json->utf8;
     $boolean = $json->property('utf8');
      => 1
  
  Sets the property with a given boolean value.
  
      $json = $json->property($property_name => $boolean);
  
  With no argumnt, it returns all the above properties as a hash reference.
  
      $flag_hashref = $json->property();
  
  =head1 INCREMENTAL PARSING
  
  Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
  
  In some cases, there is the need for incremental parsing of JSON texts.
  This module does allow you to parse a JSON stream incrementally.
  It does so by accumulating text until it has a full JSON object, which
  it then can decode. This process is similar to using C<decode_prefix>
  to see if a full JSON object is available, but is much more efficient
  (and can be implemented with a minimum of method calls).
  
  The backend module will only attempt to parse the JSON text once it is sure it
  has enough text to get a decisive result, using a very simple but
  truly incremental parser. This means that it sometimes won't stop as
  early as the full parser, for example, it doesn't detect parenthese
  mismatches. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =head2 incr_parse
  
      $json->incr_parse( [$string] ) # void context
      
      $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
      
      @obj_or_empty = $json->incr_parse( [$string] ) # list context
  
  This is the central parsing function. It can both append new text and
  extract objects from the stream accumulated so far (both of these
  functions are optional).
  
  If C<$string> is given, then this string is appended to the already
  existing JSON fragment stored in the C<$json> object.
  
  After that, if the function is called in void context, it will simply
  return without doing anything further. This can be used to add more text
  in as many chunks as you want.
  
  If the method is called in scalar context, then it will try to extract
  exactly I<one> JSON object. If that is successful, it will return this
  object, otherwise it will return C<undef>. If there is a parse error,
  this method will croak just as C<decode> would do (one can then use
  C<incr_skip> to skip the errornous part). This is the most common way of
  using the method.
  
  And finally, in list context, it will try to extract as many objects
  from the stream as it can find and return them, or the empty list
  otherwise. For this to work, there must be no separators between the JSON
  objects or arrays, instead they must be concatenated back-to-back. If
  an error occurs, an exception will be raised as in the scalar context
  case. Note that in this case, any previously-parsed JSON texts will be
  lost.
  
  Example: Parse some JSON arrays/objects in a given string and return them.
  
      my @objs = JSON->new->incr_parse ("[5][7][1,2]");
  
  =head2 incr_text
  
      $lvalue_string = $json->incr_text
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object. Under
  all other circumstances you must not call this function (I mean it.
  although in simple tests it might actually work, it I<will> fail under
  real world conditions). As a special exception, you can also call this
  method before having parsed anything.
  
  This function is useful in two cases: a) finding the trailing text after a
  JSON object or b) parsing multiple JSON objects separated by non-JSON text
  (such as commas).
  
      $json->incr_text =~ s/\s*,\s*//;
  
  In Perl 5.005, C<lvalue> attribute is not available.
  You must write codes like the below:
  
      $string = $json->incr_text;
      $string =~ s/\s*,\s*//;
      $json->incr_text( $string );
  
  =head2 incr_skip
  
      $json->incr_skip
  
  This will reset the state of the incremental parser and will remove the
  parsed text from the input buffer. This is useful after C<incr_parse>
  died, in which case the input buffer and incremental parser state is left
  unchanged, to skip the text parsed so far and to reset the parse state.
  
  =head2 incr_reset
  
      $json->incr_reset
  
  This completely resets the incremental parser, that is, after this call,
  it will be as if the parser had never parsed anything.
  
  This is useful if you want ot repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  See to L<JSON::XS/INCREMENTAL PARSING> for examples.
  
  
  =head1 JSON::PP SUPPORT METHODS
  
  The below methods are JSON::PP own methods, so when C<JSON> works
  with JSON::PP (i.e. the created object is a JSON::PP object), available.
  See to L<JSON::PP/JSON::PP OWN METHODS> in detail.
  
  If you use C<JSON> with additonal C<-support_by_pp>, some methods
  are available even with JSON::XS. See to L<USE PP FEATURES EVEN THOUGH XS BACKEND>.
  
     BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
     
     use JSON -support_by_pp;
     
     my $json = new JSON;
     $json->allow_nonref->escape_slash->encode("/");
  
     # functional interfaces too.
     print to_json(["/"], {escape_slash => 1});
     print from_json('["foo"]', {utf8 => 1});
  
  If you do not want to all functions but C<-support_by_pp>,
  use C<-no_export>.
  
     use JSON -support_by_pp, -no_export;
     # functional interfaces are not exported.
  
  =head2 allow_singlequote
  
      $json = $json->allow_singlequote([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  any JSON strings quoted by single quotations that are invalid JSON
  format.
  
      $json->allow_singlequote->decode({"foo":'bar'});
      $json->allow_singlequote->decode({'foo':"bar"});
      $json->allow_singlequote->decode({'foo':'bar'});
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
  =head2 allow_barekey
  
      $json = $json->allow_barekey([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  bare keys of JSON object that are invalid JSON format.
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
      $json->allow_barekey->decode('{foo:"bar"}');
  
  =head2 allow_bignum
  
      $json = $json->allow_bignum([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will convert
  the big integer Perl cannot handle as integer into a L<Math::BigInt>
  object and convert a floating number (any) into a L<Math::BigFloat>.
  
  On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers with C<allow_blessed> enable.
  
     $json->allow_nonref->allow_blessed->allow_bignum;
     $bigfloat = $json->decode('2.000000000000000000000000001');
     print $json->encode($bigfloat);
     # => 2.000000000000000000000000001
  
  See to L<MAPPING> aboout the conversion of JSON number.
  
  =head2 loose
  
      $json = $json->loose([$enable])
  
  The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
  and the module doesn't allow to C<decode> to these (except for \x2f).
  If C<$enable> is true (or missing), then C<decode>  will accept these
  unescaped strings.
  
      $json->loose->decode(qq|["abc
                                     def"]|);
  
  See to L<JSON::PP/JSON::PP OWN METHODS>.
  
  =head2 escape_slash
  
      $json = $json->escape_slash([$enable])
  
  According to JSON Grammar, I<slash> (U+002F) is escaped. But by default
  JSON backend modules encode strings without escaping slash.
  
  If C<$enable> is true (or missing), then C<encode> will escape slashes.
  
  =head2 indent_length
  
      $json = $json->indent_length($length)
  
  With JSON::XS, The indent space length is 3 and cannot be changed.
  With JSON::PP, it sets the indent space length with the given $length.
  The default is 3. The acceptable range is 0 to 15.
  
  =head2 sort_by
  
      $json = $json->sort_by($function_name)
      $json = $json->sort_by($subroutine_ref)
  
  If $function_name or $subroutine_ref are set, its sort routine are used.
  
     $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     $js = $pc->sort_by('own_sort')->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
  
  As the sorting routine runs in the JSON::PP scope, the given
  subroutine name and the special variables C<$a>, C<$b> will begin
  with 'JSON::PP::'.
  
  If $integer is set, then the effect is same as C<canonical> on.
  
  See to L<JSON::PP/JSON::PP OWN METHODS>.
  
  =head1 MAPPING
  
  This section is copied from JSON::XS and modified to C<JSON>.
  JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
  
  See to L<JSON::XS/MAPPING>.
  
  =head2 JSON -> PERL
  
  =over 4
  
  =item object
  
  A JSON object becomes a reference to a hash in Perl. No ordering of object
  keys is preserved (JSON does not preserver object key ordering itself).
  
  =item array
  
  A JSON array becomes a reference to an array in Perl.
  
  =item string
  
  A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
  are represented by the same codepoints in the Perl string, so no manual
  decoding is necessary.
  
  =item number
  
  A JSON number becomes either an integer, numeric (floating point) or
  string scalar in perl, depending on its range and any fractional parts. On
  the Perl level, there is no difference between those as Perl handles all
  the conversion details, but an integer may take slightly less memory and
  might represent more values exactly than floating point numbers.
  
  If the number consists of digits only, C<JSON> will try to represent
  it as an integer value. If that fails, it will try to represent it as
  a numeric (floating point) value if that is possible without loss of
  precision. Otherwise it will preserve the number as a string value (in
  which case you lose roundtripping ability, as the JSON number will be
  re-encoded toa JSON string).
  
  Numbers containing a fractional or exponential part will always be
  represented as numeric (floating point) values, possibly at a loss of
  precision (in which case you might lose perfect roundtripping ability, but
  the JSON number will still be re-encoded as a JSON number).
  
  Note that precision is not accuracy - binary floating point values cannot
  represent most decimal fractions exactly, and when converting from and to
  floating point, C<JSON> only guarantees precision up to but not including
  the leats significant bit.
  
  If the backend is JSON::PP and C<allow_bignum> is enable, the big integers 
  and the numeric can be optionally converted into L<Math::BigInt> and
  L<Math::BigFloat> objects.
  
  =item true, false
  
  These JSON atoms become C<JSON::true> and C<JSON::false>,
  respectively. They are overloaded to act almost exactly like the numbers
  C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
  the C<JSON::is_bool> function.
  
  If C<JSON::true> and C<JSON::false> are used as strings or compared as strings,
  they represent as C<true> and C<false> respectively.
  
     print JSON::true . "\n";
      => true
     print JSON::true + 1;
      => 1
  
     ok(JSON::true eq 'true');
     ok(JSON::true eq  '1');
     ok(JSON::true == 1);
  
  C<JSON> will install these missing overloading features to the backend modules.
  
  
  =item null
  
  A JSON null atom becomes C<undef> in Perl.
  
  C<JSON::null> returns C<unddef>.
  
  =back
  
  
  =head2 PERL -> JSON
  
  The mapping from Perl to JSON is slightly more difficult, as Perl is a
  truly typeless language, so we can only guess which JSON type is meant by
  a Perl value.
  
  =over 4
  
  =item hash references
  
  Perl hash references become JSON objects. As there is no inherent ordering
  in hash keys (or JSON objects), they will usually be encoded in a
  pseudo-random order that can change between runs of the same program but
  stays generally the same within a single run of a program. C<JSON>
  optionally sort the hash keys (determined by the I<canonical> flag), so
  the same datastructure will serialise to the same JSON text (given same
  settings and version of JSON::XS), but this incurs a runtime overhead
  and is only rarely useful, e.g. when you want to compare some JSON text
  against another for equality.
  
  In future, the ordered object feature will be added to JSON::PP using C<tie> mechanism.
  
  
  =item array references
  
  Perl array references become JSON arrays.
  
  =item other references
  
  Other unblessed references are generally not allowed and will cause an
  exception to be thrown, except for references to the integers C<0> and
  C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
  also use C<JSON::false> and C<JSON::true> to improve readability.
  
     to_json [\0,JSON::true]      # yields [false,true]
  
  =item JSON::true, JSON::false, JSON::null
  
  These special values become JSON true and JSON false values,
  respectively. You can also use C<\1> and C<\0> directly if you want.
  
  JSON::null returns C<undef>.
  
  =item blessed objects
  
  Blessed objects are not directly representable in JSON. See the
  C<allow_blessed> and C<convert_blessed> methods on various options on
  how to deal with this: basically, you can choose between throwing an
  exception, encoding the reference as if it weren't blessed, or provide
  your own serialiser method.
  
  With C<convert_blessed_universally> mode,  C<encode> converts blessed
  hash references or blessed array references (contains other blessed references)
  into JSON members and arrays.
  
     use JSON -convert_blessed_universally;
     JSON->new->allow_blessed->convert_blessed->encode( $blessed_object );
  
  See to L<convert_blessed>.
  
  =item simple scalars
  
  Simple Perl scalars (any scalar that is not a reference) are the most
  difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
  JSON C<null> values, scalars that have last been used in a string context
  before encoding as JSON strings, and anything else as number value:
  
     # dump as number
     encode_json [2]                      # yields [2]
     encode_json [-3.0e17]                # yields [-3e+17]
     my $value = 5; encode_json [$value]  # yields [5]
  
     # used as string, so dump as string
     print $value;
     encode_json [$value]                 # yields ["5"]
  
     # undef becomes null
     encode_json [undef]                  # yields [null]
  
  You can force the type to be a string by stringifying it:
  
     my $x = 3.1; # some variable containing a number
     "$x";        # stringified
     $x .= "";    # another, more awkward way to stringify
     print $x;    # perl does it for you, too, quite often
  
  You can force the type to be a number by numifying it:
  
     my $x = "3"; # some variable containing a string
     $x += 0;     # numify it, ensuring it will be dumped as a number
     $x *= 1;     # same thing, the choise is yours.
  
  You can not currently force the type in other, less obscure, ways.
  
  Note that numerical precision has the same meaning as under Perl (so
  binary to decimal conversion follows the same rules as in Perl, which
  can differ to other languages). Also, your perl interpreter might expose
  extensions to the floating point numbers of your platform, such as
  infinities or NaN's - these cannot be represented in JSON, and it is an
  error to pass those in.
  
  =item Big Number
  
  If the backend is JSON::PP and C<allow_bignum> is enable, 
  C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers.
  
  
  =back
  
  =head1 JSON and ECMAscript
  
  See to L<JSON::XS/JSON and ECMAscript>.
  
  =head1 JSON and YAML
  
  JSON is not a subset of YAML.
  See to L<JSON::XS/JSON and YAML>.
  
  
  =head1 BACKEND MODULE DECISION
  
  When you use C<JSON>, C<JSON> tries to C<use> JSON::XS. If this call failed, it will
  C<uses> JSON::PP. The required JSON::XS version is I<2.2> or later.
  
  The C<JSON> constructor method returns an object inherited from the backend module,
  and JSON::XS object is a blessed scaler reference while JSON::PP is a blessed hash
  reference.
  
  So, your program should not depend on the backend module, especially
  returned objects should not be modified.
  
   my $json = JSON->new; # XS or PP?
   $json->{stash} = 'this is xs object'; # this code may raise an error!
  
  To check the backend module, there are some methods - C<backend>, C<is_pp> and C<is_xs>.
  
    JSON->backend; # 'JSON::XS' or 'JSON::PP'
    
    JSON->backend->is_pp: # 0 or 1
    
    JSON->backend->is_xs: # 1 or 0
    
    $json->is_xs; # 1 or 0
    
    $json->is_pp; # 0 or 1
  
  
  If you set an enviornment variable C<PERL_JSON_BACKEND>, The calling action will be changed.
  
  =over
  
  =item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'JSON::PP'
  
  Always use JSON::PP
  
  =item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,JSON::PP'
  
  (The default) Use compiled JSON::XS if it is properly compiled & installed,
  otherwise use JSON::PP.
  
  =item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS'
  
  Always use compiled JSON::XS, die if it isn't properly compiled & installed.
  
  =back
  
  These ideas come from L<DBI::PurePerl> mechanism.
  
  example:
  
   BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::PP' }
   use JSON; # always uses JSON::PP
  
  In future, it may be able to specify another module.
  
  =head1 USE PP FEATURES EVEN THOUGH XS BACKEND
  
  Many methods are available with either JSON::XS or JSON::PP and
  when the backend module is JSON::XS, if any JSON::PP specific (i.e. JSON::XS unspported)
  method is called, it will C<warn> and be noop.
  
  But If you C<use> C<JSON> passing the optional string C<-support_by_pp>,
  it makes a part of those unupported methods available.
  This feature is achieved by using JSON::PP in C<de/encode>.
  
     BEGIN { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS
     use JSON -support_by_pp;
     my $json = new JSON;
     $json->allow_nonref->escape_slash->encode("/");
  
  At this time, the returned object is a C<JSON::Backend::XS::Supportable>
  object (re-blessed XS object), and  by checking JSON::XS unsupported flags
  in de/encoding, can support some unsupported methods - C<loose>, C<allow_bignum>,
  C<allow_barekey>, C<allow_singlequote>, C<escape_slash> and C<indent_length>.
  
  When any unsupported methods are not enable, C<XS de/encode> will be
  used as is. The switch is achieved by changing the symbolic tables.
  
  C<-support_by_pp> is effective only when the backend module is JSON::XS
  and it makes the de/encoding speed down a bit.
  
  See to L<JSON::PP SUPPORT METHODS>.
  
  =head1 INCOMPATIBLE CHANGES TO OLD VERSION
  
  There are big incompatibility between new version (2.00) and old (1.xx).
  If you use old C<JSON> 1.xx in your code, please check it.
  
  See to L<Transition ways from 1.xx to 2.xx.>
  
  =over
  
  =item jsonToObj and objToJson are obsoleted.
  
  Non Perl-style name C<jsonToObj> and C<objToJson> are obsoleted
  (but not yet deleted from the source).
  If you use these functions in your code, please replace them
  with C<from_json> and C<to_json>.
  
  
  =item Global variables are no longer available.
  
  C<JSON> class variables - C<$JSON::AUTOCONVERT>, C<$JSON::BareKey>, etc...
  - are not available any longer.
  Instead, various features can be used through object methods.
  
  
  =item Package JSON::Converter and JSON::Parser are deleted.
  
  Now C<JSON> bundles with JSON::PP which can handle JSON more properly than them.
  
  =item Package JSON::NotString is deleted.
  
  There was C<JSON::NotString> class which represents JSON value C<true>, C<false>, C<null>
  and numbers. It was deleted and replaced by C<JSON::Boolean>.
  
  C<JSON::Boolean> represents C<true> and C<false>.
  
  C<JSON::Boolean> does not represent C<null>.
  
  C<JSON::null> returns C<undef>.
  
  C<JSON> makes L<JSON::XS::Boolean> and L<JSON::PP::Boolean> is-a relation
  to L<JSON::Boolean>.
  
  =item function JSON::Number is obsoleted.
  
  C<JSON::Number> is now needless because JSON::XS and JSON::PP have
  round-trip integrity.
  
  =item JSONRPC modules are deleted.
  
  Perl implementation of JSON-RPC protocol - C<JSONRPC >, C<JSONRPC::Transport::HTTP>
  and C<Apache::JSONRPC > are deleted in this distribution.
  Instead of them, there is L<JSON::RPC> which supports JSON-RPC protocol version 1.1.
  
  =back
  
  =head2 Transition ways from 1.xx to 2.xx.
  
  You should set C<suport_by_pp> mode firstly, because
  it is always successful for the below codes even with JSON::XS.
  
      use JSON -support_by_pp;
  
  =over
  
  =item Exported jsonToObj (simple)
  
    from_json($json_text);
  
  =item Exported objToJson (simple)
  
    to_json($perl_scalar);
  
  =item Exported jsonToObj (advanced)
  
    $flags = {allow_barekey => 1, allow_singlequote => 1};
    from_json($json_text, $flags);
  
  equivalent to:
  
    $JSON::BareKey = 1;
    $JSON::QuotApos = 1;
    jsonToObj($json_text);
  
  =item Exported objToJson (advanced)
  
    $flags = {allow_blessed => 1, allow_barekey => 1};
    to_json($perl_scalar, $flags);
  
  equivalent to:
  
    $JSON::BareKey = 1;
    objToJson($perl_scalar);
  
  =item jsonToObj as object method
  
    $json->decode($json_text);
  
  =item objToJson as object method
  
    $json->encode($perl_scalar);
  
  =item new method with parameters
  
  The C<new> method in 2.x takes any parameters no longer.
  You can set parameters instead;
  
     $json = JSON->new->pretty;
  
  =item $JSON::Pretty, $JSON::Indent, $JSON::Delimiter
  
  If C<indent> is enable, that menas C<$JSON::Pretty> flag set. And
  C<$JSON::Delimiter> was substituted by C<space_before> and C<space_after>.
  In conclusion:
  
     $json->indent->space_before->space_after;
  
  Equivalent to:
  
    $json->pretty;
  
  To change indent length, use C<indent_length>.
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->pretty->indent_length(2)->encode($perl_scalar);
  
  =item $JSON::BareKey
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->allow_barekey->decode($json_text)
  
  =item $JSON::ConvBlessed
  
  use C<-convert_blessed_universally>. See to L<convert_blessed>.
  
  =item $JSON::QuotApos
  
  (Only with JSON::PP, if C<-support_by_pp> is not used.)
  
    $json->allow_singlequote->decode($json_text)
  
  =item $JSON::SingleQuote
  
  Disable. C<JSON> does not make such a invalid JSON string any longer.
  
  =item $JSON::KeySort
  
    $json->canonical->encode($perl_scalar)
  
  This is the ascii sort.
  
  If you want to use with your own sort routine, check the C<sort_by> method.
  
  (Only with JSON::PP, even if C<-support_by_pp> is used currently.)
  
    $json->sort_by($sort_routine_ref)->encode($perl_scalar)
   
    $json->sort_by(sub { $JSON::PP::a <=> $JSON::PP::b })->encode($perl_scalar)
  
  Can't access C<$a> and C<$b> but C<$JSON::PP::a> and C<$JSON::PP::b>.
  
  =item $JSON::SkipInvalid
  
    $json->allow_unknown
  
  =item $JSON::AUTOCONVERT
  
  Needless. C<JSON> backend modules have the round-trip integrity.
  
  =item $JSON::UTF8
  
  Needless because C<JSON> (JSON::XS/JSON::PP) sets
  the UTF8 flag on properly.
  
      # With UTF8-flagged strings
  
      $json->allow_nonref;
      $str = chr(1000); # UTF8-flagged
  
      $json_text  = $json->utf8(0)->encode($str);
      utf8::is_utf8($json_text);
      # true
      $json_text  = $json->utf8(1)->encode($str);
      utf8::is_utf8($json_text);
      # false
  
      $str = '"' . chr(1000) . '"'; # UTF8-flagged
  
      $perl_scalar  = $json->utf8(0)->decode($str);
      utf8::is_utf8($perl_scalar);
      # true
      $perl_scalar  = $json->utf8(1)->decode($str);
      # died because of 'Wide character in subroutine'
  
  See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
  
  =item $JSON::UnMapping
  
  Disable. See to L<MAPPING>.
  
  =item $JSON::SelfConvert
  
  This option was deleted.
  Instead of it, if a givien blessed object has the C<TO_JSON> method,
  C<TO_JSON> will be executed with C<convert_blessed>.
  
    $json->convert_blessed->encode($bleesed_hashref_or_arrayref)
    # if need, call allow_blessed
  
  Note that it was C<toJson> in old version, but now not C<toJson> but C<TO_JSON>.
  
  =back
  
  =head1 TODO
  
  =over
  
  =item example programs
  
  =back
  
  =head1 THREADS
  
  No test with JSON::PP. If with JSON::XS, See to L<JSON::XS/THREADS>.
  
  
  =head1 BUGS
  
  Please report bugs relevant to C<JSON> to E<lt>makamaka[at]cpan.orgE<gt>.
  
  
  =head1 SEE ALSO
  
  Most of the document is copied and modified from JSON::XS doc.
  
  L<JSON::XS>, L<JSON::PP>
  
  C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  JSON::XS was written by  Marc Lehmann <schmorp[at]schmorp.de>
  
  The relese of this new version owes to the courtesy of Marc Lehmann.
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2005-2010 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
JSON

$fatpacked{"JSON/PP.pm"} = <<'JSON_PP';
  package JSON::PP;
  
  # JSON-2.0
  
  use 5.005;
  use strict;
  use base qw(Exporter);
  use overload ();
  
  use Carp ();
  use B ();
  #use Devel::Peek;
  
  $JSON::PP::VERSION = '2.27008';
  
  @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
  
  # instead of hash-access, i tried index-access for speed.
  # but this method is not faster than what i expected. so it will be changed.
  
  use constant P_ASCII                => 0;
  use constant P_LATIN1               => 1;
  use constant P_UTF8                 => 2;
  use constant P_INDENT               => 3;
  use constant P_CANONICAL            => 4;
  use constant P_SPACE_BEFORE         => 5;
  use constant P_SPACE_AFTER          => 6;
  use constant P_ALLOW_NONREF         => 7;
  use constant P_SHRINK               => 8;
  use constant P_ALLOW_BLESSED        => 9;
  use constant P_CONVERT_BLESSED      => 10;
  use constant P_RELAXED              => 11;
  
  use constant P_LOOSE                => 12;
  use constant P_ALLOW_BIGNUM         => 13;
  use constant P_ALLOW_BAREKEY        => 14;
  use constant P_ALLOW_SINGLEQUOTE    => 15;
  use constant P_ESCAPE_SLASH         => 16;
  use constant P_AS_NONBLESSED        => 17;
  
  use constant P_ALLOW_UNKNOWN        => 18;
  
  use constant OLD_PERL => $] < 5.008 ? 1 : 0;
  
  BEGIN {
      my @xs_compati_bit_properties = qw(
              latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
              allow_blessed convert_blessed relaxed allow_unknown
      );
      my @pp_bit_properties = qw(
              allow_singlequote allow_bignum loose
              allow_barekey escape_slash as_nonblessed
      );
  
      # Perl version check, Unicode handling is enable?
      # Helper module sets @JSON::PP::_properties.
  
      my $helper = $] >= 5.008 ? 'JSON::PP58'
                 : $] >= 5.006 ? 'JSON::PP56'
                 :               'JSON::PP5005'
                 ;
  
      eval qq| require $helper |;
      if ($@) { Carp::croak $@; }
  
      for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
          my $flag_name = 'P_' . uc($name);
  
          eval qq/
              sub $name {
                  my \$enable = defined \$_[1] ? \$_[1] : 1;
  
                  if (\$enable) {
                      \$_[0]->{PROPS}->[$flag_name] = 1;
                  }
                  else {
                      \$_[0]->{PROPS}->[$flag_name] = 0;
                  }
  
                  \$_[0];
              }
  
              sub get_$name {
                  \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
              }
          /;
      }
  
  }
  
  
  
  # Functions
  
  my %encode_allow_method
       = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
                            allow_blessed convert_blessed indent indent_length allow_bignum
                            as_nonblessed
                          /;
  my %decode_allow_method
       = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
                            allow_barekey max_size relaxed/;
  
  
  my $JSON; # cache
  
  sub encode_json ($) { # encode
      ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
  }
  
  
  sub decode_json { # decode
      ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
  }
  
  # Obsoleted
  
  sub to_json($) {
     Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
  }
  
  
  sub from_json($) {
     Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
  }
  
  
  # Methods
  
  sub new {
      my $class = shift;
      my $self  = {
          max_depth   => 512,
          max_size    => 0,
          indent      => 0,
          FLAGS       => 0,
          fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
          indent_length => 3,
      };
  
      bless $self, $class;
  }
  
  
  sub encode {
      return $_[0]->PP_encode_json($_[1]);
  }
  
  
  sub decode {
      return $_[0]->PP_decode_json($_[1], 0x00000000);
  }
  
  
  sub decode_prefix {
      return $_[0]->PP_decode_json($_[1], 0x00000001);
  }
  
  
  # accessor
  
  
  # pretty printing
  
  sub pretty {
      my ($self, $v) = @_;
      my $enable = defined $v ? $v : 1;
  
      if ($enable) { # indent_length(3) for JSON::XS compatibility
          $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
      }
      else {
          $self->indent(0)->space_before(0)->space_after(0);
      }
  
      $self;
  }
  
  # etc
  
  sub max_depth {
      my $max  = defined $_[1] ? $_[1] : 0x80000000;
      $_[0]->{max_depth} = $max;
      $_[0];
  }
  
  
  sub get_max_depth { $_[0]->{max_depth}; }
  
  
  sub max_size {
      my $max  = defined $_[1] ? $_[1] : 0;
      $_[0]->{max_size} = $max;
      $_[0];
  }
  
  
  sub get_max_size { $_[0]->{max_size}; }
  
  
  sub filter_json_object {
      $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
      $_[0];
  }
  
  sub filter_json_single_key_object {
      if (@_ > 1) {
          $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
      }
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
      $_[0];
  }
  
  sub indent_length {
      if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
          Carp::carp "The acceptable range of indent_length() is 0 to 15.";
      }
      else {
          $_[0]->{indent_length} = $_[1];
      }
      $_[0];
  }
  
  sub get_indent_length {
      $_[0]->{indent_length};
  }
  
  sub sort_by {
      $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
      $_[0];
  }
  
  sub allow_bigint {
      Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
  }
  
  ###############################
  
  ###
  ### Perl => JSON
  ###
  
  
  { # Convert
  
      my $max_depth;
      my $indent;
      my $ascii;
      my $latin1;
      my $utf8;
      my $space_before;
      my $space_after;
      my $canonical;
      my $allow_blessed;
      my $convert_blessed;
  
      my $indent_length;
      my $escape_slash;
      my $bignum;
      my $as_nonblessed;
  
      my $depth;
      my $indent_count;
      my $keysort;
  
  
      sub PP_encode_json {
          my $self = shift;
          my $obj  = shift;
  
          $indent_count = 0;
          $depth        = 0;
  
          my $idx = $self->{PROPS};
  
          ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
              $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
           = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
                      P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
  
          ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
  
          $keysort = $canonical ? sub { $a cmp $b } : undef;
  
          if ($self->{sort_by}) {
              $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                       : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                       : sub { $a cmp $b };
          }
  
          encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
               if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
  
          my $str  = $self->object_to_json($obj);
  
          $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
  
          unless ($ascii or $latin1 or $utf8) {
              utf8::upgrade($str);
          }
  
          if ($idx->[ P_SHRINK ]) {
              utf8::downgrade($str, 1);
          }
  
          return $str;
      }
  
  
      sub object_to_json {
          my ($self, $obj) = @_;
          my $type = ref($obj);
  
          if($type eq 'HASH'){
              return $self->hash_to_json($obj);
          }
          elsif($type eq 'ARRAY'){
              return $self->array_to_json($obj);
          }
          elsif ($type) { # blessed object?
              if (blessed($obj)) {
  
                  return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
  
                  if ( $convert_blessed and $obj->can('TO_JSON') ) {
                      my $result = $obj->TO_JSON();
                      if ( defined $result and overload::Overloaded( $obj ) ) {
                          if ( overload::StrVal( $obj ) eq $result ) {
                              encode_error( sprintf(
                                  "%s::TO_JSON method returned same object as was passed instead of a new one",
                                  ref $obj
                              ) );
                          }
                      }
  
                      return $self->object_to_json( $result );
                  }
  
                  return "$obj" if ( $bignum and _is_bignum($obj) );
                  return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
  
                  encode_error( sprintf("encountered object '%s', but neither allow_blessed "
                      . "nor convert_blessed settings are enabled", $obj)
                  ) unless ($allow_blessed);
  
                  return 'null';
              }
              else {
                  return $self->value_to_json($obj);
              }
          }
          else{
              return $self->value_to_json($obj);
          }
      }
  
  
      sub hash_to_json {
          my ($self, $obj) = @_;
          my @res;
  
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                           if (++$depth > $max_depth);
  
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
          my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
  
          for my $k ( _sort( $obj ) ) {
              if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
              push @res, string_to_json( $self, $k )
                            .  $del
                            . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
      }
  
  
      sub array_to_json {
          my ($self, $obj) = @_;
          my @res;
  
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                           if (++$depth > $max_depth);
  
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
  
          for my $v (@$obj){
              push @res, $self->object_to_json($v) || $self->value_to_json($v);
          }
  
          --$depth;
          $self->_down_indent() if ($indent);
  
          return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
      }
  
  
      sub value_to_json {
          my ($self, $value) = @_;
  
          return 'null' if(!defined $value);
  
          my $b_obj = B::svref_2object(\$value);  # for round trip problem
          my $flags = $b_obj->FLAGS;
  
          return $value # as is 
              if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
  
          my $type = ref($value);
  
          if(!$type){
              return string_to_json($self, $value);
          }
          elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
              return $$value == 1 ? 'true' : 'false';
          }
          elsif ($type) {
              if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
                  return $self->value_to_json("$value");
              }
  
              if ($type eq 'SCALAR' and defined $$value) {
                  return   $$value eq '1' ? 'true'
                         : $$value eq '0' ? 'false'
                         : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
                         : encode_error("cannot encode reference to scalar");
              }
  
               if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
                   return 'null';
               }
               else {
                   if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                      encode_error("cannot encode reference to scalar");
                   }
                   else {
                      encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                   }
               }
  
          }
          else {
              return $self->{fallback}->($value)
                   if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
              return 'null';
          }
  
      }
  
  
      my %esc = (
          "\n" => '\n',
          "\r" => '\r',
          "\t" => '\t',
          "\f" => '\f',
          "\b" => '\b',
          "\"" => '\"',
          "\\" => '\\\\',
          "\'" => '\\\'',
      );
  
  
      sub string_to_json {
          my ($self, $arg) = @_;
  
          $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
          $arg =~ s/\//\\\//g if ($escape_slash);
          $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
  
          if ($ascii) {
              $arg = JSON_PP_encode_ascii($arg);
          }
  
          if ($latin1) {
              $arg = JSON_PP_encode_latin1($arg);
          }
  
          if ($utf8) {
              utf8::encode($arg);
          }
  
          return '"' . $arg . '"';
      }
  
  
      sub blessed_to_json {
          my $reftype = reftype($_[1]) || '';
          if ($reftype eq 'HASH') {
              return $_[0]->hash_to_json($_[1]);
          }
          elsif ($reftype eq 'ARRAY') {
              return $_[0]->array_to_json($_[1]);
          }
          else {
              return 'null';
          }
      }
  
  
      sub encode_error {
          my $error  = shift;
          Carp::croak "$error";
      }
  
  
      sub _sort {
          defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
      }
  
  
      sub _up_indent {
          my $self  = shift;
          my $space = ' ' x $indent_length;
  
          my ($pre,$post) = ('','');
  
          $post = "\n" . $space x $indent_count;
  
          $indent_count++;
  
          $pre = "\n" . $space x $indent_count;
  
          return ($pre,$post);
      }
  
  
      sub _down_indent { $indent_count--; }
  
  
      sub PP_encode_box {
          {
              depth        => $depth,
              indent_count => $indent_count,
          };
      }
  
  } # Convert
  
  
  sub _encode_ascii {
      join('',
          map {
              $_ <= 127 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_latin1 {
      join('',
          map {
              $_ <= 255 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
          } unpack('U*', $_[0])
      );
  }
  
  
  sub _encode_surrogates { # from perlunicode
      my $uni = $_[0] - 0x10000;
      return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
  }
  
  
  sub _is_bignum {
      $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
  }
  
  
  
  #
  # JSON => Perl
  #
  
  my $max_intsize;
  
  BEGIN {
      my $checkint = 1111;
      for my $d (5..64) {
          $checkint .= 1;
          my $int   = eval qq| $checkint |;
          if ($int =~ /[eE]/) {
              $max_intsize = $d - 1;
              last;
          }
      }
  }
  
  { # PARSE 
  
      my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
          b    => "\x8",
          t    => "\x9",
          n    => "\xA",
          f    => "\xC",
          r    => "\xD",
          '\\' => '\\',
          '"'  => '"',
          '/'  => '/',
      );
  
      my $text; # json data
      my $at;   # offset
      my $ch;   # 1chracter
      my $len;  # text length (changed according to UTF8 or NON UTF8)
      # INTERNAL
      my $depth;          # nest counter
      my $encoding;       # json text encoding
      my $is_valid_utf8;  # temp variable
      my $utf8_len;       # utf8 byte length
      # FLAGS
      my $utf8;           # must be utf8
      my $max_depth;      # max nest nubmer of objects and arrays
      my $max_size;
      my $relaxed;
      my $cb_object;
      my $cb_sk_object;
  
      my $F_HOOK;
  
      my $allow_bigint;   # using Math::BigInt
      my $singlequote;    # loosely quoting
      my $loose;          # 
      my $allow_barekey;  # bareKey
  
      # $opt flag
      # 0x00000001 .... decode_prefix
      # 0x10000000 .... incr_parse
  
      sub PP_decode_json {
          my ($self, $opt); # $opt is an effective flag during this decode_json.
  
          ($self, $text, $opt) = @_;
  
          ($at, $ch, $depth) = (0, '', 0);
  
          if ( !defined $text or ref $text ) {
              decode_error("malformed JSON string, neither array, object, number, string or atom");
          }
  
          my $idx = $self->{PROPS};
  
          ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
              = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
  
          if ( $utf8 ) {
              utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
          }
          else {
              utf8::upgrade( $text );
          }
  
          $len = length $text;
  
          ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
               = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
  
          if ($max_size > 1) {
              use bytes;
              my $bytes = length $text;
              decode_error(
                  sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
                      , $bytes, $max_size), 1
              ) if ($bytes > $max_size);
          }
  
          # Currently no effect
          # should use regexp
          my @octets = unpack('C4', $text);
          $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
                      : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
                      : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
                      : ( $octets[2]                ) ? 'UTF-16LE'
                      : (!$octets[2]                ) ? 'UTF-32LE'
                      : 'unknown';
  
          white(); # remove head white space
  
          my $valid_start = defined $ch; # Is there a first character for JSON structure?
  
          my $result = value();
  
          return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
  
          decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
  
          if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
                  decode_error(
                  'JSON text must be an object or array (but found number, string, true, false or null,'
                         . ' use allow_nonref to allow this)', 1);
          }
  
          Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
  
          my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
  
          white(); # remove tail white space
  
          if ( $ch ) {
              return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
              decode_error("garbage after JSON object");
          }
  
          ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
      }
  
  
      sub next_chr {
          return $ch = undef if($at >= $len);
          $ch = substr($text, $at++, 1);
      }
  
  
      sub value {
          white();
          return          if(!defined $ch);
          return object() if($ch eq '{');
          return array()  if($ch eq '[');
          return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
          return number() if($ch =~ /[0-9]/ or $ch eq '-');
          return word();
      }
  
      sub string {
          my ($i, $s, $t, $u);
          my $utf16;
          my $is_utf8;
  
          ($is_valid_utf8, $utf8_len) = ('', 0);
  
          $s = ''; # basically UTF8 flag on
  
          if($ch eq '"' or ($singlequote and $ch eq "'")){
              my $boundChar = $ch;
  
              OUTER: while( defined(next_chr()) ){
  
                  if($ch eq $boundChar){
                      next_chr();
  
                      if ($utf16) {
                          decode_error("missing low surrogate character in surrogate pair");
                      }
  
                      utf8::decode($s) if($is_utf8);
  
                      return $s;
                  }
                  elsif($ch eq '\\'){
                      next_chr();
                      if(exists $escapes{$ch}){
                          $s .= $escapes{$ch};
                      }
                      elsif($ch eq 'u'){ # UNICODE handling
                          my $u = '';
  
                          for(1..4){
                              $ch = next_chr();
                              last OUTER if($ch !~ /[0-9a-fA-F]/);
                              $u .= $ch;
                          }
  
                          # U+D800 - U+DBFF
                          if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
                              $utf16 = $u;
                          }
                          # U+DC00 - U+DFFF
                          elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
                              unless (defined $utf16) {
                                  decode_error("missing high surrogate character in surrogate pair");
                              }
                              $is_utf8 = 1;
                              $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
                              $utf16 = undef;
                          }
                          else {
                              if (defined $utf16) {
                                  decode_error("surrogate pair expected");
                              }
  
                              if ( ( my $hex = hex( $u ) ) > 127 ) {
                                  $is_utf8 = 1;
                                  $s .= JSON_PP_decode_unicode($u) || next;
                              }
                              else {
                                  $s .= chr $hex;
                              }
                          }
  
                      }
                      else{
                          unless ($loose) {
                              $at -= 2;
                              decode_error('illegal backslash escape sequence in string');
                          }
                          $s .= $ch;
                      }
                  }
                  else{
  
                      if ( ord $ch  > 127 ) {
                          if ( $utf8 ) {
                              unless( $ch = is_valid_utf8($ch) ) {
                                  $at -= 1;
                                  decode_error("malformed UTF-8 character in JSON string");
                              }
                              else {
                                  $at += $utf8_len - 1;
                              }
                          }
                          else {
                              utf8::encode( $ch );
                          }
  
                          $is_utf8 = 1;
                      }
  
                      if (!$loose) {
                          if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
                              $at--;
                              decode_error('invalid character encountered while parsing JSON string');
                          }
                      }
  
                      $s .= $ch;
                  }
              }
          }
  
          decode_error("unexpected end of string while parsing JSON string");
      }
  
  
      sub white {
          while( defined $ch  ){
              if($ch le ' '){
                  next_chr();
              }
              elsif($ch eq '/'){
                  next_chr();
                  if(defined $ch and $ch eq '/'){
                      1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
                  }
                  elsif(defined $ch and $ch eq '*'){
                      next_chr();
                      while(1){
                          if(defined $ch){
                              if($ch eq '*'){
                                  if(defined(next_chr()) and $ch eq '/'){
                                      next_chr();
                                      last;
                                  }
                              }
                              else{
                                  next_chr();
                              }
                          }
                          else{
                              decode_error("Unterminated comment");
                          }
                      }
                      next;
                  }
                  else{
                      $at--;
                      decode_error("malformed JSON string, neither array, object, number, string or atom");
                  }
              }
              else{
                  if ($relaxed and $ch eq '#') { # correctly?
                      pos($text) = $at;
                      $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                      $at = pos($text);
                      next_chr;
                      next;
                  }
  
                  last;
              }
          }
      }
  
  
      sub array {
          my $a  = [];
  
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                      if (++$depth > $max_depth);
  
          next_chr();
          white();
  
          if(defined $ch and $ch eq ']'){
              --$depth;
              next_chr();
              return $a;
          }
          else {
              while(defined($ch)){
                  push @$a, value();
  
                  white();
  
                  if (!defined $ch) {
                      last;
                  }
  
                  if($ch eq ']'){
                      --$depth;
                      next_chr();
                      return $a;
                  }
  
                  if($ch ne ','){
                      last;
                  }
  
                  next_chr();
                  white();
  
                  if ($relaxed and $ch eq ']') {
                      --$depth;
                      next_chr();
                      return $a;
                  }
  
              }
          }
  
          decode_error(", or ] expected while parsing array");
      }
  
  
      sub object {
          my $o = {};
          my $k;
  
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                  if (++$depth > $max_depth);
          next_chr();
          white();
  
          if(defined $ch and $ch eq '}'){
              --$depth;
              next_chr();
              if ($F_HOOK) {
                  return _json_object_hook($o);
              }
              return $o;
          }
          else {
              while (defined $ch) {
                  $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
                  white();
  
                  if(!defined $ch or $ch ne ':'){
                      $at--;
                      decode_error("':' expected");
                  }
  
                  next_chr();
                  $o->{$k} = value();
                  white();
  
                  last if (!defined $ch);
  
                  if($ch eq '}'){
                      --$depth;
                      next_chr();
                      if ($F_HOOK) {
                          return _json_object_hook($o);
                      }
                      return $o;
                  }
  
                  if($ch ne ','){
                      last;
                  }
  
                  next_chr();
                  white();
  
                  if ($relaxed and $ch eq '}') {
                      --$depth;
                      next_chr();
                      if ($F_HOOK) {
                          return _json_object_hook($o);
                      }
                      return $o;
                  }
  
              }
  
          }
  
          $at--;
          decode_error(", or } expected while parsing object/hash");
      }
  
  
      sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
          my $key;
          while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
              $key .= $ch;
              next_chr();
          }
          return $key;
      }
  
  
      sub word {
          my $word =  substr($text,$at-1,4);
  
          if($word eq 'true'){
              $at += 3;
              next_chr;
              return $JSON::PP::true;
          }
          elsif($word eq 'null'){
              $at += 3;
              next_chr;
              return undef;
          }
          elsif($word eq 'fals'){
              $at += 3;
              if(substr($text,$at,1) eq 'e'){
                  $at++;
                  next_chr;
                  return $JSON::PP::false;
              }
          }
  
          $at--; # for decode_error report
  
          decode_error("'null' expected")  if ($word =~ /^n/);
          decode_error("'true' expected")  if ($word =~ /^t/);
          decode_error("'false' expected") if ($word =~ /^f/);
          decode_error("malformed JSON string, neither array, object, number, string or atom");
      }
  
  
      sub number {
          my $n    = '';
          my $v;
  
          # According to RFC4627, hex or oct digts are invalid.
          if($ch eq '0'){
              my $peek = substr($text,$at,1);
              my $hex  = $peek =~ /[xX]/; # 0 or 1
  
              if($hex){
                  decode_error("malformed number (leading zero must not be followed by another digit)");
                  ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
              }
              else{ # oct
                  ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
                  if (defined $n and length $n > 1) {
                      decode_error("malformed number (leading zero must not be followed by another digit)");
                  }
              }
  
              if(defined $n and length($n)){
                  if (!$hex and length($n) == 1) {
                     decode_error("malformed number (leading zero must not be followed by another digit)");
                  }
                  $at += length($n) + $hex;
                  next_chr;
                  return $hex ? hex($n) : oct($n);
              }
          }
  
          if($ch eq '-'){
              $n = '-';
              next_chr;
              if (!defined $ch or $ch !~ /\d/) {
                  decode_error("malformed number (no digits after initial minus)");
              }
          }
  
          while(defined $ch and $ch =~ /\d/){
              $n .= $ch;
              next_chr;
          }
  
          if(defined $ch and $ch eq '.'){
              $n .= '.';
  
              next_chr;
              if (!defined $ch or $ch !~ /\d/) {
                  decode_error("malformed number (no digits after decimal point)");
              }
              else {
                  $n .= $ch;
              }
  
              while(defined(next_chr) and $ch =~ /\d/){
                  $n .= $ch;
              }
          }
  
          if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
              $n .= $ch;
              next_chr;
  
              if(defined($ch) and ($ch eq '+' or $ch eq '-')){
                  $n .= $ch;
                  next_chr;
                  if (!defined $ch or $ch =~ /\D/) {
                      decode_error("malformed number (no digits after exp sign)");
                  }
                  $n .= $ch;
              }
              elsif(defined($ch) and $ch =~ /\d/){
                  $n .= $ch;
              }
              else {
                  decode_error("malformed number (no digits after exp sign)");
              }
  
              while(defined(next_chr) and $ch =~ /\d/){
                  $n .= $ch;
              }
  
          }
  
          $v .= $n;
  
          if ($v !~ /[.eE]/ and length $v > $max_intsize) {
              if ($allow_bigint) { # from Adam Sussman
                  require Math::BigInt;
                  return Math::BigInt->new($v);
              }
              else {
                  return "$v";
              }
          }
          elsif ($allow_bigint) {
              require Math::BigFloat;
              return Math::BigFloat->new($v);
          }
  
          return 0+$v;
      }
  
  
      sub is_valid_utf8 {
  
          $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
                    : $_[0] =~ /[\xC2-\xDF]/  ? 2
                    : $_[0] =~ /[\xE0-\xEF]/  ? 3
                    : $_[0] =~ /[\xF0-\xF4]/  ? 4
                    : 0
                    ;
  
          return unless $utf8_len;
  
          my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
  
          return ( $is_valid_utf8 =~ /^(?:
               [\x00-\x7F]
              |[\xC2-\xDF][\x80-\xBF]
              |[\xE0][\xA0-\xBF][\x80-\xBF]
              |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
              |[\xED][\x80-\x9F][\x80-\xBF]
              |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
              |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
          )$/x )  ? $is_valid_utf8 : '';
      }
  
  
      sub decode_error {
          my $error  = shift;
          my $no_rep = shift;
          my $str    = defined $text ? substr($text, $at) : '';
          my $mess   = '';
          my $type   = $] >= 5.008           ? 'U*'
                     : $] <  5.006           ? 'C*'
                     : utf8::is_utf8( $str ) ? 'U*' # 5.6
                     : 'C*'
                     ;
  
          for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
              $mess .=  $c == 0x07 ? '\a'
                      : $c == 0x09 ? '\t'
                      : $c == 0x0a ? '\n'
                      : $c == 0x0d ? '\r'
                      : $c == 0x0c ? '\f'
                      : $c <  0x20 ? sprintf('\x{%x}', $c)
                      : $c == 0x5c ? '\\\\'
                      : $c <  0x80 ? chr($c)
                      : sprintf('\x{%x}', $c)
                      ;
              if ( length $mess >= 20 ) {
                  $mess .= '...';
                  last;
              }
          }
  
          unless ( length $mess ) {
              $mess = '(end of string)';
          }
  
          Carp::croak (
              $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
          );
  
      }
  
  
      sub _json_object_hook {
          my $o    = $_[0];
          my @ks = keys %{$o};
  
          if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
              my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
              if (@val == 1) {
                  return $val[0];
              }
          }
  
          my @val = $cb_object->($o) if ($cb_object);
          if (@val == 0 or @val > 1) {
              return $o;
          }
          else {
              return $val[0];
          }
      }
  
  
      sub PP_decode_box {
          {
              text    => $text,
              at      => $at,
              ch      => $ch,
              len     => $len,
              depth   => $depth,
              encoding      => $encoding,
              is_valid_utf8 => $is_valid_utf8,
          };
      }
  
  } # PARSE
  
  
  sub _decode_surrogates { # from perlunicode
      my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
      my $un  = pack('U*', $uni);
      utf8::encode( $un );
      return $un;
  }
  
  
  sub _decode_unicode {
      my $un = pack('U', hex shift);
      utf8::encode( $un );
      return $un;
  }
  
  
  
  
  
  ###############################
  # Utilities
  #
  
  BEGIN {
      eval 'require Scalar::Util';
      unless($@){
          *JSON::PP::blessed = \&Scalar::Util::blessed;
          *JSON::PP::reftype = \&Scalar::Util::reftype;
      }
      else{ # This code is from Sclar::Util.
          # warn $@;
          eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
          *JSON::PP::blessed = sub {
              local($@, $SIG{__DIE__}, $SIG{__WARN__});
              ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
          };
          my %tmap = qw(
              B::NULL   SCALAR
              B::HV     HASH
              B::AV     ARRAY
              B::CV     CODE
              B::IO     IO
              B::GV     GLOB
              B::REGEXP REGEXP
          );
          *JSON::PP::reftype = sub {
              my $r = shift;
  
              return undef unless length(ref($r));
  
              my $t = ref(B::svref_2object($r));
  
              return
                  exists $tmap{$t} ? $tmap{$t}
                : length(ref($$r)) ? 'REF'
                :                    'SCALAR';
          };
      }
  }
  
  
  # shamely copied and modified from JSON::XS code.
  
  $JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
  $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
  
  sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
  
  sub true  { $JSON::PP::true  }
  sub false { $JSON::PP::false }
  sub null  { undef; }
  
  ###############################
  
  package JSON::PP::Boolean;
  
  
  use overload (
     "0+"     => sub { ${$_[0]} },
     "++"     => sub { $_[0] = ${$_[0]} + 1 },
     "--"     => sub { $_[0] = ${$_[0]} - 1 },
     fallback => 1,
  );
  
  
  ###############################
  
  package JSON::PP::IncrParser;
  
  use strict;
  
  use constant INCR_M_WS   => 0; # initial whitespace skipping
  use constant INCR_M_STR  => 1; # inside string
  use constant INCR_M_BS   => 2; # inside backslash
  use constant INCR_M_JSON => 3; # outside anything, count nesting
  use constant INCR_M_C0   => 4;
  use constant INCR_M_C1   => 5;
  
  $JSON::PP::IncrParser::VERSION = '1.01';
  
  my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
  
  sub new {
      my ( $class ) = @_;
  
      bless {
          incr_nest    => 0,
          incr_text    => undef,
          incr_parsing => 0,
          incr_p       => 0,
      }, $class;
  }
  
  
  sub incr_parse {
      my ( $self, $coder, $text ) = @_;
  
      $self->{incr_text} = '' unless ( defined $self->{incr_text} );
  
      if ( defined $text ) {
          if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
              utf8::upgrade( $self->{incr_text} ) ;
              utf8::decode( $self->{incr_text} ) ;
          }
          $self->{incr_text} .= $text;
      }
  
  
      my $max_size = $coder->get_max_size;
  
      if ( defined wantarray ) {
  
          $self->{incr_mode} = INCR_M_WS;
  
          if ( wantarray ) {
              my @ret;
  
              $self->{incr_parsing} = 1;
  
              do {
                  push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
  
                  unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
                      $self->{incr_mode} = INCR_M_WS;
                  }
  
              } until ( !$self->{incr_text} );
  
              $self->{incr_parsing} = 0;
  
              return @ret;
          }
          else { # in scalar context
              $self->{incr_parsing} = 1;
              my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
              $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
              return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
          }
  
      }
  
  }
  
  
  sub _incr_parse {
      my ( $self, $coder, $text, $skip ) = @_;
      my $p = $self->{incr_p};
      my $restore = $p;
  
      my @obj;
      my $len = length $text;
  
      if ( $self->{incr_mode} == INCR_M_WS ) {
          while ( $len > $p ) {
              my $s = substr( $text, $p, 1 );
              $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
              $self->{incr_mode} = INCR_M_JSON;
              last;
         }
      }
  
      while ( $len > $p ) {
          my $s = substr( $text, $p++, 1 );
  
          if ( $s eq '"' ) {
              if ( $self->{incr_mode} != INCR_M_STR  ) {
                  $self->{incr_mode} = INCR_M_STR;
              }
              else {
                  $self->{incr_mode} = INCR_M_JSON;
                  unless ( $self->{incr_nest} ) {
                      last;
                  }
              }
          }
  
          if ( $self->{incr_mode} == INCR_M_JSON ) {
  
              if ( $s eq '[' or $s eq '{' ) {
                  if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                      Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                  }
              }
              elsif ( $s eq ']' or $s eq '}' ) {
                  last if ( --$self->{incr_nest} <= 0 );
              }
              elsif ( $s eq '#' ) {
                  while ( $len > $p ) {
                      last if substr( $text, $p++, 1 ) eq "\n";
                  }
              }
  
          }
  
      }
  
      $self->{incr_p} = $p;
  
      return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
  
      return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
  
      local $Carp::CarpLevel = 2;
  
      $self->{incr_p} = $restore;
      $self->{incr_c} = $p;
  
      my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
  
      $self->{incr_text} = substr( $self->{incr_text}, $p );
      $self->{incr_p} = 0;
  
      return $obj or '';
  }
  
  
  sub incr_text {
      if ( $_[0]->{incr_parsing} ) {
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
      }
      $_[0]->{incr_text};
  }
  
  
  sub incr_skip {
      my $self  = shift;
      $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
      $self->{incr_p} = 0;
  }
  
  
  sub incr_reset {
      my $self = shift;
      $self->{incr_text}    = undef;
      $self->{incr_p}       = 0;
      $self->{incr_mode}    = 0;
      $self->{incr_nest}    = 0;
      $self->{incr_parsing} = 0;
  }
  
  ###############################
  
  
  1;
  __END__
  =pod
  
  =head1 NAME
  
  JSON::PP - JSON::XS compatible pure-Perl module.
  
  =head1 SYNOPSIS
  
   use JSON::PP;
  
   # exported functions, they croak on error
   # and expect/generate UTF-8
  
   $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
   $perl_hash_or_arrayref  = decode_json $utf8_encoded_json_text;
  
   # OO-interface
  
   $coder = JSON::PP->new->ascii->pretty->allow_nonref;
   $pretty_printed_unencoded = $coder->encode ($perl_scalar);
   $perl_scalar = $coder->decode ($unicode_json_text);
  
   # Note that JSON version 2.0 and above will automatically use
   # JSON::XS or JSON::PP, so you should be able to just:
   
   use JSON;
  
  =head1 DESCRIPTION
  
  This module is L<JSON::XS> compatible pure Perl module.
  (Perl 5.8 or later is recommended)
  
  JSON::XS is the fastest and most proper JSON module on CPAN.
  It is written by Marc Lehmann in C, so must be compiled and
  installed in the used environment.
  
  JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
  
  
  =head2 FEATURES
  
  =over
  
  =item * correct unicode handling
  
  This module knows how to handle Unicode (depending on Perl version).
  
  See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
  
  
  =item * round-trip integrity
  
  When you serialise a perl data structure using only data types supported
  by JSON and Perl, the deserialised data structure is identical on the Perl
  level. (e.g. the string "2.0" doesn't suddenly become "2" just because
  it looks like a number). There I<are> minor exceptions to this, read the
  MAPPING section below to learn about those.
  
  
  =item * strict checking of JSON correctness
  
  There is no guessing, no generating of illegal JSON texts by default,
  and only JSON is accepted as input by default (the latter is a security feature).
  But when some options are set, loose chcking features are available.
  
  =back
  
  =head1 FUNCTIONS
  
  Basically, check to L<JSON> or L<JSON::XS>.
  
  =head2 encode_json
  
      $json_text = encode_json $perl_scalar
  
  =head2 decode_json
  
      $perl_scalar = decode_json $json_text
  
  =head2 JSON::PP::true
  
  Returns JSON true value which is blessed object.
  It C<isa> JSON::PP::Boolean object.
  
  =head2 JSON::PP::false
  
  Returns JSON false value which is blessed object.
  It C<isa> JSON::PP::Boolean object.
  
  =head2 JSON::PP::null
  
  Returns C<undef>.
  
  =head1 METHODS
  
  Basically, check to L<JSON> or L<JSON::XS>.
  
  =head2 new
  
      $json = new JSON::PP
  
  Rturns a new JSON::PP object that can be used to de/encode JSON
  strings.
  
  =head2 ascii
  
      $json = $json->ascii([$enable])
      
      $enabled = $json->get_ascii
  
  If $enable is true (or missing), then the encode method will not generate characters outside
  the code range 0..127. Any Unicode characters outside that range will be escaped using either
  a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
  (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
  
  In Perl 5.005, there is no character having high value (more than 255).
  See to L<UNICODE HANDLING ON PERLS>.
  
  If $enable is false, then the encode method will not escape Unicode characters unless
  required by the JSON syntax or other flags. This results in a faster and more compact format.
  
    JSON::PP->new->ascii(1)->encode([chr 0x10401])
    => ["\ud801\udc01"]
  
  =head2 latin1
  
      $json = $json->latin1([$enable])
      
      $enabled = $json->get_latin1
  
  If $enable is true (or missing), then the encode method will encode the resulting JSON
  text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
  
  If $enable is false, then the encode method will not escape Unicode characters
  unless required by the JSON syntax or other flags.
  
    JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  See to L<UNICODE HANDLING ON PERLS>.
  
  =head2 utf8
  
      $json = $json->utf8([$enable])
      
      $enabled = $json->get_utf8
  
  If $enable is true (or missing), then the encode method will encode the JSON result
  into UTF-8, as required by many protocols, while the decode method expects to be handled
  an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
  characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
  
  (In Perl 5.005, any character outside the range 0..255 does not exist.
  See to L<UNICODE HANDLING ON PERLS>.)
  
  In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
  encoding families, as described in RFC4627.
  
  If $enable is false, then the encode method will return the JSON string as a (non-encoded)
  Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
  (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
  
  Example, output UTF-16BE-encoded JSON:
  
    use Encode;
    $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
  
  
  =head2 pretty
  
      $json = $json->pretty([$enable])
  
  This enables (or disables) all of the C<indent>, C<space_before> and
  C<space_after> flags in one call to generate the most readable
  (or most compact) form possible.
  
  =head2 indent
  
      $json = $json->indent([$enable])
      
      $enabled = $json->get_indent
  
  The default indent space length is three.
  You can use C<indent_length> to change the length.
  
  =head2 space_before
  
      $json = $json->space_before([$enable])
      
      $enabled = $json->get_space_before
  
  =head2 space_after
  
      $json = $json->space_after([$enable])
      
      $enabled = $json->get_space_after
  
  =head2 relaxed
  
      $json = $json->relaxed([$enable])
      
      $enabled = $json->get_relaxed
  
  =head2 canonical
  
      $json = $json->canonical([$enable])
      
      $enabled = $json->get_canonical
  
  If you want your own sorting routine, you can give a code referece
  or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
  
  =head2 allow_nonref
  
      $json = $json->allow_nonref([$enable])
      
      $enabled = $json->get_allow_nonref
  
  =head2 allow_unknown
  
      $json = $json->allow_unknown ([$enable])
      
      $enabled = $json->get_allow_unknown
  
  =head2 allow_blessed
  
      $json = $json->allow_blessed([$enable])
      
      $enabled = $json->get_allow_blessed
  
  =head2 convert_blessed
  
      $json = $json->convert_blessed([$enable])
      
      $enabled = $json->get_convert_blessed
  
  =head2 filter_json_object
  
      $json = $json->filter_json_object([$coderef])
  
  =head2 filter_json_single_key_object
  
      $json = $json->filter_json_single_key_object($key [=> $coderef])
  
  =head2 shrink
  
      $json = $json->shrink([$enable])
      
      $enabled = $json->get_shrink
  
  In JSON::XS, this flag resizes strings generated by either
  C<encode> or C<decode> to their minimum size possible.
  It will also try to downgrade any strings to octet-form if possible.
  
  In JSON::PP, it is noop about resizing strings but tries
  C<utf8::downgrade> to the returned string by C<encode>.
  See to L<utf8>.
  
  See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
  
  =head2 max_depth
  
      $json = $json->max_depth([$maximum_nesting_depth])
      
      $max_depth = $json->get_max_depth
  
  Sets the maximum nesting level (default C<512>) accepted while encoding
  or decoding. If a higher nesting level is detected in JSON text or a Perl
  data structure, then the encoder and decoder will stop and croak at that
  point.
  
  Nesting level is defined by number of hash- or arrayrefs that the encoder
  needs to traverse to reach a given point or the number of C<{> or C<[>
  characters without their matching closing parenthesis crossed to reach a
  given character in a string.
  
  If no argument is given, the highest possible setting will be used, which
  is rarely useful.
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
  
  When a large value (100 or more) was set and it de/encodes a deep nested object/text,
  it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
  
  =head2 max_size
  
      $json = $json->max_size([$maximum_string_size])
      
      $max_size = $json->get_max_size
  
  Set the maximum length a JSON text may have (in bytes) where decoding is
  being attempted. The default is C<0>, meaning no limit. When C<decode>
  is called on a string that is longer then this many bytes, it will not
  attempt to decode the string but throw an exception. This setting has no
  effect on C<encode> (yet).
  
  If no argument is given, the limit check will be deactivated (same as when
  C<0> is specified).
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
  
  =head2 encode
  
      $json_text = $json->encode($perl_scalar)
  
  =head2 decode
  
      $perl_scalar = $json->decode($json_text)
  
  =head2 decode_prefix
  
      ($perl_scalar, $characters) = $json->decode_prefix($json_text)
  
  
  =head1 INCREMENTAL PARSING
  
  Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
  
  In some cases, there is the need for incremental parsing of JSON texts.
  This module does allow you to parse a JSON stream incrementally.
  It does so by accumulating text until it has a full JSON object, which
  it then can decode. This process is similar to using C<decode_prefix>
  to see if a full JSON object is available, but is much more efficient
  (and can be implemented with a minimum of method calls).
  
  This module will only attempt to parse the JSON text once it is sure it
  has enough text to get a decisive result, using a very simple but
  truly incremental parser. This means that it sometimes won't stop as
  early as the full parser, for example, it doesn't detect parenthese
  mismatches. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =head2 incr_parse
  
      $json->incr_parse( [$string] ) # void context
      
      $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
      
      @obj_or_empty = $json->incr_parse( [$string] ) # list context
  
  This is the central parsing function. It can both append new text and
  extract objects from the stream accumulated so far (both of these
  functions are optional).
  
  If C<$string> is given, then this string is appended to the already
  existing JSON fragment stored in the C<$json> object.
  
  After that, if the function is called in void context, it will simply
  return without doing anything further. This can be used to add more text
  in as many chunks as you want.
  
  If the method is called in scalar context, then it will try to extract
  exactly I<one> JSON object. If that is successful, it will return this
  object, otherwise it will return C<undef>. If there is a parse error,
  this method will croak just as C<decode> would do (one can then use
  C<incr_skip> to skip the errornous part). This is the most common way of
  using the method.
  
  And finally, in list context, it will try to extract as many objects
  from the stream as it can find and return them, or the empty list
  otherwise. For this to work, there must be no separators between the JSON
  objects or arrays, instead they must be concatenated back-to-back. If
  an error occurs, an exception will be raised as in the scalar context
  case. Note that in this case, any previously-parsed JSON texts will be
  lost.
  
  Example: Parse some JSON arrays/objects in a given string and return them.
  
      my @objs = JSON->new->incr_parse ("[5][7][1,2]");
  
  =head2 incr_text
  
      $lvalue_string = $json->incr_text
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object. Under
  all other circumstances you must not call this function (I mean it.
  although in simple tests it might actually work, it I<will> fail under
  real world conditions). As a special exception, you can also call this
  method before having parsed anything.
  
  This function is useful in two cases: a) finding the trailing text after a
  JSON object or b) parsing multiple JSON objects separated by non-JSON text
  (such as commas).
  
      $json->incr_text =~ s/\s*,\s*//;
  
  In Perl 5.005, C<lvalue> attribute is not available.
  You must write codes like the below:
  
      $string = $json->incr_text;
      $string =~ s/\s*,\s*//;
      $json->incr_text( $string );
  
  =head2 incr_skip
  
      $json->incr_skip
  
  This will reset the state of the incremental parser and will remove the
  parsed text from the input buffer. This is useful after C<incr_parse>
  died, in which case the input buffer and incremental parser state is left
  unchanged, to skip the text parsed so far and to reset the parse state.
  
  =head2 incr_reset
  
      $json->incr_reset
  
  This completely resets the incremental parser, that is, after this call,
  it will be as if the parser had never parsed anything.
  
  This is useful if you want ot repeatedly parse JSON objects and want to
  ignore any trailing data, which means you have to reset the parser after
  each successful decode.
  
  See to L<JSON::XS/INCREMENTAL PARSING> for examples.
  
  
  =head1 JSON::PP OWN METHODS
  
  =head2 allow_singlequote
  
      $json = $json->allow_singlequote([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  JSON strings quoted by single quotations that are invalid JSON
  format.
  
      $json->allow_singlequote->decode({"foo":'bar'});
      $json->allow_singlequote->decode({'foo':"bar"});
      $json->allow_singlequote->decode({'foo':'bar'});
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
  
  =head2 allow_barekey
  
      $json = $json->allow_barekey([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will accept
  bare keys of JSON object that are invalid JSON format.
  
  As same as the C<relaxed> option, this option may be used to parse
  application-specific files written by humans.
  
      $json->allow_barekey->decode('{foo:"bar"}');
  
  =head2 allow_bignum
  
      $json = $json->allow_bignum([$enable])
  
  If C<$enable> is true (or missing), then C<decode> will convert
  the big integer Perl cannot handle as integer into a L<Math::BigInt>
  object and convert a floating number (any) into a L<Math::BigFloat>.
  
  On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
  objects into JSON numbers with C<allow_blessed> enable.
  
     $json->allow_nonref->allow_blessed->allow_bignum;
     $bigfloat = $json->decode('2.000000000000000000000000001');
     print $json->encode($bigfloat);
     # => 2.000000000000000000000000001
  
  See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
  
  =head2 loose
  
      $json = $json->loose([$enable])
  
  The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
  and the module doesn't allow to C<decode> to these (except for \x2f).
  If C<$enable> is true (or missing), then C<decode>  will accept these
  unescaped strings.
  
      $json->loose->decode(qq|["abc
                                     def"]|);
  
  See L<JSON::XS/SSECURITY CONSIDERATIONS>.
  
  =head2 escape_slash
  
      $json = $json->escape_slash([$enable])
  
  According to JSON Grammar, I<slash> (U+002F) is escaped. But default
  JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
  
  If C<$enable> is true (or missing), then C<encode> will escape slashes.
  
  =head2 (OBSOLETED)as_nonblessed
  
      $json = $json->as_nonblessed
  
  (OBSOLETED) If C<$enable> is true (or missing), then C<encode> will convert
  a blessed hash reference or a blessed array reference (contains
  other blessed references) into JSON members and arrays.
  
  This feature is effective only when C<allow_blessed> is enable.
  
  =head2 indent_length
  
      $json = $json->indent_length($length)
  
  JSON::XS indent space length is 3 and cannot be changed.
  JSON::PP set the indent space length with the given $length.
  The default is 3. The acceptable range is 0 to 15.
  
  =head2 sort_by
  
      $json = $json->sort_by($function_name)
      $json = $json->sort_by($subroutine_ref)
  
  If $function_name or $subroutine_ref are set, its sort routine are used
  in encoding JSON objects.
  
     $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     $js = $pc->sort_by('own_sort')->encode($obj);
     # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
  
     sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
  
  As the sorting routine runs in the JSON::PP scope, the given
  subroutine name and the special variables C<$a>, C<$b> will begin
  'JSON::PP::'.
  
  If $integer is set, then the effect is same as C<canonical> on.
  
  =head1 INTERNAL
  
  For developers.
  
  =over
  
  =item PP_encode_box
  
  Returns
  
          {
              depth        => $depth,
              indent_count => $indent_count,
          }
  
  
  =item PP_decode_box
  
  Returns
  
          {
              text    => $text,
              at      => $at,
              ch      => $ch,
              len     => $len,
              depth   => $depth,
              encoding      => $encoding,
              is_valid_utf8 => $is_valid_utf8,
          };
  
  =back
  
  =head1 MAPPING
  
  See to L<JSON::XS/MAPPING>.
  
  
  =head1 UNICODE HANDLING ON PERLS
  
  If you do not know about Unicode on Perl well,
  please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
  
  =head2 Perl 5.8 and later
  
  Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
  
      $json->allow_nonref->encode(chr hex 3042);
      $json->allow_nonref->encode(chr hex 12345);
  
  Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
  
      $json->allow_nonref->decode('"\u3042"');
      $json->allow_nonref->decode('"\ud808\udf45"');
  
  Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
  
  Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
  so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
  
  
  =head2 Perl 5.6
  
  Perl can handle Unicode and the JSON::PP de/encode methods also work.
  
  =head2 Perl 5.005
  
  Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
  That means the unicode handling is not available.
  
  In encoding,
  
      $json->allow_nonref->encode(chr hex 3042);  # hex 3042 is 12354.
      $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
  
  Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
  as C<$value % 256>, so the above codes are equivalent to :
  
      $json->allow_nonref->encode(chr 66);
      $json->allow_nonref->encode(chr 69);
  
  In decoding,
  
      $json->decode('"\u00e3\u0081\u0082"');
  
  The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
  japanese character (C<HIRAGANA LETTER A>).
  And if it is represented in Unicode code point, C<U+3042>.
  
  Next, 
  
      $json->decode('"\u3042"');
  
  We ordinary expect the returned value is a Unicode character C<U+3042>.
  But here is 5.005 world. This is C<0xE3 0x81 0x82>.
  
      $json->decode('"\ud808\udf45"');
  
  This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
  
  
  =head1 TODO
  
  =over
  
  =item speed
  
  =item memory saving
  
  =back
  
  
  =head1 SEE ALSO
  
  Most of the document are copied and modified from JSON::XS doc.
  
  L<JSON::XS>
  
  RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2010 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
JSON_PP

$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
  =head1 NAME
  
  JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
  
  =head1 SYNOPSIS
  
   # do not "use" yourself
  
  =head1 DESCRIPTION
  
  This module exists only to provide overload resolution for Storable and similar modules. See
  L<JSON::PP> for more info about this class.
  
  =cut
  
  use JSON::PP ();
  use strict;
  
  1;
  
  =head1 AUTHOR
  
  This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
  
  =cut
  
JSON_PP_BOOLEAN

$fatpacked{"JSON/PP5005.pm"} = <<'JSON_PP5005';
  package JSON::PP5005;
  
  use 5.005;
  use strict;
  
  my @properties;
  
  $JSON::PP5005::VERSION = '1.10';
  
  BEGIN {
  
      sub utf8::is_utf8 {
          0; # It is considered that UTF8 flag off for Perl 5.005.
      }
  
      sub utf8::upgrade {
      }
  
      sub utf8::downgrade {
          1; # must always return true.
      }
  
      sub utf8::encode  {
      }
  
      sub utf8::decode {
      }
  
      *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
      *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
      *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
      *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
  
      # missing in B module.
      sub B::SVp_IOK () { 0x01000000; }
      sub B::SVp_NOK () { 0x02000000; }
      sub B::SVp_POK () { 0x04000000; }
  
      $INC{'bytes.pm'} = 1; # dummy
  }
  
  
  
  sub _encode_ascii {
      join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
  }
  
  
  sub _encode_latin1 {
      join('', map { chr($_) } unpack('C*', $_[0]) );
  }
  
  
  sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
      my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
      my $bit = unpack('B32', pack('N', $uni));
  
      if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
          my ($w, $x, $y, $z) = ($1, $2, $3, $4);
          return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
      }
      else {
          Carp::croak("Invalid surrogate pair");
      }
  }
  
  
  sub _decode_unicode {
      my ($u) = @_;
      my ($utf8bit);
  
      if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
           return pack( 'H2', $1 );
      }
  
      my $bit = unpack("B*", pack("H*", $u));
  
      if ( $bit =~ /^00000(.....)(......)$/ ) {
          $utf8bit = sprintf('110%s10%s', $1, $2);
      }
      elsif ( $bit =~ /^(....)(......)(......)$/ ) {
          $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
      }
      else {
          Carp::croak("Invalid escaped unicode");
      }
  
      return pack('B*', $utf8bit);
  }
  
  
  sub JSON::PP::incr_parse {
      local $Carp::CarpLevel = 1;
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  }
  
  
  sub JSON::PP::incr_text {
      $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
      if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
      }
  
      $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
      $_[0]->{_incr_parser}->{incr_text};
  }
  
  
  sub JSON::PP::incr_skip {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
  }
  
  
  sub JSON::PP::incr_reset {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
  }
  
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
  
  =head1 DESCRIPTION
  
  JSON::PP calls internally.
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2010 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
JSON_PP5005

$fatpacked{"JSON/PP56.pm"} = <<'JSON_PP56';
  package JSON::PP56;
  
  use 5.006;
  use strict;
  
  my @properties;
  
  $JSON::PP56::VERSION = '1.08';
  
  BEGIN {
  
      sub utf8::is_utf8 {
          my $len =  length $_[0]; # char length
          {
              use bytes; #  byte length;
              return $len != length $_[0]; # if !=, UTF8-flagged on.
          }
      }
  
  
      sub utf8::upgrade {
          ; # noop;
      }
  
  
      sub utf8::downgrade ($;$) {
          return 1 unless ( utf8::is_utf8( $_[0] ) );
  
          if ( _is_valid_utf8( $_[0] ) ) {
              my $downgrade;
              for my $c ( unpack( "U*", $_[0] ) ) {
                  if ( $c < 256 ) {
                      $downgrade .= pack("C", $c);
                  }
                  else {
                      $downgrade .= pack("U", $c);
                  }
              }
              $_[0] = $downgrade;
              return 1;
          }
          else {
              Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
              0;
          }
      }
  
  
      sub utf8::encode ($) { # UTF8 flag off
          if ( utf8::is_utf8( $_[0] ) ) {
              $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
          }
          else {
              $_[0] = pack( "U*", unpack( "C*", $_[0] ) );
              $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
          }
      }
  
  
      sub utf8::decode ($) { # UTF8 flag on
          if ( _is_valid_utf8( $_[0] ) ) {
              utf8::downgrade( $_[0] );
              $_[0] = pack( "U*", unpack( "U*", $_[0] ) );
          }
      }
  
  
      *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
      *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
      *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
      *JSON::PP::JSON_PP_decode_unicode    = \&JSON::PP::_decode_unicode;
  
      unless ( defined &B::SVp_NOK ) { # missing in B module.
          eval q{ sub B::SVp_NOK () { 0x02000000; } };
      }
  
  }
  
  
  
  sub _encode_ascii {
      join('',
          map {
              $_ <= 127 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
          } _unpack_emu($_[0])
      );
  }
  
  
  sub _encode_latin1 {
      join('',
          map {
              $_ <= 255 ?
                  chr($_) :
              $_ <= 65535 ?
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
          } _unpack_emu($_[0])
      );
  }
  
  
  sub _unpack_emu { # for Perl 5.6 unpack warnings
      return   !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) 
             : _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
             : unpack('C*', $_[0]);
  }
  
  
  sub _is_valid_utf8 {
      my $str = $_[0];
      my $is_utf8;
  
      while ($str =~ /(?:
            (
               [\x00-\x7F]
              |[\xC2-\xDF][\x80-\xBF]
              |[\xE0][\xA0-\xBF][\x80-\xBF]
              |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
              |[\xED][\x80-\x9F][\x80-\xBF]
              |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
              |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
              |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
            )
          | (.)
      )/xg)
      {
          if (defined $1) {
              $is_utf8 = 1 if (!defined $is_utf8);
          }
          else {
              $is_utf8 = 0 if (!defined $is_utf8);
              if ($is_utf8) { # eventually, not utf8
                  return;
              }
          }
      }
  
      return $is_utf8;
  }
  
  
  sub JSON::PP::incr_parse {
      local $Carp::CarpLevel = 1;
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  }
  
  
  sub JSON::PP::incr_text : lvalue {
      $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
      if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
      }
      $_[0]->{_incr_parser}->{incr_text};
  }
  
  
  sub JSON::PP::incr_skip {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
  }
  
  
  sub JSON::PP::incr_reset {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
  }
  
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  JSON::PP56 - Helper module in using JSON::PP in Perl 5.6
  
  =head1 DESCRIPTION
  
  JSON::PP calls internally.
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2009 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
JSON_PP56

$fatpacked{"JSON/PP58.pm"} = <<'JSON_PP58';
  package JSON::PP58;
  
  use 5.008;
  use strict;
  
  my @properties;
  
  $JSON::PP58::VERSION = '1.03';
  
  
  BEGIN {
  
      unless ( defined &utf8::is_utf8 ) {
         require Encode;
         *utf8::is_utf8 = *Encode::is_utf8;
      }
  
      *JSON::PP::JSON_PP_encode_ascii      = \&JSON::PP::_encode_ascii;
      *JSON::PP::JSON_PP_encode_latin1     = \&JSON::PP::_encode_latin1;
      *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
      *JSON::PP::JSON_PP_decode_unicode    = \&JSON::PP::_decode_unicode;
  
      if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
          package JSON::PP;
          require subs;
          subs->import('join');
          eval q|
              sub join {
                  return '' if (@_ < 2);
                  my $j   = shift;
                  my $str = shift;
                  for (@_) { $str .= $j . $_; }
                  return $str;
              }
          |;
      }
  
  }
  
  
  sub JSON::PP::incr_parse {
      local $Carp::CarpLevel = 1;
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  }
  
  
  sub JSON::PP::incr_text : lvalue {
      $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  
      if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
      }
      $_[0]->{_incr_parser}->{incr_text};
  }
  
  
  sub JSON::PP::incr_skip {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
  }
  
  
  sub JSON::PP::incr_reset {
      ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
  }
  
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  JSON::PP58 - Helper module in using JSON::PP in Perl 5.8 and lator
  
  =head1 DESCRIPTION
  
  JSON::PP calls internally.
  
  =head1 AUTHOR
  
  Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
  
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2008-2009 by Makamaka Hannyaharamitu
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself. 
  
  =cut
  
JSON_PP58

$fatpacked{"LWP.pm"} = <<'LWP';
  package LWP;
  
  $VERSION = "6.02";
  sub Version { $VERSION; }
  
  require 5.008;
  require LWP::UserAgent;  # this should load everything you need
  
  1;
  
  __END__
  
  =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/pub/WWW/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 *
  
  The 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 *
  
  The 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 *
  
  The B<headers> contain additional information about the
  request and can also used to describe the content.  The headers
  are a set of keyword/value pairs.
  
  =item *
  
  The 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 *
  
  The B<code> is a numerical value that indicates the overall
  outcome of the request.
  
  =item *
  
  The B<message> is a short, human readable string that
  corresponds to the I<code>.
  
  =item *
  
  The B<headers> contain additional information about the
  response and describe the content.
  
  =item *
  
  The 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 *
  
  The B<timeout> specifies how much time we give remote servers to
  respond before the library disconnects and creates an
  internal I<timeout> response.
  
  =item *
  
  The B<agent> specifies the name that your application should use when it
  presents itself on the network.
  
  =item *
  
  The B<from> attribute 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 *
  
  The B<parse_head> specifies whether we should initialize response
  headers from the E<lt>head> section of HTML documents.
  
  =item *
  
  The B<proxy> and B<no_proxy> attributes specify if and when to go through
  a proxy server. <URL:http://www.w3.org/pub/WWW/Proxies/>
  
  =item *
  
  The B<credentials> provide 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_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/gisle/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/MediaTypes.pm"} = <<'LWP_MEDIATYPES';
  package LWP::MediaTypes;
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(guess_media_type media_suffix);
  @EXPORT_OK = qw(add_type add_encoding read_media_types);
  $VERSION = "6.01";
  
  use strict;
  
  # note: These hashes will also be filled with the entries found in
  # the 'media.types' file.
  
  my %suffixType = (
      'txt'   => 'text/plain',
      'html'  => 'text/html',
      'gif'   => 'image/gif',
      'jpg'   => 'image/jpeg',
      'xml'   => 'text/xml',
  );
  
  my %suffixExt = (
      'text/plain' => 'txt',
      'text/html'  => 'html',
      'image/gif'  => 'gif',
      'image/jpeg' => 'jpg',
      'text/xml'   => 'xml',
  );
  
  #XXX: there should be some way to define this in the media.types files.
  my %suffixEncoding = (
      'Z'   => 'compress',
      'gz'  => 'gzip',
      'hqx' => 'x-hqx',
      'uu'  => 'x-uuencode',
      'z'   => 'x-pack',
      'bz2' => 'x-bzip2',
  );
  
  read_media_types();
  
  
  
  sub _dump {
      require Data::Dumper;
      Data::Dumper->new([\%suffixType, \%suffixExt, \%suffixEncoding],
  		      [qw(*suffixType *suffixExt *suffixEncoding)])->Dump;
  }
  
  
  sub guess_media_type
  {
      my($file, $header) = @_;
      return undef unless defined $file;
  
      my $fullname;
      if (ref($file)) {
  	# assume URI object
  	$file = $file->path;
  	#XXX should handle non http:, file: or ftp: URIs differently
      }
      else {
  	$fullname = $file;  # enable peek at actual file
      }
  
      my @encoding = ();
      my $ct = undef;
      for (file_exts($file)) {
  	# first check this dot part as encoding spec
  	if (exists $suffixEncoding{$_}) {
  	    unshift(@encoding, $suffixEncoding{$_});
  	    next;
  	}
  	if (exists $suffixEncoding{lc $_}) {
  	    unshift(@encoding, $suffixEncoding{lc $_});
  	    next;
  	}
  
  	# check content-type
  	if (exists $suffixType{$_}) {
  	    $ct = $suffixType{$_};
  	    last;
  	}
  	if (exists $suffixType{lc $_}) {
  	    $ct = $suffixType{lc $_};
  	    last;
  	}
  
  	# don't know nothing about this dot part, bail out
  	last;
      }
      unless (defined $ct) {
  	# Take a look at the file
  	if (defined $fullname) {
  	    $ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
  	}
  	else {
  	    $ct = "application/octet-stream";
  	}
      }
  
      if ($header) {
  	$header->header('Content-Type' => $ct);
  	$header->header('Content-Encoding' => \@encoding) if @encoding;
      }
  
      wantarray ? ($ct, @encoding) : $ct;
  }
  
  
  sub media_suffix {
      if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
  	return $suffixExt{lc $_[0]};
      }
      my(@type) = @_;
      my(@suffix, $ext, $type);
      foreach (@type) {
  	if (s/\*/.*/) {
  	    while(($ext,$type) = each(%suffixType)) {
  		push(@suffix, $ext) if $type =~ /^$_$/i;
  	    }
  	}
  	else {
  	    my $ltype = lc $_;
  	    while(($ext,$type) = each(%suffixType)) {
  		push(@suffix, $ext) if lc $type eq $ltype;
  	    }
  	}
      }
      wantarray ? @suffix : $suffix[0];
  }
  
  
  sub file_exts 
  {
      require File::Basename;
      my @parts = reverse split(/\./, File::Basename::basename($_[0]));
      pop(@parts);        # never consider first part
      @parts;
  }
  
  
  sub add_type 
  {
      my($type, @exts) = @_;
      for my $ext (@exts) {
  	$ext =~ s/^\.//;
  	$suffixType{$ext} = $type;
      }
      $suffixExt{lc $type} = $exts[0] if @exts;
  }
  
  
  sub add_encoding
  {
      my($type, @exts) = @_;
      for my $ext (@exts) {
  	$ext =~ s/^\.//;
  	$suffixEncoding{$ext} = $type;
      }
  }
  
  
  sub read_media_types 
  {
      my(@files) = @_;
  
      local($/, $_) = ("\n", undef);  # ensure correct $INPUT_RECORD_SEPARATOR
  
      my @priv_files = ();
      push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
  	if defined $ENV{HOME};  # Some doesn't have a home (for instance Win32)
  
      # Try to locate "media.types" file, and initialize %suffixType from it
      my $typefile;
      unless (@files) {
  	@files = map {"$_/LWP/media.types"} @INC;
  	push @files, @priv_files;
      }
      for $typefile (@files) {
  	local(*TYPE);
  	open(TYPE, $typefile) || next;
  	while (<TYPE>) {
  	    next if /^\s*#/; # comment line
  	    next if /^\s*$/; # blank line
  	    s/#.*//;         # remove end-of-line comments
  	    my($type, @exts) = split(' ', $_);
  	    add_type($type, @exts);
  	}
  	close(TYPE);
      }
  }
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  LWP::MediaTypes - guess media type for a file or a URL
  
  =head1 SYNOPSIS
  
   use LWP::MediaTypes qw(guess_media_type);
   $type = guess_media_type("/tmp/foo.gif");
  
  =head1 DESCRIPTION
  
  This module provides functions for handling media (also known as
  MIME) types and encodings.  The mapping from file extensions to media
  types is defined by the F<media.types> file.  If the F<~/.media.types>
  file exists it is used instead.
  For backwards compatibility we will also look for F<~/.mime.types>.
  
  The following functions are exported by default:
  
  =over 4
  
  =item guess_media_type( $filename )
  
  =item guess_media_type( $uri )
  
  =item guess_media_type( $filename_or_uri, $header_to_modify )
  
  This function tries to guess media type and encoding for a file or a URI.
  It returns the content type, which is a string like C<"text/html">.
  In array context it also returns any content encodings applied (in the
  order used to encode the file).  You can pass a URI object
  reference, instead of the file name.
  
  If the type can not be deduced from looking at the file name,
  then guess_media_type() will let the C<-T> Perl operator take a look.
  If this works (and C<-T> returns a TRUE value) then we return
  I<text/plain> as the type, otherwise we return
  I<application/octet-stream> as the type.
  
  The optional second argument should be a reference to a HTTP::Headers
  object or any object that implements the $obj->header method in a
  similar way.  When it is present the values of the
  'Content-Type' and 'Content-Encoding' will be set for this header.
  
  =item media_suffix( $type, ... )
  
  This function will return all suffixes that can be used to denote the
  specified media type(s).  Wildcard types can be used.  In a scalar
  context it will return the first suffix found. Examples:
  
    @suffixes = media_suffix('image/*', 'audio/basic');
    $suffix = media_suffix('text/html');
  
  =back
  
  The following functions are only exported by explicit request:
  
  =over 4
  
  =item add_type( $type, @exts )
  
  Associate a list of file extensions with the given media type.
  Example:
  
      add_type("x-world/x-vrml" => qw(wrl vrml));
  
  =item add_encoding( $type, @ext )
  
  Associate a list of file extensions with an encoding type.
  Example:
  
   add_encoding("x-gzip" => "gz");
  
  =item read_media_types( @files )
  
  Parse media types files and add the type mappings found there.
  Example:
  
      read_media_types("conf/mime.types");
  
  =back
  
  =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.
  
LWP_MEDIATYPES

$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);
      $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;
  	if (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 ($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);
  		    }
  		    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 sysread {
      my $self = shift;
      if (my $timeout = ${*$self}{io_socket_timeout}) {
  	die "read timeout" unless $self->can_read($timeout);
      }
      else {
  	# since we have made the socket non-blocking we
  	# use select to wait for some data to arrive
  	$self->can_read(undef) || die "Assert";
      }
      sysread($self, $_[0], $_[1], $_[2] || 0);
  }
  
  sub can_read {
      my($self, $timeout) = @_;
      my $fbits = '';
      vec($fbits, fileno($self), 1) = 1;
    SELECT:
      {
          my $before;
          $before = time if $timeout;
          my $nfound = select($fbits, undef, undef, $timeout);
          if ($nfound < 0) {
              if ($!{EINTR} || $!{EAGAIN}) {
                  # don't really think EAGAIN can happen here
                  if ($timeout) {
                      $timeout -= time - $before;
                      $timeout = 0 if $timeout < 0;
                  }
                  redo SELECT;
              }
              die "select failed: $!";
          }
          return $nfound > 0;
      }
  }
  
  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/http10.pm"} = <<'LWP_PROTOCOL_HTTP10';
  package LWP::Protocol::http10;
  
  use strict;
  
  require HTTP::Response;
  require HTTP::Status;
  require IO::Socket;
  require IO::Select;
  
  use vars qw(@ISA @EXTRA_SOCK_OPTS);
  
  require LWP::Protocol;
  @ISA = qw(LWP::Protocol);
  
  my $CRLF         = "\015\012";     # how lines should be terminated;
  				   # "\r\n" is not correct on all systems, for
  				   # instance MacPerl defines it to "\012\015"
  
  sub _new_socket
  {
      my($self, $host, $port, $timeout) = @_;
  
      local($^W) = 0;  # IO::Socket::INET can be noisy
      my $sock = IO::Socket::INET->new(PeerAddr => $host,
  				     PeerPort => $port,
  				     Proto    => 'tcp',
  				     Timeout  => $timeout,
  				     $self->_extra_sock_opts($host, $port),
  				    );
      unless ($sock) {
  	# IO::Socket::INET leaves additional error messages in $@
  	$@ =~ s/^.*?: //;
  	die "Can't connect to $host:$port ($@)";
      }
      $sock;
  }
  
  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) = @_;
  
      $h->remove_header('Connection');  # need support here to be useful
  
      # HTTP/1.1 will require us to send the 'Host' header, so we might
      # as well start now.
      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 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 = "/" unless length $fullpath;
      }
  
      # connect to remote site
      my $socket = $self->_new_socket($host, $port, $timeout);
      $self->_check_sock($request, $socket);
  
      my $sel = IO::Select->new($socket) if $timeout;
  
      my $request_line = "$method $fullpath HTTP/1.0$CRLF";
  
      my $h = $request->headers->clone;
      my $cont_ref = $request->content_ref;
      $cont_ref = $$cont_ref if ref($$cont_ref);
      my $ctype = ref($cont_ref);
  
      # If we're sending content we *have* to specify a content length
      # otherwise the server won't know a messagebody is coming.
      if ($ctype eq 'CODE') {
  	die 'No Content-Length header for request with dynamic content'
  	    unless defined($h->header('Content-Length')) ||
  		   $h->content_type =~ /^multipart\//;
  	# For HTTP/1.1 we could have used chunked transfer encoding...
      }
      else {
  	$h->header('Content-Length' => length $$cont_ref)
  	        if defined($$cont_ref) && length($$cont_ref);
      }
  
      $self->_fixup_header($h, $url, $proxy);
  
      my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
      my $n;  # used for return value from syswrite/sysread
      my $length;
      my $offset;
  
      # syswrite $buf
      $length = length($buf);
      $offset = 0;
      while ( $offset < $length ) {
  	die "write timeout" if $timeout && !$sel->can_write($timeout);
  	$n = $socket->syswrite($buf, $length-$offset, $offset );
  	die $! unless defined($n);
  	$offset += $n;
      }
  
      if ($ctype eq 'CODE') {
  	while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
  	    # syswrite $buf
  	    $length = length($buf);
  	    $offset = 0;
  	    while ( $offset < $length ) {
  		die "write timeout" if $timeout && !$sel->can_write($timeout);
  		$n = $socket->syswrite($buf, $length-$offset, $offset );
  		die $! unless defined($n);
  		$offset += $n;
  	    }
  	}
      }
      elsif (defined($$cont_ref) && length($$cont_ref)) {
  	# syswrite $$cont_ref
  	$length = length($$cont_ref);
  	$offset = 0;
  	while ( $offset < $length ) {
  	    die "write timeout" if $timeout && !$sel->can_write($timeout);
  	    $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
  	    die $! unless defined($n);
  	    $offset += $n;
  	}
      }
  
      # read response line from server
      my $response;
      $buf = '';
  
      # Inside this loop we will read the response line and all headers
      # found in the response.
      while (1) {
  	die "read timeout" if $timeout && !$sel->can_read($timeout);
  	$n = $socket->sysread($buf, $size, length($buf));
  	die $! unless defined($n);
  	die "unexpected EOF before status line seen" unless $n;
  
  	if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) {
  	    # HTTP/1.0 response or better
  	    my($ver,$code,$msg) = ($1, $2, $3);
  	    $msg =~ s/\015$//;
  	    $response = HTTP::Response->new($code, $msg);
  	    $response->protocol($ver);
  
  	    # ensure that we have read all headers.  The headers will be
  	    # terminated by two blank lines
  	    until ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
  		# must read more if we can...
  		die "read timeout" if $timeout && !$sel->can_read($timeout);
  		my $old_len = length($buf);
  		$n = $socket->sysread($buf, $size, $old_len);
  		die $! unless defined($n);
  		die "unexpected EOF before all headers seen" unless $n;
  	    }
  
  	    # now we start parsing the headers.  The strategy is to
  	    # remove one line at a time from the beginning of the header
  	    # buffer ($res).
  	    my($key, $val);
  	    while ($buf =~ s/([^\012]*)\012//) {
  		my $line = $1;
  
  		# if we need to restore as content when illegal headers
  		# are found.
  		my $save = "$line\012"; 
  
  		$line =~ s/\015$//;
  		last unless length $line;
  
  		if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
  		    $response->push_header($key, $val) if $key;
  		    ($key, $val) = ($1, $2);
  		}
  		elsif ($line =~ /^\s+(.*)/ && $key) {
  		    $val .= " $1";
  		}
  		else {
  		    $response->push_header("Client-Bad-Header-Line" => $line);
  		}
  	    }
  	    $response->push_header($key, $val) if $key;
  	    last;
  
  	}
  	elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
  	       $buf =~ /\012/ ) {
  	    # HTTP/0.9 or worse
  	    $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  	    $response->protocol('HTTP/0.9');
  	    last;
  
  	}
  	else {
  	    # need more data
  	}
      };
      $response->request($request);
      $self->_get_sock_info($response, $socket);
  
      if ($method eq "CONNECT") {
  	$response->{client_socket} = $socket;  # so it can be picked up
  	$response->content($buf);     # in case we read more than the headers
  	return $response;
      }
  
      my $usebuf = length($buf) > 0;
      $response = $self->collect($arg, $response, sub {
          if ($usebuf) {
  	    $usebuf = 0;
  	    return \$buf;
  	}
  	die "read timeout" if $timeout && !$sel->can_read($timeout);
  	my $n = $socket->sysread($buf, $size);
  	die $! unless defined($n);
  	return \$buf;
  	} );
  
      #$socket->close;
  
      $response;
  }
  
  1;
LWP_PROTOCOL_HTTP10

$fatpacked{"LWP/Protocol/https.pm"} = <<'LWP_PROTOCOL_HTTPS';
  package LWP::Protocol::https;
  
  use strict;
  our $VERSION = "6.02";
  
  require LWP::Protocol::http;
  our @ISA = qw(LWP::Protocol::http);
  
  sub socket_type
  {
      return "https";
  }
  
  sub _extra_sock_opts
  {
      my $self = shift;
      my %ssl_opts = %{$self->{ua}{ssl_opts} || {}};
      if (delete $ssl_opts{verify_hostname}) {
  	$ssl_opts{SSL_verify_mode} ||= 1;
  	$ssl_opts{SSL_verifycn_scheme} = 'www';
      }
      if ($ssl_opts{SSL_verify_mode}) {
  	unless (exists $ssl_opts{SSL_ca_file} || exists $ssl_opts{SSL_ca_path}) {
  	    eval {
  		require Mozilla::CA;
  	    };
  	    if ($@) {
  		if ($@ =! /^Can't locate Mozilla\/CA\.pm/) {
  		    $@ = <<'EOT';
  Can't verify SSL peers without knowning which Certificate Authorities to trust
  
  This problem can be fixed by either setting the PERL_LWP_SSL_CA_FILE
  envirionment variable or by installing the Mozilla::CA module.
  
  To disable verification of SSL peers set the PERL_LWP_SSL_VERIFY_HOSTNAME
  envirionment variable to 0.  If you do this you can't be sure that you
  communicate with the expected peer.
  EOT
  		}
  		die $@;
  	    }
  	    $ssl_opts{SSL_ca_file} = Mozilla::CA::SSL_ca_file();
  	}
      }
      $self->{ssl_opts} = \%ssl_opts;
      return (%ssl_opts, $self->SUPER::_extra_sock_opts);
  }
  
  sub _check_sock
  {
      my($self, $req, $sock) = @_;
      my $check = $req->header("If-SSL-Cert-Subject");
      if (defined $check) {
  	my $cert = $sock->get_peer_certificate ||
  	    die "Missing SSL certificate";
  	my $subject = $cert->subject_name;
  	die "Bad SSL certificate subject: '$subject' !~ /$check/"
  	    unless $subject =~ /$check/;
  	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
      }
  }
  
  sub _get_sock_info
  {
      my $self = shift;
      $self->SUPER::_get_sock_info(@_);
      my($res, $sock) = @_;
      $res->header("Client-SSL-Cipher" => $sock->get_cipher);
      my $cert = $sock->get_peer_certificate;
      if ($cert) {
  	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
      }
      if (!$self->{ssl_opts}{SSL_verify_mode}) {
  	$res->push_header("Client-SSL-Warning" => "Peer certificate not verified");
      }
      elsif (!$self->{ssl_opts}{SSL_verifycn_scheme}) {
  	$res->push_header("Client-SSL-Warning" => "Peer hostname match with certificate not verified");
      }
      $res->header("Client-SSL-Socket-Class" => $Net::HTTPS::SSL_SOCKET_CLASS);
  }
  
  #-----------------------------------------------------------
  package LWP::Protocol::https::Socket;
  
  require Net::HTTPS;
  our @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods);
  
  1;
  
  __END__
  
  =head1 NAME
  
  LWP::Protocol::https - Provide https support for LWP::UserAgent
  
  =head1 SYNOPSIS
  
    use LWP::UserAgent;
  
    $ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 1 });
    $res = $ua->get("https://www.example.com");
  
  =head1 DESCRIPTION
  
  The LWP::Protocol::https module provide support for using https schemed
  URLs with LWP.  This module is a plug-in to the LWP protocol handling, so
  you don't use it directly.  Once the module is installed LWP is able
  to access sites using HTTP over SSL/TLS.
  
  If hostname verification is requested by LWP::UserAgent's C<ssl_opts>, and
  neither C<SSL_ca_file> nor C<SSL_ca_path> is set, then C<SSL_ca_file> is
  implied to be the one provided by Mozilla::CA.  If the Mozilla::CA module
  isn't available SSL requests will fail.  Either install this module, set up an
  alternative C<SSL_ca_file> or disable hostname verification.
  
  This module used to be bundled with the libwww-perl, but it was unbundled in
  v6.02 in order to be able to declare its dependencies properly for the CPAN
  tool-chain.  Applications that need https support can just declare their
  dependency on LWP::Protocol::https and will no longer need to know what
  underlying modules to install.
  
  =head1 SEE ALSO
  
  L<IO::Socket::SSL>, L<Crypt::SSLeay>, L<Mozilla::CA>
  
  =head1 COPYRIGHT
  
  Copyright 1997-2011 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
LWP_PROTOCOL_HTTPS

$fatpacked{"LWP/Protocol/https10.pm"} = <<'LWP_PROTOCOL_HTTPS10';
  package LWP::Protocol::https10;
  
  use strict;
  
  # Figure out which SSL implementation to use
  use vars qw($SSL_CLASS);
  if ($Net::SSL::VERSION) {
      $SSL_CLASS = "Net::SSL";
  }
  elsif ($IO::Socket::SSL::VERSION) {
      $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded
  }
  else {
      eval { require Net::SSL; };     # from Crypt-SSLeay
      if ($@) {
  	require IO::Socket::SSL;
  	$SSL_CLASS = "IO::Socket::SSL";
      }
      else {
  	$SSL_CLASS = "Net::SSL";
      }
  }
  
  
  use vars qw(@ISA);
  
  require LWP::Protocol::http10;
  @ISA=qw(LWP::Protocol::http10);
  
  sub _new_socket
  {
      my($self, $host, $port, $timeout) = @_;
      local($^W) = 0;  # IO::Socket::INET can be noisy
      my $sock = $SSL_CLASS->new(PeerAddr => $host,
  			       PeerPort => $port,
  			       Proto    => 'tcp',
  			       Timeout  => $timeout,
  			      );
      unless ($sock) {
  	# IO::Socket::INET leaves additional error messages in $@
  	$@ =~ s/^.*?: //;
  	die "Can't connect to $host:$port ($@)";
      }
      $sock;
  }
  
  sub _check_sock
  {
      my($self, $req, $sock) = @_;
      my $check = $req->header("If-SSL-Cert-Subject");
      if (defined $check) {
  	my $cert = $sock->get_peer_certificate ||
  	    die "Missing SSL certificate";
  	my $subject = $cert->subject_name;
  	die "Bad SSL certificate subject: '$subject' !~ /$check/"
  	    unless $subject =~ /$check/;
  	$req->remove_header("If-SSL-Cert-Subject");  # don't pass it on
      }
  }
  
  sub _get_sock_info
  {
      my $self = shift;
      $self->SUPER::_get_sock_info(@_);
      my($res, $sock) = @_;
      $res->header("Client-SSL-Cipher" => $sock->get_cipher);
      my $cert = $sock->get_peer_certificate;
      if ($cert) {
  	$res->header("Client-SSL-Cert-Subject" => $cert->subject_name);
  	$res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name);
      }
      $res->header("Client-SSL-Warning" => "Peer certificate not verified");
  }
  
  1;
LWP_PROTOCOL_HTTPS10

$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.00";
  
  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 $robot_res = $self->request($robot_req);
  	my $fresh_until = $robot_res->fresh_until;
  	if ($robot_res->is_success) {
  	    my $c = $robot_res->content;
  	    if ($robot_res->content_type =~ m,^text/, && $c =~ /^\s*Disallow\s*:/mi) {
  		$self->{'rules'}->parse($robot_url, $c, $fresh_until);
  	    }
  	    else {
  		$self->{'rules'}->parse($robot_url, "", $fresh_until);
  	    }
  
  	}
  	else {
  	    $self->{'rules'}->parse($robot_url, "", $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.02";
  
  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 ($ssl_opts) {
  	# The processing of HTTPS_CA_* below is for compatiblity with Crypt::SSLeay
  	$ssl_opts = {};
  	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 compatiblity (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 = delete $cnf{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 _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;
  }
  
  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);
      }
  }
  
  
  # depreciated
  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) = @_;
      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() and post().  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 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 envirionment 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 exceptions 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 get a chance of handling requests before it's 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 handlers is called for each chunk of data received for the
  response.  The handler might croak to abort the request.
  
  This handler need 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 return 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->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_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.37';
  
  use strict;
  use Locale::Maketext::Lexicon();
  
  =head1 NAME
  
  Locale::Maketext::Extract - Extract translatable strings from source
  
  =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
          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<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  (plugin: mason)
  
  Strings inside C<E<lt>&|/lE<gt>I<...>E<lt>/&E<gt>> and
  C<E<lt>&|/locE<gt>I<...>E<lt>/&E<gt>> 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, then it uses all of the builtin
  plugins, and overrides the file types specified in each plugin
   - instead, each plugin is tried for every file.
  
  =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.
  
  =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
  
  =cut
  
  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',
  );
  
  sub new {
      my $class   = shift;
      my %params  = @_;
      my $plugins = delete $params{plugins}
          || { map { $_ => '*' } 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;
  }
  
  =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
  
  =cut
  
  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 next;
              push @plugins, $plugin_class->new( $params{$name} );
          }
          $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;
  }
  
  =head2 PO File manipulation
  
  =head3 method read_po ($file)
  
  =cut
  
  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];
  }
  
  =head3 method write_po ($file, $add_format_marker?)
  
  =cut
  
  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};
  
  }
  
  =head2 Extraction
  
      extract
      extract_file
  
  =cut
  
  sub extract {
      my $self    = shift;
      my $file    = shift;
      my $content = shift;
  
      local $@;
  
      my ( @messages, $total, $error_found );
      $total = 0;
      my $verbose = $self->{verbose};
      foreach my $plugin ( @{ $self->plugins } ) {
          if ( $plugin->known_file_type($file) ) {
              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;
  }
  
  =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.
  
  =cut
  
  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;
  }
  
  =head3 normalize_space
  
  =cut
  
  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) ) ) );
  }
  
  =head2 Lexicon accessors
  
      msgids, has_msgid,
      msgstr, set_msgstr
      msg_positions, msg_variables, msg_format, msg_out
  
  =cut
  
  sub msgids    { sort keys %{ $_[0]{lexicon} } }
  sub has_msgid { length $_[0]->msgstr( $_[1] ) }
  
  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);
  }
  
  =head2 Internal utilities
  
      _default_header
      _maketext_to_gettext
      _escape
      _format
  
  =cut
  
  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);
  }
  
  1;
  
  =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-2008 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.
  
  =cut
LOCALE_MAKETEXT_EXTRACT

$fatpacked{"Locale/Maketext/Extract/Plugin/Base.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_BASE';
  package Locale::Maketext::Extract::Plugin::Base;
  
  use strict;
  
  use File::Basename qw(fileparse);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Base - Base module for format parser plugins
  
  =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;
          my $filename = 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
      )
  
  =cut
  
  sub new {
      my $class = shift;
      my $self = bless {
          entries => [],
      }, $class;
  
      $self->_compile_file_types(@_);
      return $self;
  }
  
  =item add_entry()
  
      $plugin->add_entry($str,$line,$vars)
  
  =cut
  
  sub add_entry {
      my $self = shift;
      push @{$self->{entries}},[@_];
  }
  
  =item C<entries()>
  
      $entries = $plugin->entries;
  
  =cut
  
  #===================================
  sub entries {
  #===================================
      my $self = shift;
      return $self->{entries};
  }
  
  =item C<clear()>
  
      $plugin->clear
  
  Clears all stored entries.
  
  =cut
  
  #===================================
  sub clear {
  #===================================
      my $self = shift;
      $self->{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
  
  =cut
  
  sub file_types {
      die "Please override sub file_types() to return "
          . "a list of recognised file extensions, or regexes";
  }
  
  =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()>
  
  =cut
  
  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;
  }
  
  =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.
  
  =cut
  
  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;
  }
  
  =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-2008 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.
  
  =cut
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_BASE

$fatpacked{"Locale/Maketext/Extract/Plugin/FormFu.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_FORMFU';
  package Locale::Maketext::Extract::Plugin::FormFu;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::FormFu - FormFu format parser
  
  =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.
  
  =cut
  
  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;
  
  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};
  }
  
  =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-2008 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.
  
  =cut
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_FORMFU

$fatpacked{"Locale/Maketext/Extract/Plugin/Generic.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_GENERIC';
  package Locale::Maketext::Extract::Plugin::Generic;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Generic - Generic template parser
  
  =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
  
  =cut
  
  
  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, '' );
      }
  }
  
  =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-2008 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.
  
  =cut
  
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_GENERIC

$fatpacked{"Locale/Maketext/Extract/Plugin/Mason.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_MASON';
  package Locale::Maketext::Extract::Plugin::Mason;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Mason - Mason format parser
  
  =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
  
  Strings inside <&|/l>...</&> and <&|/loc>...</&> are extracted.
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item All file types
  
  =back
  
  =cut
  
  sub file_types {
      return qw( * );
  }
  
  
  sub extract {
      my $self = shift;
      local $_ = shift;
  
      my $line = 1;
  
      # HTML::Mason
  
      while (m!\G(.*?<&\|/l(?:oc)?(.*?)&>(.*?)</&>)!sg) {
          my ($vars, $str) = ($2, $3);
          $line += ( () = ($1 =~ /\n/g) ); # cryptocontext!
          $self->add_entry($str,  $line, $vars );
      }
  
  }
  
  =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-2008 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.
  
  =cut
  
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_MASON

$fatpacked{"Locale/Maketext/Extract/Plugin/PPI.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_PPI';
  package Locale::Maketext::Extract::Plugin::PPI;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use PPI();
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::PPI - Perl format parser
  
  =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 loc
  
  =item x
  
  =item _
  
  =item __
  
  =back
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .pm
  
  =item .pl
  
  =item .cgi
  
  =back
  
  =cut
  
  sub file_types {
      return qw( pm pl cgi );
  }
  
  my %subnames = map { $_ => 1 } qw (translate maketext gettext 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 );
  }
  
  =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-2008 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.
  
  =cut
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_PPI

$fatpacked{"Locale/Maketext/Extract/Plugin/Perl.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_PERL';
  package Locale::Maketext::Extract::Plugin::Perl;
  
  use strict;
  
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::Perl - Perl format parser
  
  =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 loc
  
  =item x
  
  =item _
  
  =item __
  
  =back
  
  =head1 KNOWN FILE TYPES
  
  =over 4
  
  =item .pm
  
  =item .pl
  
  =item .cgi
  
  =back
  
  =cut
  
  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)?|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 };
      }
  }
  
  =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-2008 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.
  
  =cut
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_PERL

$fatpacked{"Locale/Maketext/Extract/Plugin/TT2.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_TT2';
  package Locale::Maketext::Extract::Plugin::TT2;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use Template::Constants qw( :debug );
  use Template::Parser;
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::TT2 - Template Toolkit format parser
  
  =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) %]
  
  =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
  
  
  =cut
  
  # 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;
  #===================================
  #===================================
  
  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;
  #===================================
  #===================================
  
  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 );
          }
          if ( $first_literal
               && ( $ident->[0] eq "'l'" or $ident->[0] eq "'loc'" ) )
          {
              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'";
      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 ) . ')';
  }
  
  =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-2008 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.
  
  =cut
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_TT2

$fatpacked{"Locale/Maketext/Extract/Plugin/TextTemplate.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_TEXTTEMPLATE';
  package Locale::Maketext::Extract::Plugin::TextTemplate;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  use vars qw($VERSION);
  
  $VERSION = '0.31';
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::TextTemplate - Text::Template format parser
  
  =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
  
  =cut
  
  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;
              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;
          }
          $_ = '';
      }
  
  }
  
  =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-2008 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.
  
  =cut
  
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_TEXTTEMPLATE

$fatpacked{"Locale/Maketext/Extract/Plugin/YAML.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_PLUGIN_YAML';
  package Locale::Maketext::Extract::Plugin::YAML;
  
  use strict;
  use base qw(Locale::Maketext::Extract::Plugin::Base);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Plugin::YAML - YAML format parser
  
  =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.
  
  =cut
  
  
  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;
  
  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};
  }
  
  =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-2008 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.
  
  =cut
  
  
  1;
LOCALE_MAKETEXT_EXTRACT_PLUGIN_YAML

$fatpacked{"Locale/Maketext/Extract/Run.pm"} = <<'LOCALE_MAKETEXT_EXTRACT_RUN';
  package Locale::Maketext::Extract::Run;
  $Locale::Maketext::Lexicon::Extract::Run::VERSION = '0.34';
  
  use strict;
  use vars qw( @ISA @EXPORT_OK );
  use File::Spec::Functions qw(catfile);
  
  =head1 NAME
  
  Locale::Maketext::Extract::Run - Module interface to xgettext.pl
  
  =head1 SYNOPSIS
  
      use Locale::Maketext::Extract::Run 'xgettext';
      xgettext(@ARGV);
  
  =cut
  
  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)$/;
                         return;
                     }
                     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;
  
  =head1 COPYRIGHT
  
  Copyright 2003-2008 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.
  
  =cut
LOCALE_MAKETEXT_EXTRACT_RUN

$fatpacked{"Locale/Maketext/Lexicon.pm"} = <<'LOCALE_MAKETEXT_LEXICON';
  package Locale::Maketext::Lexicon;
  $Locale::Maketext::Lexicon::VERSION = '0.82';
  
  use 5.004;
  use strict;
  
  =head1 NAME
  
  Locale::Maketext::Lexicon - Use other catalog formats in Maketext
  
  =head1 VERSION
  
  This document describes version 0.80 of Locale::Maketext::Lexicon,
  released December 29, 2008.
  
  =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 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.
  
  =cut
  
  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;
              }
  
              local $@;
              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;
  
  =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-2008 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.
  
  =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.10';
  
  use strict;
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Auto - Auto fallback lexicon for Maketext
  
  =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.
  
  =cut
  
  sub parse {
      +{ _AUTO => 1 };
  }
  
  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, 2003, 2004, 2007 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.
  
  =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.17';
  
  use strict;
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Gettext - PO and MO file parser for Maketext
  
  =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,
      };
  
  =cut
  
  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;
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002, 2003, 2004, 2007 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.
  
  =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.03';
  
  use strict;
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Msgcat - Msgcat catalog parser Maketext
  
  =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.
  
  =cut
  
  sub parse {
      my $set = 0;
      my $msg = undef;
      my ($qr, $qq, $qc) = (qr//, '', '');
      my @out;
  
      # Set up the msgcat handler
      {
          no strict 'refs';
          *{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;
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002, 2003, 2004, 2007 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.
  
  =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.05';
  
  use strict;
  use Symbol ();
  
  =head1 NAME
  
  Locale::Maketext::Lexicon::Tie - Use tied hashes as lexicons for Maketext
  
  =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.
  
  =cut
  
  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;
  
  =head1 SEE ALSO
  
  L<Locale::Maketext>, L<Locale::Maketext::Lexicon>
  
  =head1 AUTHORS
  
  Audrey Tang E<lt>cpan@audreyt.orgE<gt>
  
  =head1 COPYRIGHT
  
  Copyright 2002, 2003, 2004, 2007 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.
  
  =cut
LOCALE_MAKETEXT_LEXICON_TIE

$fatpacked{"MLDBM.pm"} = <<'MLDBM';
  #
  # MLDBM.pm
  #
  # store multi-level hash structure in single level tied hash (read DBM)
  #
  # Documentation at the __END__
  #
  # Gurusamy Sarathy <gsar@umich.edu>
  # Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
  #
  
  require 5.004;
  use strict;
  
  ####################################################################
  package MLDBM::Serializer;	## deferred
  
  use Carp;
  
  #
  # The serialization interface comprises of just three methods:
  # new(), serialize() and deserialize().  Only the last two are
  # _required_ to be implemented by any MLDBM serialization wrapper.
  #
  
  sub new { bless {}, shift };
  
  sub serialize { confess "deferred" };
  
  sub deserialize { confess "deferred" };
  
  
  #
  # Attributes:
  #
  #    dumpmeth:
  #	the preferred dumping method.
  #
  #    removetaint:
  #	untainting flag; when true, data will be untainted after
  #	extraction from the database.
  #
  #    key:
  #	the magic string used to recognize non-natively stored data.
  #
  # Attribute access methods:
  #
  #	These defaults allow readonly access. Sub-class may override
  #	them to allow write access if any of these attributes
  #	makes sense for it.
  #
  
  sub DumpMeth	{
      my $s = shift;
      confess "can't set dumpmeth with " . ref($s) if @_;
      $s->_attrib('dumpmeth');
  }
  
  sub RemoveTaint	{
      my $s = shift;
      confess "can't set untaint with " . ref($s) if @_;
      $s->_attrib('removetaint');
  }
  
  sub Key	{
      my $s = shift;
      confess "can't set key with " . ref($s) if @_;
      $s->_attrib('key');
  }
  
  sub _attrib {
      my ($s, $a, $v) = @_;
      if (ref $s and @_ > 2) {
  	$s->{$a} = $v;
  	return $s;
      }
      $s->{$a};
  }
  
  ####################################################################
  package MLDBM;
  
  $MLDBM::VERSION = $MLDBM::VERSION = '2.04';
  
  require Tie::Hash;
  @MLDBM::ISA = 'Tie::Hash';
  
  use Carp;
  
  #
  # the DB package to use (we default to SDBM since it comes with perl)
  # you might want to change this default to something more efficient
  # like DB_File (you can always override it in the use list)
  #
  $MLDBM::UseDB		= "SDBM_File"		unless $MLDBM::UseDB;
  $MLDBM::Serializer	= 'Data::Dumper'	unless $MLDBM::Serializer;
  $MLDBM::Key		= '$MlDbM'		unless $MLDBM::Key;
  $MLDBM::DumpMeth	= ""			unless $MLDBM::DumpMeth;
  $MLDBM::RemoveTaint	= 0			unless $MLDBM::RemoveTaint;
  
  #
  # A private way to load packages at runtime.
  my $loadpack = sub {
      my $pack = shift;
      $pack =~ s|::|/|g;
      $pack .= ".pm";
      eval { require $pack };
      if ($@) {
  	carp "MLDBM error: " . 
  	  "Please make sure $pack is a properly installed package.\n" .
  	    "\tPerl says: \"$@\"";
  	return undef;
      }
      1;
  };
  
  
  #
  # TIEHASH interface methods
  #
  sub TIEHASH {
      my $c = shift;
      my $s = bless {}, $c;
  
      #
      # Create the right serializer object.
      my $szr = $MLDBM::Serializer;
      unless (ref $szr) {
  	$szr = "MLDBM::Serializer::$szr"	# allow convenient short names
  	  unless $szr =~ /^MLDBM::Serializer::/;
  	$loadpack->($szr) or return undef;
  	$szr = $szr->new($MLDBM::DumpMeth,
  			 $MLDBM::RemoveTaint,
  			 $MLDBM::Key);
      }
      $s->Serializer($szr);
  
      #
      # Create the right TIEHASH  object.
      my $db = $MLDBM::UseDB;
      unless (ref $db) {
  	$loadpack->($db) or return undef;
  	$db = $db->TIEHASH(@_)
  	  or carp "MLDBM error: Second level tie failed, \"$!\""
  	    and return undef;
      }
      $s->UseDB($db);
  
      return $s;
  }
  
  sub FETCH {
      my ($s, $k) = @_;
      my $ret = $s->{DB}->FETCH($k);
      $s->{SR}->deserialize($ret);
  }
  
  sub STORE {
      my ($s, $k, $v) = @_;
      $v = $s->{SR}->serialize($v);
      $s->{DB}->STORE($k, $v);
  }
  
  sub DELETE	{ my $s = shift; $s->{DB}->DELETE(@_); }
  sub FIRSTKEY	{ my $s = shift; $s->{DB}->FIRSTKEY(@_); }
  sub NEXTKEY	{ my $s = shift; $s->{DB}->NEXTKEY(@_); }
  sub EXISTS	{ my $s = shift; $s->{DB}->EXISTS(@_); }
  sub CLEAR	{ my $s = shift; $s->{DB}->CLEAR(@_); }
  
  sub new		{ &TIEHASH }
  
  #
  # delegate messages to the underlying DBM
  #
  sub AUTOLOAD {
      return if $MLDBM::AUTOLOAD =~ /::DESTROY$/;
      my $s = shift;
      if (ref $s) {			# twas a method call
  	my $dbname = ref($s->{DB});
  	# permit inheritance
  	$MLDBM::AUTOLOAD =~ s/^.*::([^:]+)$/$dbname\:\:$1/;
  	$s->{DB}->$MLDBM::AUTOLOAD(@_);
      }
  }
  
  #
  # delegate messages to the underlying Serializer
  #
  sub DumpMeth	{ my $s = shift; $s->{SR}->DumpMeth(@_); }
  sub RemoveTaint	{ my $s = shift; $s->{SR}->RemoveTaint(@_); }
  sub Key		{ my $s = shift; $s->{SR}->Key(@_); }
  
  #
  # get/set the DB object
  #
  sub UseDB 	{ my $s = shift; @_ ? ($s->{DB} = shift) : $s->{DB}; }
  
  #
  # get/set the Serializer object
  #
  sub Serializer	{ my $s = shift; @_ ? ($s->{SR} = shift) : $s->{SR}; }
  
  #
  # stuff to do at 'use' time
  #
  sub import {
      my ($pack, $dbpack, $szr, $dumpmeth, $removetaint, $key) = @_;
      $MLDBM::UseDB = $dbpack if defined $dbpack and $dbpack;
      $MLDBM::Serializer = $szr if defined $szr and $szr;
      # undocumented, may change!
      $MLDBM::DumpMeth = $dumpmeth if defined $dumpmeth;
      $MLDBM::RemoveTaint = $removetaint if defined $removetaint;
      $MLDBM::Key = $key if defined $key and $key;
  }
  
  # helper subroutine for tests to compare to arbitrary data structures
  # for equivalency
  sub _compare {
      use vars qw(%compared);
      local %compared;
      return _cmp(@_);
  }
  
  sub _cmp {
      my($a, $b) = @_;
  
      # catch circular loops
      return(1) if $compared{$a.'&*&*&*&*&*'.$b}++;
  #    print "$a $b\n";
  #    print &Data::Dumper::Dumper($a, $b);
  
      if(ref($a) and ref($a) eq ref($b)) {
  	if(eval { @$a }) {
  #	    print "HERE ".@$a." ".@$b."\n";
  	    @$a == @$b or return 0;
  #	    print @$a, ' ', @$b, "\n";
  #	    print "HERE2\n";
  
  	    for(0..@$a-1) {
  		&_cmp($a->[$_], $b->[$_]) or return 0;
  	    }
  	} elsif(eval { %$a }) {
  	    keys %$a == keys %$b or return 0;
  	    for (keys %$a) {
  		&_cmp($a->{$_}, $b->{$_}) or return 0;
  	    }
  	} elsif(eval { $$a }) {
  	    &_cmp($$a, $$b) or return 0;
  	} else {
  	    die("data $a $b not handled");
  	}
  	return 1;
      } elsif(! ref($a) and ! ref($b)) {
  	return ($a eq $b);
      } else {
  	return 0;
      }
  
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  MLDBM - store multi-level Perl hash structure in single level tied hash
  
  =head1 SYNOPSIS
  
      use MLDBM;				# this gets the default, SDBM
      #use MLDBM qw(DB_File FreezeThaw);	# use FreezeThaw for serializing
      #use MLDBM qw(DB_File Storable);	# use Storable for serializing
  
      $dbm = tie %o, 'MLDBM' [..other DBM args..] or die $!;
  
  =head1 DESCRIPTION
  
  This module can serve as a transparent interface to any TIEHASH package
  that is required to store arbitrary perl data, including nested references.
  Thus, this module can be used for storing references and other arbitrary data
  within DBM databases.
  
  It works by serializing the references in the hash into a single string. In the
  underlying TIEHASH package (usually a DBM database), it is this string that
  gets stored.  When the value is fetched again, the string is deserialized to
  reconstruct the data structure into memory.
  
  For historical and practical reasons, it requires the B<Data::Dumper> package,
  available at any CPAN site. B<Data::Dumper> gives you really nice-looking dumps of
  your data structures, in case you wish to look at them on the screen, and
  it was the only serializing engine before version 2.00.  However, as of version
  2.00, you can use any of B<Data::Dumper>, B<FreezeThaw> or B<Storable> to
  perform the underlying serialization, as hinted at by the L<SYNOPSIS> overview
  above.  Using B<Storable> is usually much faster than the other methods.
  
  See the L<BUGS> section for important limitations.
  
  =head2 Changing the Defaults
  
  B<MLDBM> relies on an underlying TIEHASH implementation (usually a
  DBM package), and an underlying serialization package.  The respective
  defaults are B<SDBM_File> and B<Data::Dumper>.  Both of these defaults
  can be changed.  Changing the B<SDBM_File> default is strongly recommended.
  See L<WARNINGS> below.
  
  Three serialization wrappers are currently supported: B<Data::Dumper>,
  B<Storable>, and B<FreezeThaw>.  Additional serializers can be
  supported by writing a wrapper that implements the interface required by
  B<MLDBM::Serializer>.  See the supported wrappers and the B<MLDBM::Serializer>
  source for details.
  
  In the following, I<$OBJ> stands for the tied object, as in:
  
  	$obj = tie %o, ....
  	$obj = tied %o;
  
  =over 4
  
  =item $MLDBM::UseDB	I<or>	I<$OBJ>->UseDB(I<[TIEDOBJECT]>)
  
  The global C<$MLDBM::UseDB> can be set to default to something other than
  C<SDBM_File>, in case you have a more efficient DBM, or if you want to use
  this with some other TIEHASH implementation.  Alternatively, you can specify
  the name of the package at C<use> time, as the first "parameter".
  Nested module names can be specified as "Foo::Bar".
  
  The corresponding method call returns the underlying TIEHASH object when
  called without arguments.  It can be called with any object that
  implements Perl's TIEHASH interface, to set that value.
  
  =item $MLDBM::Serializer	I<or>	I<$OBJ>->Serializer(I<[SZROBJECT]>)
  
  The global C<$MLDBM::Serializer> can be set to the name of the serializing
  package to be used. Currently can be set to one of C<Data::Dumper>,
  C<Storable>, or C<FreezeThaw>. Defaults to C<Data::Dumper>.  Alternatively,
  you can specify the name of the serializer package at C<use> time, as the
  second "parameter".
  
  The corresponding method call returns the underlying MLDBM serializer object
  when called without arguments.  It can be called with an object that
  implements the MLDBM serializer interface, to set that value.
  
  =back
  
  =head2 Controlling Serializer Properties
  
  These methods are meant to supply an interface to the properties of the
  underlying serializer used.  Do B<not> call or set them without
  understanding the consequences in full.  The defaults are usually sensible.
  
  Not all of these necessarily apply to all the supplied serializers, so we
  specify when to apply them.  Failure to respect this will usually lead to
  an exception.
  
  =over 4
  
  =item $MLDBM::DumpMeth	I<or>  I<$OBJ>->DumpMeth(I<[METHNAME]>)
  
  If the serializer provides alternative serialization methods, this
  can be used to set them.
  
  With B<Data::Dumper> (which offers a pure Perl and an XS verion
  of its serializing routine), this is set to C<Dumpxs> by default if that
  is supported in your installation.  Otherwise, defaults to the slower
  C<Dump> method.
  
  With B<Storable>, a value of C<portable> requests that serialization be
  architecture neutral, i.e. the deserialization can later occur on another
  platform. Of course, this only makes sense if your database files are
  themselves architecture neutral.  By default, native format is used for
  greater serializing speed in B<Storable>.  Both B<Data::Dumper> and
  B<FreezeThaw> are always architecture neutral.
  
  B<FreezeThaw> does not honor this attribute.
  
  =item $MLDBM::Key  I<or>  I<$OBJ>->Key(I<[KEYSTRING]>)
  
  If the serializer only deals with part of the data (perhaps because
  the TIEHASH object can natively store some types of data), it may need
  a unique key string to recognize the data it handles.  This can be used
  to set that string.  Best left alone.
  
  Defaults to the magic string used to recognize MLDBM data. It is a six
  character wide, unique string. This is best left alone, unless you know
  what you are doing. 
  
  B<Storable> and B<FreezeThaw> do not honor this attribute.
  
  =item $MLDBM::RemoveTaint  I<or>  I<$OBJ>->RemoveTaint(I<[BOOL]>)
  
  If the serializer can optionally untaint any retrieved data subject to
  taint checks in Perl, this can be used to request that feature.  Data
  that comes from external sources (like disk-files) must always be
  viewed with caution, so use this only when you are sure that that is
  not an issue.
  
  B<Data::Dumper> uses C<eval()> to deserialize and is therefore subject to
  taint checks.  Can be set to a true value to make the B<Data::Dumper>
  serializer untaint the data retrieved. It is not enabled by default.
  Use with care.
  
  B<Storable> and B<FreezeThaw> do not honor this attribute.
  
  =back
  
  =head1 EXAMPLES
  
  Here is a simple example.  Note that does not depend upon the underlying
  serializing package--most real life examples should not, usually.
  
      use MLDBM;				# this gets SDBM and Data::Dumper
      #use MLDBM qw(SDBM_File Storable);	# SDBM and Storable
      use Fcntl;				# to get 'em constants
  
      $dbm = tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!;
  
      $c = [\ 'c'];
      $b = {};
      $a = [1, $b, $c];
      $b->{a} = $a;
      $b->{b} = $a->[1];
      $b->{c} = $a->[2];
      @o{qw(a b c)} = ($a, $b, $c);
  
      #
      # to see what was stored
      #
      use Data::Dumper;
      print Data::Dumper->Dump([@o{qw(a b c)}], [qw(a b c)]);
  
      #
      # to modify data in a substructure
      #
      $tmp = $o{a};
      $tmp->[0] = 'foo';
      $o{a} = $tmp;
  
      #
      # can access the underlying DBM methods transparently
      #
      #print $dbm->fd, "\n";		# DB_File method
  
  Here is another small example using Storable, in a portable format:
  
      use MLDBM qw(DB_File Storable);	# DB_File and Storable
  
      tie %o, 'MLDBM', 'testmldbm', O_CREAT|O_RDWR, 0640 or die $!;
  
      (tied %o)->DumpMeth('portable');	# Ask for portable binary
      $o{'ENV'} = \%ENV;			# Stores the whole environment
  
  
  =head1 BUGS
  
  =over 4
  
  =item 1.
  
  Adding or altering substructures to a hash value is not entirely transparent
  in current perl.  If you want to store a reference or modify an existing
  reference value in the DBM, it must first be retrieved and stored in a
  temporary variable for further modifications.  In particular, something like
  this will NOT work properly:
  
  	$mldb{key}{subkey}[3] = 'stuff';	# won't work
  
  Instead, that must be written as:
  
  	$tmp = $mldb{key};			# retrieve value
  	$tmp->{subkey}[3] = 'stuff';
  	$mldb{key} = $tmp;			# store value
  
  This limitation exists because the perl TIEHASH interface currently has no
  support for multidimensional ties.
  
  =item 2.
  
  The B<Data::Dumper> serializer uses eval().  A lot.  Try the B<Storable>
  serializer, which is generally the most efficient.
  
  =back
  
  =head1 WARNINGS
  
  =over 4
  
  =item 1.
  
  Many DBM implementations have arbitrary limits on the size of records
  that can be stored.  For example, SDBM and many ODBM or NDBM
  implementations have a default limit of 1024 bytes for the size of a
  record.  MLDBM can easily exceed these limits when storing large data
  structures, leading to mysterious failures.  Although SDBM_File is
  used by MLDBM by default, it is not a good choice if you're storing
  large data structures.  Berkeley DB and GDBM both do not have these
  limits, so I recommend using either of those instead.
  
  =item 2.
  
  MLDBM does well with data structures that are not too deep and not
  too wide.  You also need to be careful about how many C<FETCH>es your
  code actually ends up doing.  Meaning, you should get the most mileage
  out of a C<FETCH> by holding on to the highest level value for as long
  as you need it.  Remember that every toplevel access of the tied hash,
  for example C<$mldb{foo}>, translates to a MLDBM C<FETCH()> call.
  
  Too often, people end up writing something like this:
  
          tie %h, 'MLDBM', ...;
          for my $k (keys %{$h{something}}) {
              print $h{something}{$k}[0]{foo}{bar};  # FETCH _every_ time!
          }
  
  when it should be written this for efficiency:
  
          tie %h, 'MLDBM', ...;
          my $root = $h{something};                  # FETCH _once_
          for my $k (keys %$root) {
              print $k->[0]{foo}{bar};
          }
  
  
  =back
  
  =head1 AUTHORS
  
  Gurusamy Sarathy <F<gsar@umich.edu>>.
  
  Support for multiple serializing packages by
  Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>.
  
  Test suite fixes for perl 5.8.0 done by Josh Chamas.
  
  Copyright (c) 1995-98 Gurusamy Sarathy.  All rights reserved.
  
  Copyright (c) 1998 Raphael Manfredi.
  
  Copyright (c) 2002 Josh Chamas, Chamas Enterprises Inc.
  
  Copyright (c) 2010 Alexandr Ciornii (alexchorny@gmail.com).
  
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =head1 VERSION
  
  Version 2.04	08 Mar 2010
  
  =head1 SEE ALSO
  
  perl(1), perltie(1), perlfunc(1), Data::Dumper(3), FreezeThaw(3), Storable(3), DBM::Deep.
  
  =cut
MLDBM

$fatpacked{"MLDBM/Serializer/Data/Dumper.pm"} = <<'MLDBM_SERIALIZER_DATA_DUMPER';
  ####################################################################
  package MLDBM::Serializer::Data::Dumper;
  BEGIN { @MLDBM::Serializer::Data::Dumper::ISA = qw(MLDBM::Serializer) }
  
  use Data::Dumper '2.08';		# Backward compatibility
  use Carp;
  
  #
  # Create a Data::Dumper serializer object.
  #
  sub new {
      my $self = shift->SUPER::new();
      my $meth = shift || "";
      $meth = (defined(&Data::Dumper::Dumpxs) ? 'Dumpxs' : 'Dump')
        unless $meth =~ /^Dump(xs)?$/;
      $self->DumpMeth($meth);
      $self->RemoveTaint(shift);
      $self->Key(shift);
      $self;
  }
  
  #
  # Serialize $val if it is a reference, or if it does begin with our magic
  # key string, since then at retrieval time we expect a Data::Dumper string.
  # Otherwise, return the scalar value.
  #
  sub serialize {
      my $self = shift;
      my ($val) = @_;
      return undef unless defined $val;
      return $val unless ref($val) or $val =~ m|^\Q$self->{'key'}|o;
      my $dumpmeth = $self->{'dumpmeth'};
      local $Data::Dumper::Indent = 0;
      local $Data::Dumper::Purity = 1;
      local $Data::Dumper::Terse = 1;
      return $self->{'key'} . Data::Dumper->$dumpmeth([$val], ['M']);
  }
  
  #
  # If the value is undefined or does not begin with our magic key string,
  # return it as-is. Otherwise, we need to recover the underlying data structure.
  #
  sub deserialize {
      my $self = shift;
      my ($val) = @_;
      return undef unless defined $val;
      return $val unless $val =~ s|^\Q$self->{'key'}||o;
      my $M = "";
      ($val) = $val =~ /^(.*)$/s if $self->{'removetaint'};
      # Disambiguate hashref (perl may treat it as a block)
      my $N = eval($val =~ /^\{/ ? '+'.$val : $val);
      return $M ? $M : $N unless $@;
      carp "MLDBM error: $@\twhile evaluating:\n $val";
  }
  
  sub DumpMeth	{ my $s = shift; $s->_attrib('dumpmeth', @_); }
  sub RemoveTaint	{ my $s = shift; $s->_attrib('removetaint', @_); }
  sub Key		{ my $s = shift; $s->_attrib('key', @_); }
  
  # avoid used only once warnings
  {
      local $Data::Dumper::Terse;
  }
  
  1;
MLDBM_SERIALIZER_DATA_DUMPER

$fatpacked{"MLDBM/Serializer/FreezeThaw.pm"} = <<'MLDBM_SERIALIZER_FREEZETHAW';
  ####################################################################
  package MLDBM::Serializer::FreezeThaw;
  BEGIN { @MLDBM::Serializer::FreezeThaw::ISA = qw(MLDBM::Serializer) }
  
  use FreezeThaw;
  
  sub serialize {
      return FreezeThaw::freeze($_[1]);
  }
  
  sub deserialize {
      my ($obj) = FreezeThaw::thaw($_[1]);
      return $obj;
  }
  
  1;
MLDBM_SERIALIZER_FREEZETHAW

$fatpacked{"MLDBM/Serializer/Storable.pm"} = <<'MLDBM_SERIALIZER_STORABLE';
  ####################################################################
  package MLDBM::Serializer::Storable;
  BEGIN { @MLDBM::Serializer::Storable::ISA = qw(MLDBM::Serializer) }
  
  use Storable;
  
  sub new {
      my $self = shift->SUPER::new();
      $self->DumpMeth(shift);
      # Storable doesn't honor other attributes
      $self;
  }
  
  #
  # Serialize a reference to supplied value
  #
  sub serialize {
      my $self = shift;
      my $dumpmeth = $self->{'_dumpsub_'};
      &$dumpmeth(\$_[0]);
  }
  
  #
  # Deserialize and de-reference
  #
  sub deserialize {
      my $obj = Storable::thaw($_[1]);		# Does not care whether portable
      defined($obj) ? $$obj : undef;
  }
  
  #
  # Change dump method when portability is requested
  #
  sub DumpMeth {
      my $self = shift;
      $self->{'_dumpsub_'} = 
        ($_[0] && $_[0] eq 'portable' ? \&Storable::nfreeze : \&Storable::freeze);
      $self->_attrib('dumpmeth', @_);
  }
  
  1;
MLDBM_SERIALIZER_STORABLE

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

$fatpacked{"MetaCPAN/API.pm"} = <<'METACPAN_API';
  use strict;
  use warnings;
  package MetaCPAN::API;
  BEGIN {
    $MetaCPAN::API::VERSION = '0.34';
  }
  # ABSTRACT: A comprehensive, DWIM-featured API to MetaCPAN
  
  use Any::Moose;
  
  use Carp;
  use JSON;
  use Try::Tiny;
  use HTTP::Tiny;
  use URI::Escape 'uri_escape';
  
  with qw/
      MetaCPAN::API::Author
      MetaCPAN::API::Module
      MetaCPAN::API::POD
      MetaCPAN::API::Release
      MetaCPAN::API::Source
  /;
  
  has base_url => (
      is      => 'ro',
      isa     => 'Str',
      default => 'http://api.metacpan.org/v0',
  );
  
  has ua => (
      is         => 'ro',
      isa        => 'HTTP::Tiny',
      lazy_build => 1,
  );
  
  has ua_args => (
      is      => 'ro',
      isa     => 'ArrayRef',
      default => sub {
          my $version = $MetaCPAN::API::VERSION || 'xx';
          return [ agent => "MetaCPAN::API/$version" ];
      },
  );
  
  sub _build_ua {
      my $self = shift;
  
      return HTTP::Tiny->new( @{ $self->ua_args } );
  }
  
  sub fetch {
      my $self    = shift;
      my $url     = shift;
      my $extra   = $self->_build_extra_params(@_);
      my $base    = $self->base_url;
      my $req_url = $extra ? "$base/$url?$extra" : "$base/$url";
  
      my $result  = $self->ua->get($req_url);
      return $self->_decode_result( $result, $req_url );
  }
  
  sub post {
      my $self  = shift;
      my $url   = shift;
      my $query = shift;
      my $base  = $self->base_url;
  
      defined $url
          or croak 'First argument of URL must be provided';
  
      ref $query and ref $query eq 'HASH'
          or croak 'Second argument of query hashref must be provided';
  
      my $query_json = encode_json $query;
      my $result     = $self->ua->request(
          'POST',
          "$base/$url",
          {
              headers => { 'Content-Type' => 'application/json' },
              content => $query_json,
          }
      );
  
      return $self->_decode_result( $result, $url, $query_json );
  }
  
  sub _decode_result {
      my $self = shift;
      my ( $result, $url, $original ) = @_;
      my $decoded_result;
  
      ref $result and ref $result eq 'HASH'
          or croak 'First argument must be hashref';
  
      defined $url
          or croak 'Second argument of a URL must be provided';
  
      if ( defined ( my $success = $result->{'success'} ) ) {
          my $reason = $result->{'reason'} || '';
          $reason .= ( defined $original ? " (request: $original)" : '' );
  
          $success or croak "Failed to fetch '$url': $reason";
      } else {
          croak 'Missing success in return value';
      }
  
      defined ( my $content = $result->{'content'} )
          or croak 'Missing content in return value';
  
      try   { $decoded_result = decode_json $content }
      catch { croak "Couldn't decode '$content': $_" };
  
      return $decoded_result;
  }
  
  sub _build_extra_params {
      my $self = shift;
  
      @_ % 2 == 0
          or croak 'Incorrect number of params, must be key/value';
  
      my %extra = @_;
      my $extra = join '&', map { "$_=" . uri_escape($extra{$_}) } keys %extra;
  
      return $extra;
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API - A comprehensive, DWIM-featured API to MetaCPAN
  
  =head1 VERSION
  
  version 0.34
  
  =head1 SYNOPSIS
  
      my $mcpan  = MetaCPAN::API->new();
      my $author = $mcpan->author('XSAWYERX');
      my $dist   = $mcpan->release( distribution => 'MetaCPAN-API' );
  
  =head1 DESCRIPTION
  
  This is a hopefully-complete API-compliant interface to MetaCPAN
  (L<https://metacpan.org>) with DWIM capabilities, to make your life easier.
  
  This module has three purposes:
  
  =over 4
  
  =item * Provide 100% of the beta MetaCPAN API
  
  This module will be updated regularly on every MetaCPAN API change, and intends
  to provide the user with as much of the API as possible, no shortcuts. If it's
  documented in the API, you should be able to do it.
  
  Because of this design decision, this module has an official MetaCPAN namespace
  with the blessing of the MetaCPAN developers.
  
  Notice this module currently only provides the beta API, not the old
  soon-to-be-deprecated API.
  
  =item * Be lightweight, to allow flexible usage
  
  While many modules would help make writing easier, it's important to take into
  account how they affect your compile-time, run-time and overall memory
  consumption.
  
  By providing a slim interface implementation, more users are able to use this
  module, such as long-running processes (like daemons), CLI or GUI applications,
  cron jobs, and more.
  
  =item * DWIM
  
  While it's possible to access the methods defined by the API spec, there's still
  a matter of what you're really trying to achieve. For example, when searching
  for I<"Dave">, you want to find both I<Dave Cross> and I<Dave Rolsky> (and any
  other I<Dave>), but you also want to search for a PAUSE ID of I<DAVE>, if one
  exists.
  
  This is where DWIM comes in. This module provides you with additional generic
  methods which will try to do what they think you want.
  
  Of course, this does not prevent you from manually using the API methods. You
  still have full control over that, if that's what you wish.
  
  You can (and should) read up on the generic methods, which will explain how
  their DWIMish nature works, and what searches they run.
  
  =back
  
  =head1 ATTRIBUTES
  
  =head2 base_url
  
      my $mcpan = MetaCPAN::API->new(
          base_url => 'http://localhost:9999',
      );
  
  This attribute is used for REST requests. You should set it to where the
  MetaCPAN is accessible. By default it's already set correctly, but if you're
  running a local instance of MetaCPAN, or use a local mirror, or tunnel it
  through a local port, or any of those stuff, you would want to change this.
  
  Default: I<http://api.metacpan.org/v0>.
  
  This attribute is read-only (immutable), meaning that once it's set on
  initialize (via C<new()>), you cannot change it. If you need to, create a
  new instance of MetaCPAN::API. Why is it immutable? Because it's better.
  
  =head2 ua
  
  This attribute is used to contain the user agent used for running the REST
  request to the server. It is specifically set to L<HTTP::Tiny>, so if you
  want to set it manually, make sure it's of HTTP::Tiny.
  
  HTTP::Tiny is used as part of the philosophy of keeping it tiny.
  
  This attribute is read-only (immutable), meaning that once it's set on
  initialize (via C<new()>), you cannot change it. If you need to, create a
  new instance of MetaCPAN::API. Why is it immutable? Because it's better.
  
  =head2 ua_args
  
      my $mcpan = MetaCPAN::API->new(
          ua_args => [ agent => 'MyAgent' ],
      );
  
  The arguments that will be given to the L<HTTP::Tiny> user agent.
  
  This attribute is read-only (immutable), meaning that once it's set on
  initialize (via C<new()>), you cannot change it. If you need to, create a
  new instance of MetaCPAN::API. Why is it immutable? Because it's better.
  
  The default is a user agent string: B<MetaCPAN::API/$version>.
  
  =head1 METHODS
  
  =head2 fetch
  
      my $result = $mcpan->fetch('/release/distribution/Moose');
  
      # with parameters
      my $more = $mcpan->fetch(
          '/release/distribution/Moose',
          param => 'value',
      );
  
  This is a helper method for API implementations. It fetches a path from
  MetaCPAN, decodes the JSON from the content variable and returns it.
  
  You don't really need to use it, but you can in case you want to write your
  own extension implementation to MetaCPAN::API.
  
  It accepts an additional hash as C<GET> parameters.
  
  =head2 post
  
      # /release&content={"query":{"match_all":{}},"filter":{"prefix":{"archive":"Cache-Cache-1.06"}}}
      my $result = $mcpan->fetch(
          'release',
          {
              query  => { match_all => {} },
              filter => { prefix => { archive => 'Cache-Cache-1.06' } },
          },
      );
  
  The POST equivalent of the C<fetch()> method. It gets the path and JSON request.
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API

$fatpacked{"MetaCPAN/API/Author.pm"} = <<'METACPAN_API_AUTHOR';
  use strict;
  use warnings;
  package MetaCPAN::API::Author;
  BEGIN {
    $MetaCPAN::API::Author::VERSION = '0.34';
  }
  # ABSTRACT: Author information for MetaCPAN::API
  
  use Carp;
  use Any::Moose 'Role';
  
  # /author/{author}
  sub author {
      my $self = shift;
      my ( $pause_id, $url, %extra_opts );
  
      if ( @_ == 1 ) {
          $url = 'author/' . shift;
      } elsif ( @_ == 2 ) {
          my %opts = @_;
  
          if ( defined $opts{'pauseid'} ) {
              $url = "author/" . $opts{'pauseid'};
          } elsif ( defined $opts{'search'} ) {
              my $search_opts = $opts{'search'};
  
              ref $search_opts && ref $search_opts eq 'HASH'
                  or croak "'search' key must be hashref";
  
              %extra_opts = %{$search_opts};
              $url        = 'author/_search';
          } else {
              croak 'Unknown option given';
          }
      } else {
          croak 'Please provide an author PAUSEID or a "search"';
      }
  
      return $self->fetch( $url, %extra_opts );
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API::Author - Author information for MetaCPAN::API
  
  =head1 VERSION
  
  version 0.34
  
  =head1 DESCRIPTION
  
  This role provides MetaCPAN::API with fetching information about authors.
  
  =head1 METHODS
  
  =head2 author
  
      my $result1 = $mcpan->author('XSAWYERX');
      my $result2 = $mcpan->author( pauseid => 'XSAWYERX' );
  
  Searches MetaCPAN for a specific author.
  
  You can do complex searches using 'search' parameter:
  
      # example lifted from MetaCPAN docs
      my $result = $mcpan->author(
          search => {
              q    => 'profile.name:twitter',
              size => 1,
          },
      );
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API_AUTHOR

$fatpacked{"MetaCPAN/API/Module.pm"} = <<'METACPAN_API_MODULE';
  use strict;
  use warnings;
  package MetaCPAN::API::Module;
  BEGIN {
    $MetaCPAN::API::Module::VERSION = '0.34';
  }
  # ABSTRACT: Module information for MetaCPAN::API
  
  use Carp;
  use Any::Moose 'Role';
  
  # /module/{module}
  sub module {
      my $self = shift;
      my $name = shift;
  
      $name or croak 'Please provide a module name';
  
      return $self->fetch("module/$name");
  }
  
  # file() is a synonym of module
  sub file { goto &module }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API::Module - Module information for MetaCPAN::API
  
  =head1 VERSION
  
  version 0.34
  
  =head1 DESCRIPTION
  
  This role provides MetaCPAN::API with fetching information about modules.
  
  More specifically, this returns the C<.pm> file of that module.
  
  =head1 METHODS
  
  =head2 module
  
      my $result = $mcpan->module('MetaCPAN::API');
  
  Searches MetaCPAN and returns a module's C<.pm> file.
  
  =head2 file
  
  A synonym of C<module>.
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API_MODULE

$fatpacked{"MetaCPAN/API/POD.pm"} = <<'METACPAN_API_POD';
  use strict;
  use warnings;
  package MetaCPAN::API::POD;
  BEGIN {
    $MetaCPAN::API::POD::VERSION = '0.34';
  }
  # ABSTRACT: POD information for MetaCPAN::API
  
  use Carp;
  use Any::Moose 'Role';
  
  # /pod/{module}
  # /pod/{author}/{release}/{path}
  sub pod {
      my $self  = shift;
      my %opts  = @_ ? @_ : ();
      my $url   = '';
      my $error = "Either provide 'module' or 'author and 'release' and 'path'";
  
      %opts or croak $error;
  
      if ( defined ( my $module = $opts{'module'} ) ) {
          $url = "pod/$module";
      } elsif (
          defined ( my $author  = $opts{'author'}  ) &&
          defined ( my $release = $opts{'release'} ) &&
          defined ( my $path    = $opts{'path'}    )
        ) {
          $url = "pod/$author/$release/$path";
      } else {
          croak $error;
      }
  
      # check content-type
      my %extra = ();
      if ( defined ( my $type = $opts{'content-type'} ) ) {
          $type =~ m{^ text/ (?: html|plain|x-pod|x-markdown ) $}x
              or croak 'Incorrect content-type provided';
  
          $extra{headers}{'content-type'} = $type;
      }
  
      $url = $self->base_url . "/$url";
  
      my $result = $self->ua->get( $url, \%extra );
      $result->{'success'}
          or croak "Failed to fetch '$url': " . $result->{'reason'};
  
      return $result->{'content'};
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API::POD - POD information for MetaCPAN::API
  
  =head1 VERSION
  
  version 0.34
  
  =head1 DESCRIPTION
  
  This role provides MetaCPAN::API with fetching POD information about modules
  and distribution releases.
  
  =head1 METHODS
  
  =head2 pod
  
      my $result = $mcpan->pod( pod => 'Moose' );
  
      # or
      my $result = $mcpan->pod(
          author  => 'DOY',
          release => 'Moose-2.0201',
          path    => 'lib/Moose.pm',
      );
  
  Searches MetaCPAN for a module or a specific release and returns the POD.
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API_POD

$fatpacked{"MetaCPAN/API/Release.pm"} = <<'METACPAN_API_RELEASE';
  use strict;
  use warnings;
  package MetaCPAN::API::Release;
  BEGIN {
    $MetaCPAN::API::Release::VERSION = '0.34';
  }
  # ABSTRACT: Distribution and releases information for MetaCPAN::API
  
  use Carp;
  use Any::Moose 'Role';
  
  # /release/{distribution}
  # /release/{author}/{release}
  sub release {
      my $self  = shift;
      my %opts  = @_ ? @_ : ();
      my $url   = '';
      my $error = "Either provide 'distribution', or 'author' and 'release', " .
                  "or 'search'";
  
      %opts or croak $error;
  
      my %extra_opts = ();
  
      if ( defined ( my $dist = $opts{'distribution'} ) ) {
          $url = "release/$dist";
      } elsif (
          defined ( my $author  = $opts{'author'}  ) &&
          defined ( my $release = $opts{'release'} )
        ) {
          $url = "release/$author/$release";
      } elsif ( defined ( my $search_opts = $opts{'search'} ) ) {
          ref $search_opts && ref $search_opts eq 'HASH'
              or croak $error;
  
          %extra_opts = %{$search_opts};
          $url        = 'release/_search';
      } else {
          croak $error;
      }
  
      return $self->fetch( $url, %extra_opts );
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API::Release - Distribution and releases information for MetaCPAN::API
  
  =head1 VERSION
  
  version 0.34
  
  =head1 DESCRIPTION
  
  This role provides MetaCPAN::API with fetching information about distribution
  and releases.
  
  =head1 METHODS
  
  =head2 release
  
      my $result = $mcpan->release( distribution => 'Moose' );
  
      # or
      my $result = $mcpan->release( author => 'DOY', release => 'Moose-2.0001' );
  
  Searches MetaCPAN for a dist.
  
  You can do complex searches using 'search' parameter:
  
      # example lifted from MetaCPAN docs
      my $result = $mcpan->release(
          search => {
              author => "OALDERS AND ",
              filter => "status:latest",
              fields => "name",
              size   => 1,
          },
      );
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API_RELEASE

$fatpacked{"MetaCPAN/API/Source.pm"} = <<'METACPAN_API_SOURCE';
  use strict;
  use warnings;
  package MetaCPAN::API::Source;
  BEGIN {
    $MetaCPAN::API::Source::VERSION = '0.34';
  }
  # ABSTRACT: Source information for MetaCPAN::API
  
  use Carp;
  use Any::Moose 'Role';
  
  # /source/{author}/{release}/{path}
  sub source {
      my $self  = shift;
      my %opts  = @_ ? @_ : ();
      my $url   = '';
      my $error = "Provide 'author' and 'release' and 'path'";
  
      %opts or croak $error;
  
      if (
          defined ( my $author  = $opts{'author'}  ) &&
          defined ( my $release = $opts{'release'} ) &&
          defined ( my $path    = $opts{'path'}    )
        ) {
          $url = "source/$author/$release/$path";
      } else {
          croak $error;
      }
  
      $url = $self->base_url . "/$url";
  
      my $result = $self->ua->get($url);
      $result->{'success'}
          or croak "Failed to fetch '$url': " . $result->{'reason'};
  
      return $result->{'content'};
  }
  
  1;
  
  
  
  =pod
  
  =head1 NAME
  
  MetaCPAN::API::Source - Source information for MetaCPAN::API
  
  =head1 VERSION
  
  version 0.34
  
  =head1 DESCRIPTION
  
  This role provides MetaCPAN::API with fetching of source files.
  
  =head1 METHODS
  
  =head2 pod
  
      my $text = $mcpan->pod(
          author  => 'DOY',
          release => 'Moose-2.0201',
          path    => 'lib/Moose.pm',
      );
  
  Searches MetaCPAN for a module or a specific release and returns the plain
  source.
  
  =head1 AUTHOR
  
    Renee Baecker <module@renee-baecker.de>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Renee Baecker.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =head1 AUTHOR
  
    Sawyer X <xsawyerx@cpan.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Sawyer X.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
METACPAN_API_SOURCE

$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA';
  # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
  # vim:ts=8:sw=2:et:sta:sts=2
  package Module::Metadata;
  
  # Adapted from Perl-licensed code originally distributed with
  # Module-Build by Ken Williams
  
  # This module provides routines to gather information about
  # perl modules (assuming this may be expanded in the distant
  # parrot future to look at other types of modules).
  
  use strict;
  use vars qw($VERSION);
  $VERSION = '1.000007';
  $VERSION = eval $VERSION;
  
  use File::Spec;
  use IO::File;
  use version 0.87;
  BEGIN {
    if ($INC{'Log/Contextual.pm'}) {
      Log::Contextual->import('log_info');
    } else {
      *log_info = sub (&) { warn $_[0]->() };
    }
  }
  use File::Find qw(find);
  
  my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
  
  my $PKG_REGEXP  = qr{   # match a package declaration
    ^[\s\{;]*             # intro chars on a line
    package               # the word 'package'
    \s+                   # whitespace
    ([\w:]+)              # a package name
    \s*                   # optional whitespace
    ($V_NUM_REGEXP)?        # optional version number
    \s*                   # optional whitesapce
    [;\{]                 # semicolon line terminator or block start (since 5.16)
  }x;
  
  my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
    ([\$*])         # sigil - $ or *
    (
      (             # optional leading package name
        (?:::|\')?  # possibly starting like just :: (  la $::VERSION)
        (?:\w+(?:::|\'))*  # Foo::Bar:: ...
      )?
      VERSION
    )\b
  }x;
  
  my $VERS_REGEXP = qr{ # match a VERSION definition
    (?:
      \(\s*$VARNAME_REGEXP\s*\) # with parens
    |
      $VARNAME_REGEXP           # without parens
    )
    \s*
    =[^=~]  # = but not ==, nor =~
  }x;
  
  
  sub new_from_file {
    my $class    = shift;
    my $filename = File::Spec->rel2abs( shift );
  
    return undef unless defined( $filename ) && -f $filename;
    return $class->_init(undef, $filename, @_);
  }
  
  sub new_from_handle {
    my $class    = shift;
    my $handle   = shift;
    my $filename = shift;
    return undef unless defined($handle) && defined($filename);
    $filename = File::Spec->rel2abs( $filename );
  
    return $class->_init(undef, $filename, @_, handle => $handle);
  
  }
  
  
  sub new_from_module {
    my $class   = shift;
    my $module  = shift;
    my %props   = @_;
  
    $props{inc} ||= \@INC;
    my $filename = $class->find_module_by_name( $module, $props{inc} );
    return undef unless defined( $filename ) && -f $filename;
    return $class->_init($module, $filename, %props);
  }
  
  {
    
    my $compare_versions = sub {
      my ($v1, $op, $v2) = @_;
      $v1 = version->new($v1)
        unless UNIVERSAL::isa($v1,'version');
    
      my $eval_str = "\$v1 $op \$v2";
      my $result   = eval $eval_str;
      log_info { "error comparing versions: '$eval_str' $@" } if $@;
    
      return $result;
    };
  
    my $normalize_version = sub {
      my ($version) = @_;
      if ( $version =~ /[=<>!,]/ ) { # logic, not just version
        # take as is without modification
      }
      elsif ( ref $version eq 'version' ) { # version objects
        $version = $version->is_qv ? $version->normal : $version->stringify;
      }
      elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
        # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
        $version = "v$version";
      }
      else {
        # leave alone
      }
      return $version;
    };
  
    # separate out some of the conflict resolution logic
  
    my $resolve_module_versions = sub {
      my $packages = shift;
    
      my( $file, $version );
      my $err = '';
        foreach my $p ( @$packages ) {
          if ( defined( $p->{version} ) ) {
    	if ( defined( $version ) ) {
     	  if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
    	    $err .= "  $p->{file} ($p->{version})\n";
    	  } else {
    	    # same version declared multiple times, ignore
    	  }
    	} else {
    	  $file    = $p->{file};
    	  $version = $p->{version};
    	}
          }
          $file ||= $p->{file} if defined( $p->{file} );
        }
    
      if ( $err ) {
        $err = "  $file ($version)\n" . $err;
      }
    
      my %result = (
        file    => $file,
        version => $version,
        err     => $err
      );
    
      return \%result;
    };
  
    sub package_versions_from_directory {
      my ( $class, $dir, $files ) = @_;
  
      my @files;
  
      if ( $files ) {
        @files = @$files;
      } else {
        find( {
          wanted => sub {
            push @files, $_ if -f $_ && /\.pm$/;
          },
          no_chdir => 1,
        }, $dir );
      }
  
      # First, we enumerate all packages & versions,
      # separating into primary & alternative candidates
      my( %prime, %alt );
      foreach my $file (@files) {
        my $mapped_filename = File::Spec->abs2rel( $file, $dir );
        my @path = split( /\//, $mapped_filename );
        (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
    
        my $pm_info = $class->new_from_file( $file );
    
        foreach my $package ( $pm_info->packages_inside ) {
          next if $package eq 'main';  # main can appear numerous times, ignore
          next if $package eq 'DB';    # special debugging package, ignore
          next if grep /^_/, split( /::/, $package ); # private package, ignore
    
          my $version = $pm_info->version( $package );
    
          if ( $package eq $prime_package ) {
            if ( exists( $prime{$package} ) ) {
              die "Unexpected conflict in '$package'; multiple versions found.\n";
            } else {
              $prime{$package}{file} = $mapped_filename;
              $prime{$package}{version} = $version if defined( $version );
            }
          } else {
            push( @{$alt{$package}}, {
                                      file    => $mapped_filename,
                                      version => $version,
                                     } );
          }
        }
      }
    
      # Then we iterate over all the packages found above, identifying conflicts
      # and selecting the "best" candidate for recording the file & version
      # for each package.
      foreach my $package ( keys( %alt ) ) {
        my $result = $resolve_module_versions->( $alt{$package} );
    
        if ( exists( $prime{$package} ) ) { # primary package selected
    
          if ( $result->{err} ) {
    	# Use the selected primary package, but there are conflicting
    	# errors among multiple alternative packages that need to be
    	# reported
            log_info {
    	    "Found conflicting versions for package '$package'\n" .
    	    "  $prime{$package}{file} ($prime{$package}{version})\n" .
    	    $result->{err}
            };
    
          } elsif ( defined( $result->{version} ) ) {
    	# There is a primary package selected, and exactly one
    	# alternative package
    
    	if ( exists( $prime{$package}{version} ) &&
    	     defined( $prime{$package}{version} ) ) {
    	  # Unless the version of the primary package agrees with the
    	  # version of the alternative package, report a conflict
    	  if ( $compare_versions->(
                   $prime{$package}{version}, '!=', $result->{version}
                 )
               ) {
  
              log_info {
                "Found conflicting versions for package '$package'\n" .
    	      "  $prime{$package}{file} ($prime{$package}{version})\n" .
    	      "  $result->{file} ($result->{version})\n"
              };
    	  }
    
    	} else {
    	  # The prime package selected has no version so, we choose to
    	  # use any alternative package that does have a version
    	  $prime{$package}{file}    = $result->{file};
    	  $prime{$package}{version} = $result->{version};
    	}
    
          } else {
    	# no alt package found with a version, but we have a prime
    	# package so we use it whether it has a version or not
          }
    
        } else { # No primary package was selected, use the best alternative
    
          if ( $result->{err} ) {
            log_info {
              "Found conflicting versions for package '$package'\n" .
    	    $result->{err}
            };
          }
    
          # Despite possible conflicting versions, we choose to record
          # something rather than nothing
          $prime{$package}{file}    = $result->{file};
          $prime{$package}{version} = $result->{version}
    	  if defined( $result->{version} );
        }
      }
    
      # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
      # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
      for (grep defined $_->{version}, values %prime) {
        $_->{version} = $normalize_version->( $_->{version} );
      }
    
      return \%prime;
    }
  } 
    
  
  sub _init {
    my $class    = shift;
    my $module   = shift;
    my $filename = shift;
    my %props = @_;
  
    my $handle = delete $props{handle};
    my( %valid_props, @valid_props );
    @valid_props = qw( collect_pod inc );
    @valid_props{@valid_props} = delete( @props{@valid_props} );
    warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
  
    my %data = (
      module       => $module,
      filename     => $filename,
      version      => undef,
      packages     => [],
      versions     => {},
      pod          => {},
      pod_headings => [],
      collect_pod  => 0,
  
      %valid_props,
    );
  
    my $self = bless(\%data, $class);
  
    if ( $handle ) {
      $self->_parse_fh($handle);
    }
    else {
      $self->_parse_file();
    }
  
    unless($self->{module} and length($self->{module})) {
      my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
      if($f =~ /\.pm$/) {
        $f =~ s/\..+$//;
        my @candidates = grep /$f$/, @{$self->{packages}};
        $self->{module} = shift(@candidates); # punt
      }
      else {
        if(grep /main/, @{$self->{packages}}) {
          $self->{module} = 'main';
        }
        else {
          $self->{module} = $self->{packages}[0] || '';
        }
      }
    }
  
    $self->{version} = $self->{versions}{$self->{module}}
        if defined( $self->{module} );
  
    return $self;
  }
  
  # class method
  sub _do_find_module {
    my $class   = shift;
    my $module  = shift || die 'find_module_by_name() requires a package name';
    my $dirs    = shift || \@INC;
  
    my $file = File::Spec->catfile(split( /::/, $module));
    foreach my $dir ( @$dirs ) {
      my $testfile = File::Spec->catfile($dir, $file);
      return [ File::Spec->rel2abs( $testfile ), $dir ]
  	if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
      return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
  	if -e "$testfile.pm";
    }
    return;
  }
  
  # class method
  sub find_module_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[0];
  }
  
  # class method
  sub find_module_dir_by_name {
    my $found = shift()->_do_find_module(@_) or return;
    return $found->[1];
  }
  
  
  # given a line of perl code, attempt to parse it if it looks like a
  # $VERSION assignment, returning sigil, full name, & package name
  sub _parse_version_expression {
    my $self = shift;
    my $line = shift;
  
    my( $sig, $var, $pkg );
    if ( $line =~ $VERS_REGEXP ) {
      ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
      if ( $pkg ) {
        $pkg = ($pkg eq '::') ? 'main' : $pkg;
        $pkg =~ s/::$//;
      }
    }
  
    return ( $sig, $var, $pkg );
  }
  
  sub _parse_file {
    my $self = shift;
  
    my $filename = $self->{filename};
    my $fh = IO::File->new( $filename )
      or die( "Can't open '$filename': $!" );
  
    $self->_parse_fh($fh);
  }
  
  sub _parse_fh {
    my ($self, $fh) = @_;
  
    my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
    my( @pkgs, %vers, %pod, @pod );
    my $pkg = 'main';
    my $pod_sect = '';
    my $pod_data = '';
  
    while (defined( my $line = <$fh> )) {
      my $line_num = $.;
  
      chomp( $line );
      next if $line =~ /^\s*#/;
  
      $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
  
      # Would be nice if we could also check $in_string or something too
      last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
  
      if ( $in_pod || $line =~ /^=cut/ ) {
  
        if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
  	push( @pod, $1 );
  	if ( $self->{collect_pod} && length( $pod_data ) ) {
            $pod{$pod_sect} = $pod_data;
            $pod_data = '';
          }
  	$pod_sect = $1;
  
  
        } elsif ( $self->{collect_pod} ) {
  	$pod_data .= "$line\n";
  
        }
  
      } else {
  
        $pod_sect = '';
        $pod_data = '';
  
        # parse $line to see if it's a $VERSION declaration
        my( $vers_sig, $vers_fullname, $vers_pkg ) =
  	  $self->_parse_version_expression( $line );
  
        if ( $line =~ $PKG_REGEXP ) {
          $pkg = $1;
          push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
          $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
          $need_vers = defined $2 ? 0 : 1;
  
        # VERSION defined with full package spec, i.e. $Module::VERSION
        } elsif ( $vers_fullname && $vers_pkg ) {
  	push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
  	$need_vers = 0 if $vers_pkg eq $pkg;
  
  	unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
  	  $vers{$vers_pkg} =
  	    $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  	} else {
  	  # Warn unless the user is using the "$VERSION = eval
  	  # $VERSION" idiom (though there are probably other idioms
  	  # that we should watch out for...)
  	  warn <<"EOM" unless $line =~ /=\s*eval/;
  Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
  ignoring subsequent declaration on line $line_num.
  EOM
  	}
  
        # first non-comment line in undeclared package main is VERSION
        } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
  	$need_vers = 0;
  	my $v =
  	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  	$vers{$pkg} = $v;
  	push( @pkgs, 'main' );
  
        # first non-comment line in undeclared package defines package main
        } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
  	$need_vers = 1;
  	$vers{main} = '';
  	push( @pkgs, 'main' );
  
        # only keep if this is the first $VERSION seen
        } elsif ( $vers_fullname && $need_vers ) {
  	$need_vers = 0;
  	my $v =
  	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  
  
  	unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
  	  $vers{$pkg} = $v;
  	} else {
  	  warn <<"EOM";
  Package '$pkg' already declared with version '$vers{$pkg}'
  ignoring new version '$v' on line $line_num.
  EOM
  	}
  
        }
  
      }
  
    }
  
    if ( $self->{collect_pod} && length($pod_data) ) {
      $pod{$pod_sect} = $pod_data;
    }
  
    $self->{versions} = \%vers;
    $self->{packages} = \@pkgs;
    $self->{pod} = \%pod;
    $self->{pod_headings} = \@pod;
  }
  
  {
  my $pn = 0;
  sub _evaluate_version_line {
    my $self = shift;
    my( $sigil, $var, $line ) = @_;
  
    # Some of this code came from the ExtUtils:: hierarchy.
  
    # We compile into $vsub because 'use version' would cause
    # compiletime/runtime issues with local()
    my $vsub;
    $pn++; # everybody gets their own package
    my $eval = qq{BEGIN { q#  Hide from _packages_inside()
      #; package Module::Metadata::_version::p$pn;
      use version;
      no strict;
  
        \$vsub = sub {
          local $sigil$var;
          \$$var=undef;
          $line;
          \$$var
        };
    }};
  
    local $^W;
    # Try to get the $VERSION
    eval $eval;
    # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
    # installed, so we need to hunt in ./lib for it
    if ( $@ =~ /Can't locate/ && -d 'lib' ) {
      local @INC = ('lib',@INC);
      eval $eval;
    }
    warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
      if $@;
    (ref($vsub) eq 'CODE') or
      die "failed to build version sub for $self->{filename}";
    my $result = eval { $vsub->() };
    die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
      if $@;
  
    # Upgrade it into a version object
    my $version = eval { _dwim_version($result) };
  
    die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
      unless defined $version; # "0" is OK!
  
    return $version;
  }
  }
  
  # Try to DWIM when things fail the lax version test in obvious ways
  {
    my @version_prep = (
      # Best case, it just works
      sub { return shift },
  
      # If we still don't have a version, try stripping any
      # trailing junk that is prohibited by lax rules
      sub {
        my $v = shift;
        $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
        return $v;
      },
  
      # Activestate apparently creates custom versions like '1.23_45_01', which
      # cause version.pm to think it's an invalid alpha.  So check for that
      # and strip them
      sub {
        my $v = shift;
        my $num_dots = () = $v =~ m{(\.)}g;
        my $num_unders = () = $v =~ m{(_)}g;
        my $leading_v = substr($v,0,1) eq 'v';
        if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
          $v =~ s{_}{}g;
          $num_unders = () = $v =~ m{(_)}g;
        }
        return $v;
      },
  
      # Worst case, try numifying it like we would have before version objects
      sub {
        my $v = shift;
        no warnings 'numeric';
        return 0 + $v;
      },
  
    );
  
    sub _dwim_version {
      my ($result) = shift;
  
      return $result if ref($result) eq 'version';
  
      my ($version, $error);
      for my $f (@version_prep) {
        $result = $f->($result);
        $version = eval { version->new($result) };
        $error ||= $@ if $@; # capture first failure
        last if defined $version;
      }
  
      die $error unless defined $version;
  
      return $version;
    }
  }
  
  ############################################################
  
  # accessors
  sub name            { $_[0]->{module}           }
  
  sub filename        { $_[0]->{filename}         }
  sub packages_inside { @{$_[0]->{packages}}      }
  sub pod_inside      { @{$_[0]->{pod_headings}}  }
  sub contains_pod    { $#{$_[0]->{pod_headings}} }
  
  sub version {
      my $self = shift;
      my $mod  = shift || $self->{module};
      my $vers;
      if ( defined( $mod ) && length( $mod ) &&
  	 exists( $self->{versions}{$mod} ) ) {
  	return $self->{versions}{$mod};
      } else {
  	return undef;
      }
  }
  
  sub pod {
      my $self = shift;
      my $sect = shift;
      if ( defined( $sect ) && length( $sect ) &&
  	 exists( $self->{pod}{$sect} ) ) {
  	return $self->{pod}{$sect};
      } else {
  	return undef;
      }
  }
  
  1;
  
  =head1 NAME
  
  Module::Metadata - Gather package and POD information from perl module files
  
  =head1 SYNOPSIS
  
    use Module::Metadata;
  
    # information about a .pm file
    my $info = Module::Metadata->new_from_file( $file );
    my $version = $info->version;
  
    # information about a directory full of .pm files
    my $provides =
      Module::Metadata->package_versions_from_directory('lib');
  
  =head1 DESCRIPTION
  
  This module provides a standard way to gather metadata about a .pm file
  without executing unsafe code.
  
  =head1 USAGE
  
  =head2 Class methods
  
  =over 4
  
  =item C<< new_from_file($filename, collect_pod => 1) >>
  
  Construct a C<Module::Metadata> object given the path to a file. Takes an
  optional argument C<collect_pod> which is a boolean that determines whether POD
  data is collected and stored for reference. POD data is not collected by
  default. POD headings are always collected.  Returns undef if the filename
  does not exist.
  
  =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
  
  This works just like C<new_from_file>, except that a handle can be provided
  as the first argument.  Note that there is no validation to confirm that the
  handle is a handle or something that can act like one.  Passing something that
  isn't a handle will cause a exception when trying to read from it.  The
  C<filename> argument is mandatory or undef will be returned.
  
  =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
  
  Construct a C<Module::Metadata> object given a module or package name. In addition
  to accepting the C<collect_pod> argument as described above, this
  method accepts a C<inc> argument which is a reference to an array of
  of directories to search for the module. If none are given, the
  default is @INC.  Returns undef if the module cannot be found.
  
  =item C<< find_module_by_name($module, \@dirs) >>
  
  Returns the path to a module given the module or package name. A list
  of directories can be passed in as an optional parameter, otherwise
  @INC is searched.
  
  Can be called as either an object or a class method.
  
  =item C<< find_module_dir_by_name($module, \@dirs) >>
  
  Returns the entry in C<@dirs> (or C<@INC> by default) that contains
  the module C<$module>. A list of directories can be passed in as an
  optional parameter, otherwise @INC is searched.
  
  Can be called as either an object or a class method.
  
  =item C<< package_versions_from_directory($dir, \@files?) >>
  
  Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
  for those files in C<$dir> - and reads each file for packages and versions,
  returning a hashref of the form:
  
    {
      'Package::Name' => {
        version => '0.123',
        file => 'Package/Name.pm'
      },
      'OtherPackage::Name' => ...
    }
  
  =item C<< log_info (internal) >>
  
  Used internally to perform logging; imported from Log::Contextual if
  Log::Contextual has already been loaded, otherwise simply calls warn.
  
  =back
  
  =head2 Object methods
  
  =over 4
  
  =item C<< name() >>
  
  Returns the name of the package represented by this module. If there
  are more than one packages, it makes a best guess based on the
  filename. If it's a script (i.e. not a *.pm) the package name is
  'main'.
  
  =item C<< version($package) >>
  
  Returns the version as defined by the $VERSION variable for the
  package as returned by the C<name> method if no arguments are
  given. If given the name of a package it will attempt to return the
  version of that package if it is specified in the file.
  
  =item C<< filename() >>
  
  Returns the absolute path to the file.
  
  =item C<< packages_inside() >>
  
  Returns a list of packages.
  
  =item C<< pod_inside() >>
  
  Returns a list of POD sections.
  
  =item C<< contains_pod() >>
  
  Returns true if there is any POD in the file.
  
  =item C<< pod($section) >>
  
  Returns the POD data in the given section.
  
  =back
  
  =head1 AUTHOR
  
  Original code from Module::Build::ModuleInfo by Ken Williams
  <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
  
  Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
  assistance from David Golden (xdg) <dagolden@cpan.org>.
  
  =head1 COPYRIGHT
  
  Original code Copyright (c) 2001-2011 Ken Williams.
  Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
  All rights reserved.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
MODULE_METADATA

$fatpacked{"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.
  
  =cut
  
  package Module::Runtime;
  
  { use 5.006; }
  use warnings;
  use strict;
  
  use Params::Classify 0.000 qw(is_string);
  
  our $VERSION = "0.011";
  
  use parent "Exporter";
  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
  );
  
  =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.
  The rule for this, precisely, is: the string must
  consist of one or more segments separated by C<::>; each segment must
  consist of one or more identifier characters (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.
  Only ASCII characters are permitted; Perl's handling of non-ASCII
  characters in source code is inconsistent.
  C<'> separators are not permitted.
  
  =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
  
  sub require_module($) {
  	# Explicit scalar() here works around a Perl core bug, present
  	# in Perl 5.8 and 5.10, which allowed a require() in return
  	# position to pass a non-scalar context through to file scope
  	# of the required file.  This breaks some modules.  require()
  	# in any other position, where its op flags determine context
  	# statically, doesn't have this problem, because the op flags
  	# are forced to scalar.
  	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 but wasn't detected correctly,
  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_notional_filename($name)); };
  	die $@ if $@ ne "" && $@ !~ /\A
  		Can't\ locate\ .+\ at
  		\ \Q@{[__FILE__]}\E\ line\ \Q@{[__LINE__-1]}\E
  	/xs;
  	$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<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
  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{"Net/HTTP.pm"} = <<'NET_HTTP';
  package Net::HTTP;
  
  use strict;
  use vars qw($VERSION @ISA $SOCKET_CLASS);
  
  $VERSION = "6.01";
  unless ($SOCKET_CLASS) {
      eval { require IO::Socket::INET } || require IO::Socket;
      $SOCKET_CLASS = "IO::Socket::INET";
  }
  require Net::HTTP::Methods;
  require Carp;
  
  @ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods');
  
  sub new {
      my $class = shift;
      Carp::croak("No Host option provided") unless @_;
      $class->SUPER::new(@_);
  }
  
  sub configure {
      my($self, $cnf) = @_;
      $self->http_configure($cnf);
  }
  
  sub http_connect {
      my($self, $cnf) = @_;
      $self->SUPER::configure($cnf);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::HTTP - Low-level HTTP connection (client)
  
  =head1 SYNOPSIS
  
   use Net::HTTP;
   my $s = Net::HTTP->new(Host => "www.perl.com") || die $@;
   $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
   my($code, $mess, %h) = $s->read_response_headers;
  
   while (1) {
      my $buf;
      my $n = $s->read_entity_body($buf, 1024);
      die "read failed: $!" unless defined $n;
      last unless $n;
      print $buf;
   }
  
  =head1 DESCRIPTION
  
  The C<Net::HTTP> class is a low-level HTTP client.  An instance of the
  C<Net::HTTP> class represents a connection to an HTTP server.  The
  HTTP protocol is described in RFC 2616.  The C<Net::HTTP> class
  supports C<HTTP/1.0> and C<HTTP/1.1>.
  
  C<Net::HTTP> is a sub-class of C<IO::Socket::INET>.  You can mix the
  methods described below with reading and writing from the socket
  directly.  This is not necessary a good idea, unless you know what you
  are doing.
  
  The following methods are provided (in addition to those of
  C<IO::Socket::INET>):
  
  =over
  
  =item $s = Net::HTTP->new( %options )
  
  The C<Net::HTTP> constructor method takes the same options as
  C<IO::Socket::INET>'s as well as these:
  
    Host:            Initial host attribute value
    KeepAlive:       Initial keep_alive attribute value
    SendTE:          Initial send_te attribute_value
    HTTPVersion:     Initial http_version attribute value
    PeerHTTPVersion: Initial peer_http_version attribute value
    MaxLineLength:   Initial max_line_length attribute value
    MaxHeaderLines:  Initial max_header_lines attribute value
  
  The C<Host> option is also the default for C<IO::Socket::INET>'s
  C<PeerAddr>.  The C<PeerPort> defaults to 80 if not provided.
  
  The C<Listen> option provided by C<IO::Socket::INET>'s constructor
  method is not allowed.
  
  If unable to connect to the given HTTP server then the constructor
  returns C<undef> and $@ contains the reason.  After a successful
  connect, a C<Net:HTTP> object is returned.
  
  =item $s->host
  
  Get/set the default value of the C<Host> header to send.  The $host
  must not be set to an empty string (or C<undef>) for HTTP/1.1.
  
  =item $s->keep_alive
  
  Get/set the I<keep-alive> value.  If this value is TRUE then the
  request will be sent with headers indicating that the server should try
  to keep the connection open so that multiple requests can be sent.
  
  The actual headers set will depend on the value of the C<http_version>
  and C<peer_http_version> attributes.
  
  =item $s->send_te
  
  Get/set the a value indicating if the request will be sent with a "TE"
  header to indicate the transfer encodings that the server can choose to
  use.  The list of encodings announced as accepted by this client depends
  on availability of the following modules: C<Compress::Raw::Zlib> for
  I<deflate>, and C<IO::Compress::Gunzip> for I<gzip>.
  
  =item $s->http_version
  
  Get/set the HTTP version number that this client should announce.
  This value can only be set to "1.0" or "1.1".  The default is "1.1".
  
  =item $s->peer_http_version
  
  Get/set the protocol version number of our peer.  This value will
  initially be "1.0", but will be updated by a successful
  read_response_headers() method call.
  
  =item $s->max_line_length
  
  Get/set a limit on the length of response line and response header
  lines.  The default is 8192.  A value of 0 means no limit.
  
  =item $s->max_header_length
  
  Get/set a limit on the number of header lines that a response can
  have.  The default is 128.  A value of 0 means no limit.
  
  =item $s->format_request($method, $uri, %headers, [$content])
  
  Format a request message and return it as a string.  If the headers do
  not include a C<Host> header, then a header is inserted with the value
  of the C<host> attribute.  Headers like C<Connection> and
  C<Keep-Alive> might also be added depending on the status of the
  C<keep_alive> attribute.
  
  If $content is given (and it is non-empty), then a C<Content-Length>
  header is automatically added unless it was already present.
  
  =item $s->write_request($method, $uri, %headers, [$content])
  
  Format and send a request message.  Arguments are the same as for
  format_request().  Returns true if successful.
  
  =item $s->format_chunk( $data )
  
  Returns the string to be written for the given chunk of data.  
  
  =item $s->write_chunk($data)
  
  Will write a new chunk of request entity body data.  This method
  should only be used if the C<Transfer-Encoding> header with a value of
  C<chunked> was sent in the request.  Note, writing zero-length data is
  a no-op.  Use the write_chunk_eof() method to signal end of entity
  body data.
  
  Returns true if successful.
  
  =item $s->format_chunk_eof( %trailers )
  
  Returns the string to be written for signaling EOF when a
  C<Transfer-Encoding> of C<chunked> is used.
  
  =item $s->write_chunk_eof( %trailers )
  
  Will write eof marker for chunked data and optional trailers.  Note
  that trailers should not really be used unless is was signaled
  with a C<Trailer> header.
  
  Returns true if successful.
  
  =item ($code, $mess, %headers) = $s->read_response_headers( %opts )
  
  Read response headers from server and return it.  The $code is the 3
  digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
  message that came with it.  Headers are then returned as key/value
  pairs.  Since key letter casing is not normalized and the same key can
  even occur multiple times, assigning these values directly to a hash
  is not wise.  Only the $code is returned if this method is called in
  scalar context.
  
  As a side effect this method updates the 'peer_http_version'
  attribute.
  
  Options might be passed in as key/value pairs.  There are currently
  only two options supported; C<laxed> and C<junk_out>.
  
  The C<laxed> option will make read_response_headers() more forgiving
  towards servers that have not learned how to speak HTTP properly.  The
  C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
  value.  The C<junk_out> option can be used to capture bad header lines
  when C<laxed> is enabled.  The value should be an array reference.
  Bad header lines will be pushed onto the array.
  
  The C<laxed> option must be specified in order to communicate with
  pre-HTTP/1.0 servers that don't describe the response outcome or the
  data they send back with a header block.  For these servers
  peer_http_version is set to "0.9" and this method returns (200,
  "Assumed OK").
  
  The method will raise an exception (die) if the server does not speak
  proper HTTP or if the C<max_line_length> or C<max_header_length>
  limits are reached.  If the C<laxed> option is turned on and
  C<max_line_length> and C<max_header_length> checks are turned off,
  then no exception will be raised and this method will always
  return a response code.
  
  =item $n = $s->read_entity_body($buf, $size);
  
  Reads chunks of the entity body content.  Basically the same interface
  as for read() and sysread(), but the buffer offset argument is not
  supported yet.  This method should only be called after a successful
  read_response_headers() call.
  
  The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
  could be returned this time, otherwise the number of bytes assigned
  to $buf.  The $buf is set to "" when the return value is -1.
  
  You normally want to retry this call if this function returns either
  -1 or C<undef> with C<$!> as EINTR or EAGAIN (see L<Errno>).  EINTR
  can happen if the application catches signals and EAGAIN can happen if
  you made the socket non-blocking.
  
  This method will raise exceptions (die) if the server does not speak
  proper HTTP.  This can only happen when reading chunked data.
  
  =item %headers = $s->get_trailers
  
  After read_entity_body() has returned 0 to indicate end of the entity
  body, you might call this method to pick up any trailers.
  
  =item $s->_rbuf
  
  Get/set the read buffer content.  The read_response_headers() and
  read_entity_body() methods use an internal buffer which they will look
  for data before they actually sysread more from the socket itself.  If
  they read too much, the remaining data will be left in this buffer.
  
  =item $s->_rbuf_length
  
  Returns the number of bytes in the read buffer.  This should always be
  the same as:
  
      length($s->_rbuf)
  
  but might be more efficient.
  
  =back
  
  =head1 SUBCLASSING
  
  The read_response_headers() and read_entity_body() will invoke the
  sysread() method when they need more data.  Subclasses might want to
  override this method to control how reading takes place.
  
  The object itself is a glob.  Subclasses should avoid using hash key
  names prefixed with C<http_> and C<io_>.
  
  =head1 SEE ALSO
  
  L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
  
  =head1 COPYRIGHT
  
  Copyright 2001-2003 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
NET_HTTP

$fatpacked{"Net/HTTP/Methods.pm"} = <<'NET_HTTP_METHODS';
  package Net::HTTP::Methods;
  
  require 5.005;  # 4-arg substr
  
  use strict;
  use vars qw($VERSION);
  
  $VERSION = "6.00";
  
  my $CRLF = "\015\012";   # "\r\n" is not portable
  
  *_bytes = defined(&utf8::downgrade) ?
      sub {
          unless (utf8::downgrade($_[0], 1)) {
              require Carp;
              Carp::croak("Wide character in HTTP request (bytes required)");
          }
          return $_[0];
      }
      :
      sub {
          return $_[0];
      };
  
  
  sub new {
      my $class = shift;
      unshift(@_, "Host") if @_ == 1;
      my %cnf = @_;
      require Symbol;
      my $self = bless Symbol::gensym(), $class;
      return $self->http_configure(\%cnf);
  }
  
  sub http_configure {
      my($self, $cnf) = @_;
  
      die "Listen option not allowed" if $cnf->{Listen};
      my $explict_host = (exists $cnf->{Host});
      my $host = delete $cnf->{Host};
      my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
      if (!$peer) {
  	die "No Host option provided" unless $host;
  	$cnf->{PeerAddr} = $peer = $host;
      }
  
      if ($peer =~ s,:(\d+)$,,) {
  	$cnf->{PeerPort} = int($1);  # always override
      }
      if (!$cnf->{PeerPort}) {
  	$cnf->{PeerPort} = $self->http_default_port;
      }
  
      if (!$explict_host) {
  	$host = $peer;
  	$host =~ s/:.*//;
      }
      if ($host && $host !~ /:/) {
  	my $p = $cnf->{PeerPort};
  	$host .= ":$p" if $p != $self->http_default_port;
      }
  
      $cnf->{Proto} = 'tcp';
  
      my $keep_alive = delete $cnf->{KeepAlive};
      my $http_version = delete $cnf->{HTTPVersion};
      $http_version = "1.1" unless defined $http_version;
      my $peer_http_version = delete $cnf->{PeerHTTPVersion};
      $peer_http_version = "1.0" unless defined $peer_http_version;
      my $send_te = delete $cnf->{SendTE};
      my $max_line_length = delete $cnf->{MaxLineLength};
      $max_line_length = 8*1024 unless defined $max_line_length;
      my $max_header_lines = delete $cnf->{MaxHeaderLines};
      $max_header_lines = 128 unless defined $max_header_lines;
  
      return undef unless $self->http_connect($cnf);
  
      $self->host($host);
      $self->keep_alive($keep_alive);
      $self->send_te($send_te);
      $self->http_version($http_version);
      $self->peer_http_version($peer_http_version);
      $self->max_line_length($max_line_length);
      $self->max_header_lines($max_header_lines);
  
      ${*$self}{'http_buf'} = "";
  
      return $self;
  }
  
  sub http_default_port {
      80;
  }
  
  # set up property accessors
  for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
      my $prop_name = "http_" . $method;
      no strict 'refs';
      *$method = sub {
  	my $self = shift;
  	my $old = ${*$self}{$prop_name};
  	${*$self}{$prop_name} = shift if @_;
  	return $old;
      };
  }
  
  # we want this one to be a bit smarter
  sub http_version {
      my $self = shift;
      my $old = ${*$self}{'http_version'};
      if (@_) {
  	my $v = shift;
  	$v = "1.0" if $v eq "1";  # float
  	unless ($v eq "1.0" or $v eq "1.1") {
  	    require Carp;
  	    Carp::croak("Unsupported HTTP version '$v'");
  	}
  	${*$self}{'http_version'} = $v;
      }
      $old;
  }
  
  sub format_request {
      my $self = shift;
      my $method = shift;
      my $uri = shift;
  
      my $content = (@_ % 2) ? pop : "";
  
      for ($method, $uri) {
  	require Carp;
  	Carp::croak("Bad method or uri") if /\s/ || !length;
      }
  
      push(@{${*$self}{'http_request_method'}}, $method);
      my $ver = ${*$self}{'http_version'};
      my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
  
      my @h;
      my @connection;
      my %given = (host => 0, "content-length" => 0, "te" => 0);
      while (@_) {
  	my($k, $v) = splice(@_, 0, 2);
  	my $lc_k = lc($k);
  	if ($lc_k eq "connection") {
  	    $v =~ s/^\s+//;
  	    $v =~ s/\s+$//;
  	    push(@connection, split(/\s*,\s*/, $v));
  	    next;
  	}
  	if (exists $given{$lc_k}) {
  	    $given{$lc_k}++;
  	}
  	push(@h, "$k: $v");
      }
  
      if (length($content) && !$given{'content-length'}) {
  	push(@h, "Content-Length: " . length($content));
      }
  
      my @h2;
      if ($given{te}) {
  	push(@connection, "TE") unless grep lc($_) eq "te", @connection;
      }
      elsif ($self->send_te && gunzip_ok()) {
  	# gzip is less wanted since the IO::Uncompress::Gunzip interface for
  	# it does not really allow chunked decoding to take place easily.
  	push(@h2, "TE: deflate,gzip;q=0.3");
  	push(@connection, "TE");
      }
  
      unless (grep lc($_) eq "close", @connection) {
  	if ($self->keep_alive) {
  	    if ($peer_ver eq "1.0") {
  		# from looking at Netscape's headers
  		push(@h2, "Keep-Alive: 300");
  		unshift(@connection, "Keep-Alive");
  	    }
  	}
  	else {
  	    push(@connection, "close") if $ver ge "1.1";
  	}
      }
      push(@h2, "Connection: " . join(", ", @connection)) if @connection;
      unless ($given{host}) {
  	my $h = ${*$self}{'http_host'};
  	push(@h2, "Host: $h") if $h;
      }
  
      return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
  }
  
  
  sub write_request {
      my $self = shift;
      $self->print($self->format_request(@_));
  }
  
  sub format_chunk {
      my $self = shift;
      return $_[0] unless defined($_[0]) && length($_[0]);
      return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
  }
  
  sub write_chunk {
      my $self = shift;
      return 1 unless defined($_[0]) && length($_[0]);
      $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
  }
  
  sub format_chunk_eof {
      my $self = shift;
      my @h;
      while (@_) {
  	push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
      }
      return _bytes(join("", "0$CRLF", @h, $CRLF));
  }
  
  sub write_chunk_eof {
      my $self = shift;
      $self->print($self->format_chunk_eof(@_));
  }
  
  
  sub my_read {
      die if @_ > 3;
      my $self = shift;
      my $len = $_[1];
      for (${*$self}{'http_buf'}) {
  	if (length) {
  	    $_[0] = substr($_, 0, $len, "");
  	    return length($_[0]);
  	}
  	else {
  	    return $self->sysread($_[0], $len);
  	}
      }
  }
  
  
  sub my_readline {
      my $self = shift;
      my $what = shift;
      for (${*$self}{'http_buf'}) {
  	my $max_line_length = ${*$self}{'http_max_line_length'};
  	my $pos;
  	while (1) {
  	    # find line ending
  	    $pos = index($_, "\012");
  	    last if $pos >= 0;
  	    die "$what line too long (limit is $max_line_length)"
  		if $max_line_length && length($_) > $max_line_length;
  
  	    # need to read more data to find a line ending
            READ:
              {
                  my $n = $self->sysread($_, 1024, length);
                  unless (defined $n) {
                      redo READ if $!{EINTR};
                      if ($!{EAGAIN}) {
                          # Hmm, we must be reading from a non-blocking socket
                          # XXX Should really wait until this socket is readable,...
                          select(undef, undef, undef, 0.1);  # but this will do for now
                          redo READ;
                      }
                      # if we have already accumulated some data let's at least
                      # return that as a line
                      die "$what read failed: $!" unless length;
                  }
                  unless ($n) {
                      return undef unless length;
                      return substr($_, 0, length, "");
                  }
              }
  	}
  	die "$what line too long ($pos; limit is $max_line_length)"
  	    if $max_line_length && $pos > $max_line_length;
  
  	my $line = substr($_, 0, $pos+1, "");
  	$line =~ s/(\015?\012)\z// || die "Assert";
  	return wantarray ? ($line, $1) : $line;
      }
  }
  
  
  sub _rbuf {
      my $self = shift;
      if (@_) {
  	for (${*$self}{'http_buf'}) {
  	    my $old;
  	    $old = $_ if defined wantarray;
  	    $_ = shift;
  	    return $old;
  	}
      }
      else {
  	return ${*$self}{'http_buf'};
      }
  }
  
  sub _rbuf_length {
      my $self = shift;
      return length ${*$self}{'http_buf'};
  }
  
  
  sub _read_header_lines {
      my $self = shift;
      my $junk_out = shift;
  
      my @headers;
      my $line_count = 0;
      my $max_header_lines = ${*$self}{'http_max_header_lines'};
      while (my $line = my_readline($self, 'Header')) {
  	if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
  	    push(@headers, $1, $2);
  	}
  	elsif (@headers && $line =~ s/^\s+//) {
  	    $headers[-1] .= " " . $line;
  	}
  	elsif ($junk_out) {
  	    push(@$junk_out, $line);
  	}
  	else {
  	    die "Bad header: '$line'\n";
  	}
  	if ($max_header_lines) {
  	    $line_count++;
  	    if ($line_count >= $max_header_lines) {
  		die "Too many header lines (limit is $max_header_lines)";
  	    }
  	}
      }
      return @headers;
  }
  
  
  sub read_response_headers {
      my($self, %opt) = @_;
      my $laxed = $opt{laxed};
  
      my($status, $eol) = my_readline($self, 'Status');
      unless (defined $status) {
  	die "Server closed connection without sending any data back";
      }
  
      my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
      if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
  	die "Bad response status line: '$status'" unless $laxed;
  	# assume HTTP/0.9
  	${*$self}{'http_peer_http_version'} = "0.9";
  	${*$self}{'http_status'} = "200";
  	substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
  	return 200 unless wantarray;
  	return (200, "Assumed OK");
      };
  
      ${*$self}{'http_peer_http_version'} = $peer_ver;
      ${*$self}{'http_status'} = $code;
  
      my $junk_out;
      if ($laxed) {
  	$junk_out = $opt{junk_out} || [];
      }
      my @headers = $self->_read_header_lines($junk_out);
  
      # pick out headers that read_entity_body might need
      my @te;
      my $content_length;
      for (my $i = 0; $i < @headers; $i += 2) {
  	my $h = lc($headers[$i]);
  	if ($h eq 'transfer-encoding') {
  	    my $te = $headers[$i+1];
  	    $te =~ s/^\s+//;
  	    $te =~ s/\s+$//;
  	    push(@te, $te) if length($te);
  	}
  	elsif ($h eq 'content-length') {
  	    # ignore bogus and overflow values
  	    if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
  		$content_length = $1;
  	    }
  	}
      }
      ${*$self}{'http_te'} = join(",", @te);
      ${*$self}{'http_content_length'} = $content_length;
      ${*$self}{'http_first_body'}++;
      delete ${*$self}{'http_trailers'};
      return $code unless wantarray;
      return ($code, $message, @headers);
  }
  
  
  sub read_entity_body {
      my $self = shift;
      my $buf_ref = \$_[0];
      my $size = $_[1];
      die "Offset not supported yet" if $_[2];
  
      my $chunked;
      my $bytes;
  
      if (${*$self}{'http_first_body'}) {
  	${*$self}{'http_first_body'} = 0;
  	delete ${*$self}{'http_chunked'};
  	delete ${*$self}{'http_bytes'};
  	my $method = shift(@{${*$self}{'http_request_method'}});
  	my $status = ${*$self}{'http_status'};
  	if ($method eq "HEAD") {
  	    # this response is always empty regardless of other headers
  	    $bytes = 0;
  	}
  	elsif (my $te = ${*$self}{'http_te'}) {
  	    my @te = split(/\s*,\s*/, lc($te));
  	    die "Chunked must be last Transfer-Encoding '$te'"
  		unless pop(@te) eq "chunked";
  
  	    for (@te) {
  		if ($_ eq "deflate" && inflate_ok()) {
  		    #require Compress::Raw::Zlib;
  		    my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
  		    die "Can't make inflator: $status" unless $i;
  		    $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
  		}
  		elsif ($_ eq "gzip" && gunzip_ok()) {
  		    #require IO::Uncompress::Gunzip;
  		    my @buf;
  		    $_ = sub {
  			push(@buf, $_[0]);
  			return "" unless $_[1];
  			my $input = join("", @buf);
  			my $output;
  			IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
  			    or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
  			return \$output;
  		    };
  		}
  		elsif ($_ eq "identity") {
  		    $_ = sub { $_[0] };
  		}
  		else {
  		    die "Can't handle transfer encoding '$te'";
  		}
  	    }
  
  	    @te = reverse(@te);
  
  	    ${*$self}{'http_te2'} = @te ? \@te : "";
  	    $chunked = -1;
  	}
  	elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
  	    $bytes = $content_length;
  	}
          elsif ($status =~ /^(?:1|[23]04)/) {
              # RFC 2616 says that these responses should always be empty
              # but that does not appear to be true in practice [RT#17907]
              $bytes = 0;
          }
  	else {
  	    # XXX Multi-Part types are self delimiting, but RFC 2616 says we
  	    # only has to deal with 'multipart/byteranges'
  
  	    # Read until EOF
  	}
      }
      else {
  	$chunked = ${*$self}{'http_chunked'};
  	$bytes   = ${*$self}{'http_bytes'};
      }
  
      if (defined $chunked) {
  	# The state encoded in $chunked is:
  	#   $chunked == 0:   read CRLF after chunk, then chunk header
          #   $chunked == -1:  read chunk header
  	#   $chunked > 0:    bytes left in current chunk to read
  
  	if ($chunked <= 0) {
  	    my $line = my_readline($self, 'Entity body');
  	    if ($chunked == 0) {
  		die "Missing newline after chunk data: '$line'"
  		    if !defined($line) || $line ne "";
  		$line = my_readline($self, 'Entity body');
  	    }
  	    die "EOF when chunk header expected" unless defined($line);
  	    my $chunk_len = $line;
  	    $chunk_len =~ s/;.*//;  # ignore potential chunk parameters
  	    unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
  		die "Bad chunk-size in HTTP response: $line";
  	    }
  	    $chunked = hex($1);
  	    if ($chunked == 0) {
  		${*$self}{'http_trailers'} = [$self->_read_header_lines];
  		$$buf_ref = "";
  
  		my $n = 0;
  		if (my $transforms = delete ${*$self}{'http_te2'}) {
  		    for (@$transforms) {
  			$$buf_ref = &$_($$buf_ref, 1);
  		    }
  		    $n = length($$buf_ref);
  		}
  
  		# in case somebody tries to read more, make sure we continue
  		# to return EOF
  		delete ${*$self}{'http_chunked'};
  		${*$self}{'http_bytes'} = 0;
  
  		return $n;
  	    }
  	}
  
  	my $n = $chunked;
  	$n = $size if $size && $size < $n;
  	$n = my_read($self, $$buf_ref, $n);
  	return undef unless defined $n;
  
  	${*$self}{'http_chunked'} = $chunked - $n;
  
  	if ($n > 0) {
  	    if (my $transforms = ${*$self}{'http_te2'}) {
  		for (@$transforms) {
  		    $$buf_ref = &$_($$buf_ref, 0);
  		}
  		$n = length($$buf_ref);
  		$n = -1 if $n == 0;
  	    }
  	}
  	return $n;
      }
      elsif (defined $bytes) {
  	unless ($bytes) {
  	    $$buf_ref = "";
  	    return 0;
  	}
  	my $n = $bytes;
  	$n = $size if $size && $size < $n;
  	$n = my_read($self, $$buf_ref, $n);
  	return undef unless defined $n;
  	${*$self}{'http_bytes'} = $bytes - $n;
  	return $n;
      }
      else {
  	# read until eof
  	$size ||= 8*1024;
  	return my_read($self, $$buf_ref, $size);
      }
  }
  
  sub get_trailers {
      my $self = shift;
      @{${*$self}{'http_trailers'} || []};
  }
  
  BEGIN {
  my $gunzip_ok;
  my $inflate_ok;
  
  sub gunzip_ok {
      return $gunzip_ok if defined $gunzip_ok;
  
      # Try to load IO::Uncompress::Gunzip.
      local $@;
      local $SIG{__DIE__};
      $gunzip_ok = 0;
  
      eval {
  	require IO::Uncompress::Gunzip;
  	$gunzip_ok++;
      };
  
      return $gunzip_ok;
  }
  
  sub inflate_ok {
      return $inflate_ok if defined $inflate_ok;
  
      # Try to load Compress::Raw::Zlib.
      local $@;
      local $SIG{__DIE__};
      $inflate_ok = 0;
  
      eval {
  	require Compress::Raw::Zlib;
  	$inflate_ok++;
      };
  
      return $inflate_ok;
  }
  
  } # BEGIN
  
  1;
NET_HTTP_METHODS

$fatpacked{"Net/HTTP/NB.pm"} = <<'NET_HTTP_NB';
  package Net::HTTP::NB;
  
  use strict;
  use vars qw($VERSION @ISA);
  
  $VERSION = "6.00";
  
  require Net::HTTP;
  @ISA=qw(Net::HTTP);
  
  sub sysread {
      my $self = $_[0];
      if (${*$self}{'httpnb_read_count'}++) {
  	${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
  	die "Multi-read\n";
      }
      my $buf;
      my $offset = $_[3] || 0;
      my $n = sysread($self, $_[1], $_[2], $offset);
      ${*$self}{'httpnb_save'} .= substr($_[1], $offset);
      return $n;
  }
  
  sub read_response_headers {
      my $self = shift;
      ${*$self}{'httpnb_read_count'} = 0;
      ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
      my @h = eval { $self->SUPER::read_response_headers(@_) };
      if ($@) {
  	return if $@ eq "Multi-read\n";
  	die;
      }
      return @h;
  }
  
  sub read_entity_body {
      my $self = shift;
      ${*$self}{'httpnb_read_count'} = 0;
      ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
      # XXX I'm not so sure this does the correct thing in case of
      # transfer-encoding tranforms
      my $n = eval { $self->SUPER::read_entity_body(@_); };
      if ($@) {
  	$_[0] = "";
  	return -1;
      }
      return $n;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::HTTP::NB - Non-blocking HTTP client
  
  =head1 SYNOPSIS
  
   use Net::HTTP::NB;
   my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@;
   $s->write_request(GET => "/");
  
   use IO::Select;
   my $sel = IO::Select->new($s);
  
   READ_HEADER: {
      die "Header timeout" unless $sel->can_read(10);
      my($code, $mess, %h) = $s->read_response_headers;
      redo READ_HEADER unless $code;
   }
  
   while (1) {
      die "Body timeout" unless $sel->can_read(10);
      my $buf;
      my $n = $s->read_entity_body($buf, 1024);
      last unless $n;
      print $buf;
   }
  
  =head1 DESCRIPTION
  
  Same interface as C<Net::HTTP> but it will never try multiple reads
  when the read_response_headers() or read_entity_body() methods are
  invoked.  This make it possible to multiplex multiple Net::HTTP::NB
  using select without risk blocking.
  
  If read_response_headers() did not see enough data to complete the
  headers an empty list is returned.
  
  If read_entity_body() did not see new entity data in its read
  the value -1 is returned.
  
  =head1 SEE ALSO
  
  L<Net::HTTP>
  
  =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.
  
  =cut
NET_HTTP_NB

$fatpacked{"Net/HTTPS.pm"} = <<'NET_HTTPS';
  package Net::HTTPS;
  
  use strict;
  use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
  
  $VERSION = "6.00";
  
  # Figure out which SSL implementation to use
  if ($SSL_SOCKET_CLASS) {
      # somebody already set it
  }
  elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) {
      unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) {
  	die "Bad socket class [$SSL_SOCKET_CLASS]";
      }
      eval "require $SSL_SOCKET_CLASS";
      die $@ if $@;
  }
  elsif ($IO::Socket::SSL::VERSION) {
      $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
  }
  elsif ($Net::SSL::VERSION) {
      $SSL_SOCKET_CLASS = "Net::SSL";
  }
  else {
      eval { require IO::Socket::SSL; };
      if ($@) {
  	my $old_errsv = $@;
  	eval {
  	    require Net::SSL;  # from Crypt-SSLeay
  	};
  	if ($@) {
  	    $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
  	    die $old_errsv . $@;
  	}
  	$SSL_SOCKET_CLASS = "Net::SSL";
      }
      else {
  	$SSL_SOCKET_CLASS = "IO::Socket::SSL";
      }
  }
  
  require Net::HTTP::Methods;
  
  @ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
  
  sub configure {
      my($self, $cnf) = @_;
      $self->http_configure($cnf);
  }
  
  sub http_connect {
      my($self, $cnf) = @_;
      if ($self->isa("Net::SSL")) {
  	if ($cnf->{SSL_verify_mode}) {
  	    if (my $f = $cnf->{SSL_ca_file}) {
  		$ENV{HTTPS_CA_FILE} = $f;
  	    }
  	    if (my $f = $cnf->{SSL_ca_path}) {
  		$ENV{HTTPS_CA_DIR} = $f;
  	    }
  	}
  	if ($cnf->{SSL_verifycn_scheme}) {
  	    $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0";
  	    return undef;
  	}
      }
      $self->SUPER::configure($cnf);
  }
  
  sub http_default_port {
      443;
  }
  
  # The underlying SSLeay classes fails to work if the socket is
  # placed in non-blocking mode.  This override of the blocking
  # method makes sure it stays the way it was created.
  sub blocking { }  # noop
  
  1;
NET_HTTPS

$fatpacked{"Package/DeprecationManager.pm"} = <<'PACKAGE_DEPRECATIONMANAGER';
  package Package::DeprecationManager;
  BEGIN {
    $Package::DeprecationManager::VERSION = '0.11';
  }
  
  use strict;
  use warnings;
  
  use Carp qw( croak );
  use List::MoreUtils qw( any );
  use Params::Util qw( _HASH0 );
  use Sub::Install;
  
  sub import {
      shift;
      my %args = @_;
  
      croak
          'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager'
          unless $args{-deprecations} && _HASH0( $args{-deprecations} );
  
      my %registry;
  
      my $import = _build_import( \%registry );
      my $warn = _build_warn( \%registry, $args{-deprecations}, $args{-ignore} );
  
      my $caller = caller();
  
      Sub::Install::install_sub(
          {
              code => $import,
              into => $caller,
              as   => 'import',
          }
      );
  
      Sub::Install::install_sub(
          {
              code => $warn,
              into => $caller,
              as   => 'deprecated',
          }
      );
  
      return;
  }
  
  sub _build_import {
      my $registry = shift;
  
      return sub {
          my $class = shift;
          my %args  = @_;
  
          $args{-api_version} ||= delete $args{-compatible};
  
          $registry->{ caller() } = $args{-api_version}
              if $args{-api_version};
  
          return;
      };
  }
  
  sub _build_warn {
      my $registry      = shift;
      my $deprecated_at = shift;
      my $ignore        = shift;
  
      my %ignore = map { $_ => 1 } grep { !ref } @{ $ignore || [] };
      my @ignore_res = grep {ref} @{ $ignore || [] };
  
      my %warned;
  
      return sub {
          my %args = @_ < 2 ? ( message => shift ) : @_;
  
          my ( $package, undef, undef, $sub ) = caller(1);
  
          my $skipped = 1;
  
          if ( @ignore_res || keys %ignore ) {
              while ( defined $package
                  && ( $ignore{$package} || any { $package =~ $_ } @ignore_res )
                  ) {
                  $package = caller( $skipped++ );
              }
          }
  
          $package = 'unknown package' unless defined $package;
  
          unless ( defined $args{feature} ) {
              $args{feature} = $sub;
          }
  
          my $compat_version = $registry->{$package};
  
          my $deprecated_at = $deprecated_at->{ $args{feature} };
  
          return
              if defined $compat_version
                  && defined $deprecated_at
                  && $compat_version lt $deprecated_at;
  
          my $msg;
          if ( defined $args{message} ) {
              $msg = $args{message};
          }
          else {
              $msg = "$args{feature} has been deprecated";
              $msg .= " since version $deprecated_at"
                  if defined $deprecated_at;
          }
  
          return if $warned{$package}{ $args{feature} }{$msg};
  
          $warned{$package}{ $args{feature} }{$msg} = 1;
  
          # We skip at least two levels. One for this anon sub, and one for the
          # sub calling it.
          local $Carp::CarpLevel = $Carp::CarpLevel + $skipped;
  
          Carp::cluck($msg);
      };
  }
  
  1;
  
  # ABSTRACT: Manage deprecation warnings for your distribution
  
  
  
  =pod
  
  =head1 NAME
  
  Package::DeprecationManager - Manage deprecation warnings for your distribution
  
  =head1 VERSION
  
  version 0.11
  
  =head1 SYNOPSIS
  
    package My::Class;
  
    use Package::DeprecationManager -deprecations => {
        'My::Class::foo' => '0.02',
        'My::Class::bar' => '0.05',
        'feature-X'      => '0.07',
    };
  
    sub foo {
        deprecated( 'Do not call foo!' );
  
        ...
    }
  
    sub bar {
        deprecated();
  
        ...
    }
  
    sub baz {
        my %args = @_;
  
        if ( $args{foo} ) {
            deprecated(
                message => ...,
                feature => 'feature-X',
            );
        }
    }
  
    package Other::Class;
  
    use My::Class -api_version => '0.04';
  
    My::Class->new()->foo(); # warns
    My::Class->new()->bar(); # does not warn
    My::Class->new()->far(); # does not warn again
  
  =head1 DESCRIPTION
  
  This module allows you to manage a set of deprecations for one or more modules.
  
  When you import C<Package::DeprecationManager>, you must provide a set of
  C<-deprecations> as a hash ref. The keys are "feature" names, and the values
  are the version when that feature was deprecated.
  
  In many cases, you can simply use the fully qualified name of a subroutine or
  method as the feature name. This works for cases where the whole subroutine is
  deprecated. However, the feature names can be any string. This is useful if
  you don't want to deprecate an entire subroutine, just a certain usage.
  
  You can also provide an optional array reference in the C<-ignore>
  parameter.
  
  The values to be ignored can be package names or regular expressions (made
  with C<qr//>).  Use this to ignore packages in your distribution that can
  appear on the call stack when a deprecated feature is used.
  
  As part of the import process, C<Package::DeprecationManager> will export two
  subroutines into its caller. It provides an C<import()> sub for the caller and a
  C<deprecated()> sub.
  
  The C<import()> sub allows callers of I<your> class to specify an C<-api_version>
  parameter. If this is supplied, then deprecation warnings are only issued for
  deprecations for api versions earlier than the one specified.
  
  You must call the C<deprecated()> sub in each deprecated subroutine. When
  called, it will issue a warning using C<Carp::cluck()>.
  
  The C<deprecated()> sub can be called in several ways. If you do not pass any
  arguments, it will generate an appropriate warning message. If you pass a
  single argument, this is used as the warning message.
  
  Finally, you can call it with named arguments. Currently, the only allowed
  names are C<message> and C<feature>. The C<feature> argument should correspond
  to the feature name passed in the C<-deprecations> hash.
  
  If you don't explicitly specify a feature, the C<deprecated()> sub uses
  C<caller()> to identify its caller, using its fully qualified subroutine name.
  
  A given deprecation warning is only issued once for a given package. This
  module tracks this based on both the feature name I<and> the error message
  itself. This means that if you provide severaldifferent error messages for the
  same feature, all of those errors will appear.
  
  =head1 BUGS
  
  Please report any bugs or feature requests to
  C<bug-package-deprecationmanager@rt.cpan.org>, or through the web interface at
  L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
  notified of progress on your bug as I make changes.
  
  =head1 DONATIONS
  
  If you'd like to thank me for the work I've done on this module, please
  consider making a "donation" to me via PayPal. I spend a lot of free time
  creating free software, and would appreciate any support you'd care to offer.
  
  Please note that B<I am not suggesting that you must do this> in order
  for me to continue working on this particular software. I will
  continue to do so, inasmuch as I have in the past, for as long as it
  interests me.
  
  Similarly, a donation made in this way will probably not make me work on this
  software much more, unless I get so many donations that I can consider working
  on free software full time, which seems unlikely at best.
  
  To donate, log into PayPal and send money to autarch@urth.org or use the
  button on this page: L<http://www.urth.org/~autarch/fs-donation.html>
  
  =head1 CREDITS
  
  The idea for this functionality and some of its implementation was originally
  created as L<Class::MOP::Deprecated> by Goro Fuji.
  
  =head1 AUTHOR
  
  Dave Rolsky <autarch@urth.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2011 by Dave Rolsky.
  
  This is free software, licensed under:
  
    The Artistic License 2.0 (GPL Compatible)
  
  =cut
  
  
  __END__
  
PACKAGE_DEPRECATIONMANAGER

$fatpacked{"Package/Stash.pm"} = <<'PACKAGE_STASH';
  package Package::Stash;
  {
    $Package::Stash::VERSION = '0.33';
  }
  use strict;
  use warnings;
  # ABSTRACT: routines for manipulating stashes
  
  our $IMPLEMENTATION;
  
  BEGIN {
      $IMPLEMENTATION = $ENV{PACKAGE_STASH_IMPLEMENTATION}
          if exists $ENV{PACKAGE_STASH_IMPLEMENTATION};
  
      my $err;
      if ($IMPLEMENTATION) {
          if (!eval "require Package::Stash::$IMPLEMENTATION; 1") {
              require Carp;
              Carp::croak("Could not load Package::Stash::$IMPLEMENTATION: $@");
          }
      }
      else {
          for my $impl ('XS', 'PP') {
              if (eval "require Package::Stash::$impl; 1;") {
                  $IMPLEMENTATION = $impl;
                  last;
              }
              else {
                  $err .= $@;
              }
          }
      }
  
      if (!$IMPLEMENTATION) {
          require Carp;
          Carp::croak("Could not find a suitable Package::Stash implementation: $err");
      }
  
      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});
      }
  }
  
  use Package::DeprecationManager -deprecations => {
      'Package::Stash::add_package_symbol'        => 0.14,
      'Package::Stash::remove_package_glob'       => 0.14,
      'Package::Stash::has_package_symbol'        => 0.14,
      'Package::Stash::get_package_symbol'        => 0.14,
      'Package::Stash::get_or_add_package_symbol' => 0.14,
      'Package::Stash::remove_package_symbol'     => 0.14,
      'Package::Stash::list_all_package_symbols'  => 0.14,
  };
  
  sub add_package_symbol {
      #deprecated('add_package_symbol is deprecated, please use add_symbol');
      shift->add_symbol(@_);
  }
  
  sub remove_package_glob {
      #deprecated('remove_package_glob is deprecated, please use remove_glob');
      shift->remove_glob(@_);
  }
  
  sub has_package_symbol {
      #deprecated('has_package_symbol is deprecated, please use has_symbol');
      shift->has_symbol(@_);
  }
  
  sub get_package_symbol {
      #deprecated('get_package_symbol is deprecated, please use get_symbol');
      shift->get_symbol(@_);
  }
  
  sub get_or_add_package_symbol {
      #deprecated('get_or_add_package_symbol is deprecated, please use get_or_add_symbol');
      shift->get_or_add_symbol(@_);
  }
  
  sub remove_package_symbol {
      #deprecated('remove_package_symbol is deprecated, please use remove_symbol');
      shift->remove_symbol(@_);
  }
  
  sub list_all_package_symbols {
      #deprecated('list_all_package_symbols is deprecated, please use list_all_symbols');
      shift->list_all_symbols(@_);
  }
  
  
  1;
  
  __END__
  =pod
  
  =head1 NAME
  
  Package::Stash - routines for manipulating stashes
  
  =head1 VERSION
  
  version 0.33
  
  =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 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.
  
  =for Pod::Coverage add_package_symbol
  remove_package_glob
  has_package_symbol
  get_package_symbol
  get_or_add_package_symbol
  remove_package_symbol
  list_all_package_symbols
  
  =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 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 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',
      },
      -also => [ qw(
          Dist::CheckConflicts
          Package::DeprecationManager
          Scalar::Util
      ) ],
  
  ;
  
  1;
PACKAGE_STASH_CONFLICTS

$fatpacked{"Package/Stash/PP.pm"} = <<'PACKAGE_STASH_PP';
  package Package::Stash::PP;
  {
    $Package::Stash::PP::VERSION = '0.33';
  }
  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);
  
  
  sub new {
      my $class = shift;
      my ($package) = @_;
  
      if (!defined($package) || (ref($package) && ref($package) ne 'HASH')) {
          confess "Package::Stash->new must be passed the name of the "
                . "package to access";
      }
      elsif (ref($package) eq 'HASH') {
          confess "The pure perl implementation of Package::Stash doesn't "
                . "currently support anonymous stashes. You should install "
                . "Package::Stash::XS";
      }
      elsif ($package !~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
          confess "$package is not a module name";
      }
  
      return bless {
          'package' => $package,
      }, $class;
  }
  
  sub name {
      confess "Can't call name as a class method"
          unless blessed($_[0]);
      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};
      }
  }
  
  {
      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);
  
      my $pkg = $self->name;
  
      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{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
          }
      }
  
      no strict 'refs';
      no warnings 'redefine', 'misc', 'prototype';
      *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
  }
  
  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 {
                  return B::svref_2object($entry_ref)->SV->isa('B::SV');
              }
          }
          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}) {
              if ($type eq 'ARRAY') {
                  if (BROKEN_ISA_ASSIGNMENT) {
                      $self->add_symbol(
                          $variable,
                          $name eq 'ISA' ? () : ([])
                      );
                  }
                  else {
                      $self->add_symbol($variable, []);
                  }
              }
              elsif ($type eq 'HASH') {
                  $self->add_symbol($variable, {});
              }
              elsif ($type eq 'SCALAR') {
                  $self->add_symbol($variable);
              }
              elsif ($type eq 'IO') {
                  $self->add_symbol($variable, Symbol::geniosym);
              }
              elsif ($type eq 'CODE') {
                  confess "Don't know how to vivify CODE variables";
              }
              else {
                  confess "Unknown type $type in vivication";
              }
          }
          else {
              return undef;
          }
      }
  
      my $entry_ref = \$namespace->{$name};
  
      if (ref($entry_ref) eq 'GLOB') {
          return *{$entry_ref}{$type};
      }
      else {
          if ($type eq 'CODE') {
              no strict 'refs';
              return \&{ $self->name . '::' . $name };
          }
          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 ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
          { sigil => '$', type => 'SCALAR', name => $name },
          { sigil => '@', type => 'ARRAY',  name => $name },
          { sigil => '%', type => 'HASH',   name => $name },
          { sigil => '&', type => 'CODE',   name => $name },
          { sigil => '',  type => 'IO',     name => $name },
      );
  
      my ($scalar, $array, $hash, $code, $io);
      if ($type eq 'SCALAR') {
          $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
          $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
          $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
          $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
      }
      elsif ($type eq 'ARRAY') {
          $scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
          $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
          $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
          $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
      }
      elsif ($type eq 'HASH') {
          $scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
          $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
          $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
          $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
      }
      elsif ($type eq 'CODE') {
          $scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
          $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
          $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
          $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
      }
      elsif ($type eq 'IO') {
          $scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
          $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
          $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
          $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
      }
      else {
          confess "This should never ever ever happen";
      }
  
      $self->remove_glob($name);
  
      $self->add_symbol($scalar_desc => $scalar) if defined $scalar;
      $self->add_symbol($array_desc  => $array)  if defined $array;
      $self->add_symbol($hash_desc   => $hash)   if defined $hash;
      $self->add_symbol($code_desc   => $code)   if defined $code;
      $self->add_symbol($io_desc     => $io)     if defined $io;
  }
  
  sub list_all_symbols {
      my ($self, $type_filter) = @_;
  
      my $namespace = $self->namespace;
      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 {
              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.33
  
  =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 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 SEE ALSO
  
  =over 4
  
  =item * L<Class::MOP::Package>
  
  This module is a factoring out of code that used to live here
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 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{"Sub/Exporter.pm"} = <<'SUB_EXPORTER';
  use 5.006;
  use strict;
  use warnings;
  package Sub::Exporter;
  
  use Carp ();
  use Data::OptList ();
  use Params::Util ();
  use Sub::Install 0.92 ();
  
  =head1 NAME
  
  Sub::Exporter - a sophisticated exporter for custom-built routines
  
  =head1 VERSION
  
  version 0.982
  
  =cut
  
  our $VERSION = '0.982';
  
  =head1 SYNOPSIS
  
  Sub::Exporter must be used in two places.  First, in an exporting module:
  
    # in the exporting module:
    package Text::Tweaker;
    use Sub::Exporter -setup => {
      exports => [
        qw(squish titlecase), # always works the same way
        reformat => \&build_reformatter, # generator to build exported function
        trim     => \&build_trimmer,
        indent   => \&build_indenter,
      ],
      collectors => [ 'defaults' ],
    };
  
  Then, in an importing module:
  
    # in the importing module:
    use Text::Tweaker
      'squish',
      indent   => { margin => 5 },
      reformat => { width => 79, justify => 'full', -as => 'prettify_text' },
      defaults => { eol => 'CRLF' };
  
  With this setup, the importing module ends up with three routines: C<squish>,
  C<indent>, and C<prettify_text>.  The latter two have been built to the
  specifications of the importer -- they are not just copies of the code in the
  exporting package.
  
  =head1 DESCRIPTION
  
  B<ACHTUNG!>  If you're not familiar with Exporter or exporting, read
  L<Sub::Exporter::Tutorial> first!
  
  =head2 Why Generators?
  
  The biggest benefit of Sub::Exporter over existing exporters (including the
  ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather
  than to simply export code identical to that found in the exporting package.
  
  If your module's consumers get a routine that works like this:
  
    use Data::Analyze qw(analyze);
    my $value = analyze($data, $tolerance, $passes);
  
  and they constantly pass only one or two different set of values for the
  non-C<$data> arguments, your code can benefit from Sub::Exporter.  By writing a
  simple generator, you can let them do this, instead:
  
    use Data::Analyze
      analyze => { tolerance => 0.10, passes => 10, -as => analyze10 },
      analyze => { tolerance => 0.15, passes => 50, -as => analyze50 };
  
    my $value = analyze10($data);
  
  The generator for that would look something like this:
  
    sub build_analyzer {
      my ($class, $name, $arg) = @_;
  
      return sub {
        my $data      = shift;
        my $tolerance = shift || $arg->{tolerance}; 
        my $passes    = shift || $arg->{passes}; 
  
        analyze($data, $tolerance, $passes);
      }
    }
  
  Your module's user now has to do less work to benefit from it -- and remember,
  you're often your own user!  Investing in customized subroutines is an
  investment in future laziness.
  
  This also avoids a common form of ugliness seen in many modules: package-level
  configuration.  That is, you might have seen something like the above
  implemented like so:
  
    use Data::Analyze qw(analyze);
    $Data::Analyze::default_tolerance = 0.10;
    $Data::Analyze::default_passes    = 10;
  
  This might save time, until you have multiple modules using Data::Analyze.
  Because there is only one global configuration, they step on each other's toes
  and your code begins to have mysterious errors.
  
  Generators can also allow you to export class methods to be called as
  subroutines:
  
    package Data::Methodical;
    use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } };
  
    sub _curry_class {
      my ($class, $name) = @_;
      sub { $class->$name(@_); };
    }
  
  Because of the way that exporters and Sub::Exporter work, any package that
  inherits from Data::Methodical can inherit its exporter and override its
  C<some_method>.  If a user imports C<some_method> from that package, he'll
  receive a subroutine that calls the method on the subclass, rather than on
  Data::Methodical itself.
  
  =head2 Other Customizations
  
  Building custom routines with generators isn't the only way that Sub::Exporters
  allows the importing code to refine its use of the exported routines.  They may
  also be renamed to avoid naming collisions.
  
  Consider the following code:
  
    # this program determines to which circle of Hell you will be condemned
    use Morality qw(sin virtue); # for calculating viciousness
    use Math::Trig qw(:all);     # for dealing with circles
  
  The programmer has inadvertantly imported two C<sin> routines.  The solution,
  in Exporter.pm-based modules, would be to import only one and then call the
  other by its fully-qualified name.  Alternately, the importer could write a
  routine that did so, or could mess about with typeglobs.
  
  How much easier to write:
  
    # this program determines to which circle of Hell you will be condemned
    use Morality qw(virtue), sin => { -as => 'offense' };
    use Math::Trig -all => { -prefix => 'trig_' };
  
  and to have at one's disposal C<offense> and C<trig_sin> -- not to mention
  C<trig_cos> and C<trig_tan>.
  
  =head1 EXPORTER CONFIGURATION
  
  You can configure an exporter for your package by using Sub::Exporter like so:
  
    package Tools;
    use Sub::Exporter
      -setup => { exports => [ qw(function1 function2 function3) ] };
  
  This is the simplest way to use the exporter, and is basically equivalent to
  this:
  
    package Tools;
    use base qw(Exporter);
    our @EXPORT_OK = qw(function1 function2 function2);
  
  Any basic use of Sub::Exporter will look like this:
  
    package Tools;
    use Sub::Exporter -setup => \%config;
  
  The following keys are valid in C<%config>:
  
    exports - a list of routines to provide for exporting; each routine may be
              followed by generator
    groups  - a list of groups to provide for exporting; each must be followed by
              either (a) a list of exports, possibly with arguments for each
              export, or (b) a generator
  
    collectors - a list of names into which values are collected for use in
                 routine generation; each name may be followed by a validator
  
  In addition to the basic options above, a few more advanced options may be
  passed:
  
    into_level - how far up the caller stack to look for a target (default 0)
    into       - an explicit target (package) into which to export routines
  
  In other words: Sub::Exporter installs a C<import> routine which, when called,
  exports routines to the calling namespace.  The C<into> and C<into_level>
  options change where those exported routines are installed.
  
    generator  - a callback used to produce the code that will be installed
                 default: Sub::Exporter::default_generator
  
    installer  - a callback used to install the code produced by the generator
                 default: Sub::Exporter::default_installer
  
  For information on how these callbacks are used, see the documentation for
  C<L</default_generator>> and C<L</default_installer>>.
  
  =head2 Export Configuration
  
  The C<exports> list may be provided as an array reference or a hash reference.
  The list is processed in such a way that the following are equivalent:
  
    { exports => [ qw(foo bar baz), quux => \&quux_generator ] }
  
    { exports =>
      { foo => undef, bar => undef, baz => undef, quux => \&quux_generator } }
  
  Generators are code that return coderefs.  They are called with four
  parameters:
  
    $class - the class whose exporter has been called (the exporting class)
    $name  - the name of the export for which the routine is being build
   \%arg   - the arguments passed for this export
   \%col   - the collections for this import
  
  Given the configuration in the L</SYNOPSIS>, the following C<use> statement:
  
    use Text::Tweaker
      reformat => { -as => 'make_narrow', width => 33 },
      defaults => { eol => 'CR' };
  
  would result in the following call to C<&build_reformatter>:
  
    my $code = build_reformatter(
      'Text::Tweaker',
      'reformat',
      { width => 33 }, # note that -as is not passed in
      { defaults => { eol => 'CR' } },
    );
  
  The returned coderef (C<$code>) would then be installed as C<make_narrow> in the
  calling package.
  
  Instead of providing a coderef in the configuration, a reference to a method
  name may be provided.  This method will then be called on the invocant of the
  C<import> method.  (In this case, we do not pass the C<$class> parameter, as it
  would be redundant.)
  
  =head2 Group Configuration
  
  The C<groups> list can be passed in the same forms as C<exports>.  Groups must
  have values to be meaningful, which may either list exports that make up the
  group (optionally with arguments) or may provide a way to build the group.
  
  The simpler case is the first: a group definition is a list of exports.  Here's
  the example that could go in exporter in the L</SYNOPSIS>.
  
    groups  => {
      default    => [ qw(reformat) ],
      shorteners => [ qw(squish trim) ],
      email_safe => [
        'indent',
        reformat => { -as => 'email_format', width => 72 }
      ],
    },
  
  Groups are imported by specifying their name prefixed be either a dash or a
  colon.  This line of code would import the C<shorteners> group:
  
    use Text::Tweaker qw(-shorteners);
  
  Arguments passed to a group when importing are merged into the groups options
  and passed to any relevant generators.  Groups can contain other groups, but
  looping group structures are ignored.
  
  The other possible value for a group definition, a coderef, allows one
  generator to build several exportable routines simultaneously.  This is useful
  when many routines must share enclosed lexical variables.  The coderef must
  return a hash reference.  The keys will be used as export names and the values
  are the subs that will be exported.
  
  This example shows a simple use of the group generator.
  
    package Data::Crypto;
    use Sub::Exporter -setup => { groups => { cipher => \&build_cipher_group } };
  
    sub build_cipher_group {
      my ($class, $group, $arg) = @_;
      my ($encode, $decode) = build_codec($arg->{secret});
      return { cipher => $encode, decipher => $decode };
    }
  
  The C<cipher> and C<decipher> routines are built in a group because they are
  built together by code which encloses their secret in their environment.
  
  =head3 Default Groups
  
  If a module that uses Sub::Exporter is C<use>d with no arguments, it will try
  to export the group named C<default>.  If that group has not been specifically
  configured, it will be empty, and nothing will happen.
  
  Another group is also created if not defined: C<all>.  The C<all> group
  contains all the exports from the exports list.
  
  =head2 Collector Configuration
  
  The C<collectors> entry in the exporter configuration gives names which, when
  found in the import call, have their values collected and passed to every
  generator.
  
  For example, the C<build_analyzer> generator that we saw above could be
  rewritten as:
  
   sub build_analyzer {
     my ($class, $name, $arg, $col) = @_;
  
     return sub {
       my $data      = shift;
       my $tolerance = shift || $arg->{tolerance} || $col->{defaults}{tolerance}; 
       my $passes    = shift || $arg->{passes}    || $col->{defaults}{passes}; 
  
       analyze($data, $tolerance, $passes);
     }
   }
  
  That would allow the import to specify global defaults for his imports:
  
    use Data::Analyze
      'analyze',
      analyze  => { tolerance => 0.10, -as => analyze10 },
      analyze  => { tolerance => 0.15, passes => 50, -as => analyze50 },
      defaults => { passes => 10 };
  
    my $A = analyze10($data);     # equivalent to analyze($data, 0.10, 10);
    my $C = analyze50($data);     # equivalent to analyze($data, 0.15, 10);
    my $B = analyze($data, 0.20); # equivalent to analyze($data, 0.20, 10);
  
  If values are provided in the C<collectors> list during exporter setup, they
  must be code references, and are used to validate the importer's values.  The
  validator is called when the collection is found, and if it returns false, an
  exception is thrown.  We could ensure that no one tries to set a global data
  default easily:
  
    collectors => { defaults => sub { return (exists $_[0]->{data}) ? 0 : 1 } }
  
  Collector coderefs can also be used as hooks to perform arbitrary actions
  before anything is exported.
  
  When the coderef is called, it is passed the value of the collection and a
  hashref containing the following entries:
  
    name        - the name of the collector
    config      - the exporter configuration (hashref)
    import_args - the arguments passed to the exporter, sans collections (aref)
    class       - the package on which the importer was called
    into        - the package into which exports will be exported
  
  Collectors with all-caps names (that is, made up of underscore or capital A
  through Z) are reserved for special use.  The only currently implemented
  special collector is C<INIT>, whose hook (if present in the exporter
  configuration) is always run before any other hook.
  
  =head1 CALLING THE EXPORTER
  
  Arguments to the exporter (that is, the arguments after the module name in a
  C<use> statement) are parsed as follows:
  
  First, the collectors gather any collections found in the arguments.  Any
  reference type may be given as the value for a collector.  For each collection
  given in the arguments, its validator (if any) is called.  
  
  Next, groups are expanded.  If the group is implemented by a group generator,
  the generator is called.  There are two special arguments which, if given to a
  group, have special meaning:
  
    -prefix - a string to prepend to any export imported from this group
    -suffix - a string to append to any export imported from this group
  
  Finally, individual export generators are called and all subs, generated or
  otherwise, are installed in the calling package.  There is only one special
  argument for export generators:
  
    -as     - where to install the exported sub
  
  Normally, C<-as> will contain an alternate name for the routine.  It may,
  however, contain a reference to a scalar.  If that is the case, a reference the
  generated routine will be placed in the scalar referenced by C<-as>.  It will
  not be installed into the calling package.
  
  =head2 Special Exporter Arguments
  
  The generated exporter accept some special options, which may be passed as the
  first argument, in a hashref.
  
  These options are:
  
    into_level
    into
    generator
    installer
  
  These override the same-named configuration options described in L</EXPORTER
  CONFIGURATION>.
  
  =cut
  
  # Given a potential import name, this returns the group name -- if it's got a
  # group prefix.
  sub _group_name {
    my ($name) = @_;
  
    return if (index q{-:}, (substr $name, 0, 1)) == -1;
    return substr $name, 1;
  }
  
  # \@groups is a canonicalized opt list of exports and groups this returns
  # another canonicalized opt list with groups replaced with relevant exports.
  # \%seen is groups we've already expanded and can ignore.
  # \%merge is merged options from the group we're descending through.
  sub _expand_groups {
    my ($class, $config, $groups, $collection, $seen, $merge) = @_;
    $seen  ||= {};
    $merge ||= {};
    my @groups = @$groups;
  
    for my $i (reverse 0 .. $#groups) {
      if (my $group_name = _group_name($groups[$i][0])) {
        my $seen = { %$seen }; # faux-dynamic scoping
  
        splice @groups, $i, 1,
          _expand_group($class, $config, $groups[$i], $collection, $seen, $merge);
      } else {
        # there's nothing to munge in this export's args
        next unless my %merge = %$merge;
  
        # we have things to merge in; do so
        my $prefix = (delete $merge{-prefix}) || '';
        my $suffix = (delete $merge{-suffix}) || '';
  
        if (
          Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private
          or
          Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private
        ) {
          # this entry was build by a group generator
          $groups[$i][0] = $prefix . $groups[$i][0] . $suffix;
        } else {
          my $as
            = ref $groups[$i][1]{-as} ? $groups[$i][1]{-as}
            :     $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix
            :                           $prefix . $groups[$i][0]      . $suffix;
  
          $groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as };
        }
      }
    }
  
    return \@groups;
  }
  
  # \@group is a name/value pair from an opt list.
  sub _expand_group {
    my ($class, $config, $group, $collection, $seen, $merge) = @_;
    $merge ||= {};
  
    my ($group_name, $group_arg) = @$group;
    $group_name = _group_name($group_name);
  
    Carp::croak qq(group "$group_name" is not exported by the $class module)
      unless exists $config->{groups}{$group_name};
  
    return if $seen->{$group_name}++;
  
    if (ref $group_arg) {
      my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||'');
      my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||'');
      $merge = {
        %$merge,
        %$group_arg,
        ($prefix ? (-prefix => $prefix) : ()),
        ($suffix ? (-suffix => $suffix) : ()),
      };
    }
  
    my $exports = $config->{groups}{$group_name};
  
    if (
      Params::Util::_CODELIKE($exports) ## no critic Private
      or
      Params::Util::_SCALAR0($exports) ## no critic Private
    ) {
      # I'm not very happy with this code for hiding -prefix and -suffix, but
      # it's needed, and I'm not sure, offhand, how to make it better.
      # -- rjbs, 2006-12-05
      my $group_arg = $merge ? { %$merge } : {};
      delete $group_arg->{-prefix};
      delete $group_arg->{-suffix};
  
      my $group = Params::Util::_CODELIKE($exports) ## no critic Private
                ? $exports->($class, $group_name, $group_arg, $collection)
                : $class->$$exports($group_name, $group_arg, $collection);
  
      Carp::croak qq(group generator "$group_name" did not return a hashref)
        if ref $group ne 'HASH';
  
      my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ];
      return @{
        _expand_groups($class, $config, $stuff, $collection, $seen, $merge)
      };
    } else {
      $exports
        = Data::OptList::mkopt($exports, "$group_name exports");
  
      return @{
        _expand_groups($class, $config, $exports, $collection, $seen, $merge)
      };
    }
  }
  
  sub _mk_collection_builder {
    my ($col, $etc) = @_;
    my ($config, $import_args, $class, $into) = @$etc;
  
    my %seen;
    sub {
      my ($collection) = @_;
      my ($name, $value) = @$collection;
  
      Carp::croak "collection $name provided multiple times in import"
        if $seen{ $name }++;
  
      if (ref(my $hook = $config->{collectors}{$name})) {
        my $arg = {
          name        => $name,
          config      => $config,
          import_args => $import_args,
          class       => $class,
          into        => $into,
        };
  
        my $error_msg = "collection $name failed validation";
        if (Params::Util::_SCALAR0($hook)) { ## no critic Private
          Carp::croak $error_msg unless $class->$$hook($value, $arg);
        } else {
          Carp::croak $error_msg unless $hook->($value, $arg);
        }
      }
  
      $col->{ $name } = $value;
    }
  }
  
  # Given a config and pre-canonicalized importer args, remove collections from
  # the args and return them.
  sub _collect_collections {
    my ($config, $import_args, $class, $into) = @_;
  
    my @collections
      = map  { splice @$import_args, $_, 1 }
        grep { exists $config->{collectors}{ $import_args->[$_][0] } }
        reverse 0 .. $#$import_args;
  
    unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT};
  
    my $col = {};
    my $builder = _mk_collection_builder($col, \@_);
    for my $collection (@collections) {
      $builder->($collection)
    }
  
    return $col;
  }
  
  =head1 SUBROUTINES
  
  =head2 setup_exporter
  
  This routine builds and installs an C<import> routine.  It is called with one
  argument, a hashref containing the exporter configuration.  Using this, it
  builds an exporter and installs it into the calling package with the name
  "import."  In addition to the normal exporter configuration, a few named
  arguments may be passed in the hashref:
  
    into       - into what package should the exporter be installed
    into_level - into what level up the stack should the exporter be installed
    as         - what name should the installed exporter be given
  
  By default the exporter is installed with the name C<import> into the immediate
  caller of C<setup_exporter>.  In other words, if your package calls
  C<setup_exporter> without providing any of the three above arguments, it will
  have an C<import> routine installed.
  
  Providing both C<into> and C<into_level> will cause an exception to be thrown.
  
  The exporter is built by C<L</build_exporter>>.
  
  =cut
  
  sub setup_exporter {
    my ($config)  = @_;
  
    Carp::croak 'into and into_level may not both be supplied to exporter'
      if exists $config->{into} and exists $config->{into_level};
  
    my $as   = delete $config->{as}   || 'import';
    my $into
      = exists $config->{into}       ? delete $config->{into}
      : exists $config->{into_level} ? caller(delete $config->{into_level})
      :                                caller(0);
  
    my $import = build_exporter($config);
  
    Sub::Install::reinstall_sub({
      code => $import,
      into => $into,
      as   => $as,
    });
  }
  
  =head2 build_exporter
  
  Given a standard exporter configuration, this routine builds and returns an
  exporter -- that is, a subroutine that can be installed as a class method to
  perform exporting on request.
  
  Usually, this method is called by C<L</setup_exporter>>, which then installs
  the exporter as a package's import routine.
  
  =cut
  
  sub _key_intersection {
    my ($x, $y) = @_;
    my %seen = map { $_ => 1 } keys %$x;
    my @names = grep { $seen{$_} } keys %$y;
  }
  
  # Given the config passed to setup_exporter, which contains sugary opt list
  # data, rewrite the opt lists into hashes, catch a few kinds of invalid
  # configurations, and set up defaults.  Since the config is a reference, it's
  # rewritten in place.
  my %valid_config_key;
  BEGIN {
    %valid_config_key =
      map { $_ => 1 }
      qw(as collectors installer generator exports groups into into_level),
      qw(exporter), # deprecated
  }
  
  sub _assert_collector_names_ok {
    my ($collectors) = @_;
  
    for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) {
      Carp::croak "unknown reserved collector name: $reserved_name"
        if $reserved_name ne 'INIT';
    }
  }
  
  sub _rewrite_build_config {
    my ($config) = @_;
  
    if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) {
      Carp::croak "unknown options (@keys) passed to Sub::Exporter";
    }
  
    Carp::croak q(into and into_level may not both be supplied to exporter)
      if exists $config->{into} and exists $config->{into_level};
  
    # XXX: Remove after deprecation period.
    if ($config->{exporter}) {
      Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical.";
      $config->{installer} = delete $config->{exporter};
    }
  
    Carp::croak q(into and into_level may not both be supplied to exporter)
      if exists $config->{into} and exists $config->{into_level};
  
    for (qw(exports collectors)) {
      $config->{$_} = Data::OptList::mkopt_hash(
        $config->{$_},
        $_,
        [ 'CODE', 'SCALAR' ],
      );
    }
  
    _assert_collector_names_ok($config->{collectors});
  
    if (my @names = _key_intersection(@$config{qw(exports collectors)})) {
      Carp::croak "names (@names) used in both collections and exports";
    }
  
    $config->{groups} = Data::OptList::mkopt_hash(
        $config->{groups},
        'groups',
        [
          'HASH',   # standard opt list
          'ARRAY',  # standard opt list
          'CODE',   # group generator
          'SCALAR', # name of group generation method
        ]
      );
  
    # by default, export nothing
    $config->{groups}{default} ||= [];
  
    # by default, build an all-inclusive 'all' group
    $config->{groups}{all} ||= [ keys %{ $config->{exports} } ];
  
    $config->{generator} ||= \&default_generator;
    $config->{installer} ||= \&default_installer;
  }
  
  sub build_exporter {
    my ($config) = @_;
  
    _rewrite_build_config($config);
  
    my $import = sub {
      my ($class) = shift;
  
      # XXX: clean this up -- rjbs, 2006-03-16
      my $special = (ref $_[0]) ? shift(@_) : {};
      Carp::croak q(into and into_level may not both be supplied to exporter)
        if exists $special->{into} and exists $special->{into_level};
  
      if ($special->{exporter}) {
        Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical.";
        $special->{installer} = delete $special->{exporter};
      }
  
      my $into
        = defined $special->{into}       ? delete $special->{into}
        : defined $special->{into_level} ? caller(delete $special->{into_level})
        : defined $config->{into}        ? $config->{into}
        : defined $config->{into_level}  ? caller($config->{into_level})
        :                                  caller(0);
  
      my $generator = delete $special->{generator} || $config->{generator};
      my $installer = delete $special->{installer} || $config->{installer};
  
      # this builds a AOA, where the inner arrays are [ name => value_ref ]
      my $import_args = Data::OptList::mkopt([ @_ ]);
  
      # is this right?  defaults first or collectors first? -- rjbs, 2006-06-24
      $import_args = [ [ -default => undef ] ] unless @$import_args;
  
      my $collection = _collect_collections($config, $import_args, $class, $into);
  
      my $to_import = _expand_groups($class, $config, $import_args, $collection);
  
      # now, finally $import_arg is really the "to do" list
      _do_import(
        {
          class     => $class,
          col       => $collection,
          config    => $config,
          into      => $into,
          generator => $generator,
          installer => $installer,
        },
        $to_import,
      );
    };
  
    return $import;
  }
  
  sub _do_import {
    my ($arg, $to_import) = @_;
  
    my @todo;
  
    for my $pair (@$to_import) {
      my ($name, $import_arg) = @$pair;
  
      my ($generator, $as);
  
      if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic
        # This is the case when a group generator has inserted name/code pairs.
        $generator = sub { $import_arg };
        $as = $name;
      } else {
        $import_arg = { $import_arg ? %$import_arg : () };
  
        Carp::croak qq("$name" is not exported by the $arg->{class} module)
          unless exists $arg->{config}{exports}{$name};
  
        $generator = $arg->{config}{exports}{$name};
  
        $as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name;
      }
  
      my $code = $arg->{generator}->(
        { 
          class     => $arg->{class},
          name      => $name,
          arg       => $import_arg,
          col       => $arg->{col},
          generator => $generator,
        }
      );
  
      push @todo, $as, $code;
    }
  
    $arg->{installer}->(
      {
        class => $arg->{class},
        into  => $arg->{into},
        col   => $arg->{col},
      },
      \@todo,
    );
  }
  
  ## Cute idea, possibly for future use: also supply an "unimport" for:
  ## no Module::Whatever qw(arg arg arg);
  # sub _unexport {
  #   my (undef, undef, undef, undef, undef, $as, $into) = @_;
  # 
  #   if (ref $as eq 'SCALAR') {
  #     undef $$as;
  #   } elsif (ref $as) {
  #     Carp::croak "invalid reference type for $as: " . ref $as;
  #   } else {
  #     no strict 'refs';
  #     delete &{$into . '::' . $as};
  #   }
  # }
  
  =head2 default_generator
  
  This is Sub::Exporter's default generator.  It takes bits of configuration that
  have been gathered during the import and turns them into a coderef that can be
  installed.
  
    my $code = default_generator(\%arg);
  
  Passed arguments are:
  
    class - the class on which the import method was called
    name  - the name of the export being generated
    arg   - the arguments to the generator
    col   - the collections
  
    generator - the generator to be used to build the export (code or scalar ref)
  
  =cut
  
  sub default_generator {
    my ($arg) = @_;
    my ($class, $name, $generator) = @$arg{qw(class name generator)};
  
    if (not defined $generator) {
      my $code = $class->can($name)
        or Carp::croak "can't locate exported subroutine $name via $class";
      return $code;
    }
  
    # I considered making this "$class->$generator(" but it seems that
    # overloading precedence would turn an overloaded-as-code generator object
    # into a string before code. -- rjbs, 2006-06-11
    return $generator->($class, $name, $arg->{arg}, $arg->{col})
      if Params::Util::_CODELIKE($generator); ## no critic Private
  
    # This "must" be a scalar reference, to a generator method name.
    # -- rjbs, 2006-12-05
    return $class->$$generator($name, $arg->{arg}, $arg->{col});
  }
  
  =head2 default_installer
  
  This is Sub::Exporter's default installer.  It does what Sub::Exporter
  promises: it installs code into the target package.
  
    default_installer(\%arg, \@to_export);
  
  Passed arguments are:
  
    into - the package into which exports should be delivered
  
  C<@to_export> is a list of name/value pairs.  The default exporter assigns code
  (the values) to named slots (the names) in the given package.  If the name is a
  scalar reference, the scalar reference is made to point to the code reference
  instead.
  
  =cut
  
  sub default_installer {
    my ($arg, $to_export) = @_;
  
    for (my $i = 0; $i < @$to_export; $i += 2) {
      my ($as, $code) = @$to_export[ $i, $i+1 ];
  
      # Allow as isa ARRAY to push onto an array?
      # Allow into isa HASH to install name=>code into hash?
  
      if (ref $as eq 'SCALAR') {
        $$as = $code;
      } elsif (ref $as) {
        Carp::croak "invalid reference type for $as: " . ref $as;
      } else {
        Sub::Install::reinstall_sub({
          code => $code,
          into => $arg->{into},
          as   => $as
        });
      }
    }
  }
  
  sub default_exporter {
    Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical";
    goto &default_installer;
  }
  
  =head1 EXPORTS
  
  Sub::Exporter also offers its own exports: the C<setup_exporter> and
  C<build_exporter> routines described above.  It also provides a special "setup"
  collector, which will set up an exporter using the parameters passed to it.
  
  Note that the "setup" collector (seen in examples like the L</SYNOPSIS> above)
  uses C<build_exporter>, not C<setup_exporter>.  This means that the special
  arguments like "into" and "as" for C<setup_exporter> are not accepted here.
  Instead, you may write something like:
  
    use Sub::Exporter
      { into => 'Target::Package' },
      -setup => {
        -as     => 'do_import',
        exports => [ ... ],
      }
    ;
  
  Finding a good reason for wanting to do this is left as as exercise for the
  reader.
  
  =cut
  
  setup_exporter({
    exports => [
      qw(setup_exporter build_exporter),
      _import => sub { build_exporter($_[2]) },
    ],
    groups  => {
      all   => [ qw(setup_exporter build_export) ],
    },
    collectors => { -setup => \&_setup },
  });
  
  sub _setup {
    my ($value, $arg) = @_;
  
    if (ref $value eq 'HASH') {
      push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ];
      return 1;
    } elsif (ref $value eq 'ARRAY') {
      push @{ $arg->{import_args} },
        [ _import => { -as => 'import', exports => $value } ];
      return 1;
    }
    return;
  }
  
  =head1 COMPARISONS
  
  There are a whole mess of exporters on the CPAN.  The features included in
  Sub::Exporter set it apart from any existing Exporter.  Here's a summary of
  some other exporters and how they compare.
  
  =over
  
  =item * L<Exporter> and co.
  
  This is the standard Perl exporter.  Its interface is a little clunky, but it's
  fast and ubiquitous.  It can do some things that Sub::Exporter can't:  it can
  export things other than routines, it can import "everything in this group
  except this symbol," and some other more esoteric things.  These features seem
  to go nearly entirely unused.
  
  It always exports things exactly as they appear in the exporting module; it
  can't rename or customize routines.  Its groups ("tags") can't be nested.
  
  L<Exporter::Lite> is a whole lot like Exporter, but it does significantly less:
  it supports exporting symbols, but not groups, pattern matching, or negation.
  
  The fact that Sub::Exporter can't export symbols other than subroutines is
  a good idea, not a missing feature.
  
  For simple uses, setting up Sub::Exporter is about as easy as Exporter.  For
  complex uses, Sub::Exporter makes hard things possible, which would not be
  possible with Exporter. 
  
  When using a module that uses Sub::Exporter, users familiar with Exporter will
  probably see no difference in the basics.  These two lines do about the same
  thing in whether the exporting module uses Exporter or Sub::Exporter.
  
    use Some::Module qw(foo bar baz);
    use Some::Module qw(foo :bar baz);
  
  The definition for exporting in Exporter.pm might look like this:
  
    package Some::Module;
    use base qw(Exporter);
    our @EXPORT_OK   = qw(foo bar baz quux);
    our %EXPORT_TAGS = (bar => [ qw(bar baz) ]);
  
  Using Sub::Exporter, it would look like this:
  
    package Some::Module;
    use Sub::Exporter -setup => {
      exports => [ qw(foo bar baz quux) ],
      groups  => { bar => [ qw(bar baz) ]}
    };
  
  Sub::Exporter respects inheritance, so that a package may export inherited
  routines, and will export the most inherited version.  Exporting methods
  without currying away the invocant is a bad idea, but Sub::Exporter allows you
  to do just that -- and anyway, there are other uses for this feature, like
  packages of exported subroutines which use inheritance specifically to allow
  more specialized, but similar, packages.
  
  L<Exporter::Easy> provides a wrapper around the standard Exporter.  It makes it
  simpler to build groups, but doesn't provide any more functionality.  Because
  it is a front-end to Exporter, it will store your exporter's configuration in
  global package variables.
  
  =item * Attribute-Based Exporters
  
  Some exporters use attributes to mark variables to export.  L<Exporter::Simple>
  supports exporting any kind of symbol, and supports groups.  Using a module
  like Exporter or Sub::Exporter, it's easy to look at one place and see what is
  exported, but it's impossible to look at a variable definition and see whether
  it is exported by that alone.  Exporter::Simple makes this trade in reverse:
  each variable's declaration includes its export definition, but there is no one
  place to look to find a manifest of exports.
  
  More importantly, Exporter::Simple does not add any new features to those of
  Exporter.  In fact, like Exporter::Easy, it is just a front-end to Exporter, so
  it ends up storing its configuration in global package variables.  (This means
  that there is one place to look for your exporter's manifest, actually.  You
  can inspect the C<@EXPORT> package variables, and other related package
  variables, at runtime.)
  
  L<Perl6::Export> isn't actually attribute based, but looks similar.  Its syntax
  is borrowed from Perl 6, and implemented by a source filter.  It is a prototype
  of an interface that is still being designed.  It should probably be avoided
  for production work.  On the other hand, L<Perl6::Export::Attrs> implements
  Perl 6-like exporting, but translates it into Perl 5 by providing attributes.
  
  =item * Other Exporters
  
  L<Exporter::Renaming> wraps the standard Exporter to allow it to export symbols
  with changed names.
  
  L<Class::Exporter> performs a special kind of routine generation, giving each
  importing package an instance of your class, and then exporting the instance's
  methods as normal routines.  (Sub::Exporter, of course, can easily emulate this
  behavior, as shown above.)
  
  L<Exporter::Tidy> implements a form of renaming (using its C<_map> argument)
  and of prefixing, and implements groups.  It also avoids using package
  variables for its configuration.
  
  =back
  
  =head1 TODO
  
  =cut
  
  =over
  
  =item * write a set of longer, more demonstrative examples
  
  =item * solidify the "custom exporter" interface (see C<&default_exporter>)
  
  =item * add an "always" group
  
  =back
  
  =head1 AUTHOR
  
  Ricardo SIGNES, C<< <rjbs@cpan.org> >>
  
  =head1 THANKS
  
  Hans Dieter Pearcey provided helpful advice while I was writing Sub::Exporter.
  Ian Langworth and Shawn Sorichetti asked some good questions and hepled me
  improve my documentation quite a bit.  Yuval Kogman helped me find a bunch of
  little problems.
  
  Thanks, guys! 
  
  =head1 BUGS
  
  Please report any bugs or feature requests through the web interface at
  L<http://rt.cpan.org>. I will be notified, and then you'll automatically be
  notified of progress on your bug as I make changes.
  
  =head1 COPYRIGHT
  
  Copyright 2006-2007, Ricardo SIGNES.  This program is free software;  you can
  redistribute it and/or modify it under the same terms as Perl itself.
  
  =cut
  
  "jn8:32"; # <-- magic true value
SUB_EXPORTER

$fatpacked{"Sub/Exporter/Util.pm"} = <<'SUB_EXPORTER_UTIL';
  use strict;
  use warnings;
  
  package Sub::Exporter::Util;
  
  use Data::OptList ();
  use Params::Util ();
  
  =head1 NAME
  
  Sub::Exporter::Util - utilities to make Sub::Exporter easier
  
  =head1 VERSION
  
  version 0.982
  
  =cut
  
  our $VERSION = '0.982';
  
  =head1 DESCRIPTION
  
  This module provides a number of utility functions for performing common or
  useful operations when setting up a Sub::Exporter configuration.  All of the
  utilites may be exported, but none are by default.
  
  =head1 THE UTILITIES
  
  =head2 curry_method
  
    exports => {
      some_method => curry_method,
    }
  
  This utility returns a generator which will produce an invocant-curried version
  of a method.  In other words, it will export a method call with the exporting
  class built in as the invocant.
  
  A module importing the code some the above example might do this:
  
    use Some::Module qw(some_method);
  
    my $x = some_method;
  
  This would be equivalent to:
  
    use Some::Module;
  
    my $x = Some::Module->some_method;
  
  If Some::Module is subclassed and the subclass's import method is called to
  import C<some_method>, the subclass will be curried in as the invocant.
  
  If an argument is provided for C<curry_method> it is used as the name of the
  curried method to export.  This means you could export a Widget constructor
  like this:
  
    exports => { widget => curry_method('new') }
  
  This utility may also be called as C<curry_class>, for backwards compatibility.
  
  =cut
  
  sub curry_method {
    my $override_name = shift;
    sub {
      my ($class, $name) = @_;
      $name = $override_name if defined $override_name;
      sub { $class->$name(@_); };
    }
  }
  
  BEGIN { *curry_class = \&curry_method; }
  
  =head2 curry_chain
  
  C<curry_chain> behaves like C<L</curry_method>>, but is meant for generating
  exports that will call several methods in succession.
  
    exports => {
      reticulate => curry_chain([
        new => gather_data => analyze => [ detail => 100 ] => results
      ]),
    }
  
  If imported from Spliner, calling the C<reticulate> routine will be equivalent
  to:
  
    Splinter->new->gather_data->analyze(detail => 100)->results;
  
  If any method returns something on which methods may not be called, the routine
  croaks.
  
  The arguments to C<curry_chain> form an optlist.  The names are methods to be
  called and the arguments, if given, are arrayrefs to be dereferenced and passed
  as arguments to those methods.  C<curry_chain> returns a generator like those
  expected by Sub::Exporter.
  
  B<Achtung!> at present, there is no way to pass arguments from the generated
  routine to the method calls.  This will probably be solved in future revisions
  by allowing the opt list's values to be subroutines that will be called with
  the generated routine's stack.
  
  =cut
  
  sub curry_chain {
    # In the future, we can make \%arg an optional prepend, like the "special"
    # args to the default Sub::Exporter-generated import routine.
    my (@opt_list) = @_;
  
    my $pairs = Data::OptList::mkopt(\@opt_list, 'args', 'ARRAY');
  
    sub {
      my ($class) = @_;
  
      sub {
        my $next = $class;
  
        for my $i (0 .. $#$pairs) {
          my $pair = $pairs->[ $i ];
          
          unless (Params::Util::_INVOCANT($next)) { ## no critic Private
            my $str = defined $next ? "'$next'" : 'undef';
            Carp::croak("can't call $pair->[0] on non-invocant $str")
          }
  
          my ($method, $args) = @$pair;
  
          if ($i == $#$pairs) {
            return $next->$method($args ? @$args : ());
          } else {
            $next = $next->$method($args ? @$args : ());
          }
        }
      };
    }
  }
  
  # =head2 name_map
  # 
  # This utility returns an list to be used in specify export generators.  For
  # example, the following:
  # 
  #   exports => {
  #     name_map(
  #       '_?_gen'  => [ qw(fee fie) ],
  #       '_make_?' => [ qw(foo bar) ],
  #     ),
  #   }
  # 
  # is equivalent to:
  # 
  #   exports => {
  #     name_map(
  #       fee => \'_fee_gen',
  #       fie => \'_fie_gen',
  #       foo => \'_make_foo',
  #       bar => \'_make_bar',
  #     ),
  #   }
  # 
  # This can save a lot of typing, when providing many exports with similarly-named
  # generators.
  # 
  # =cut
  # 
  # sub name_map {
  #   my (%groups) = @_;
  # 
  #   my %map;
  # 
  #   while (my ($template, $names) = each %groups) {
  #     for my $name (@$names) {
  #       (my $export = $template) =~ s/\?/$name/
  #         or Carp::croak 'no ? found in name_map template';
  # 
  #       $map{ $name } = \$export;
  #     }
  #   }
  # 
  #   return %map;
  # }
  
  =head2 merge_col
  
    exports => {
      merge_col(defaults => {
        twiddle => \'_twiddle_gen',
        tweak   => \&_tweak_gen,
      }),
    }
  
  This utility wraps the given generator in one that will merge the named
  collection into its args before calling it.  This means that you can support a
  "default" collector in multipe exports without writing the code each time.
  
  You can specify as many pairs of collection names and generators as you like.
  
  =cut
  
  sub merge_col {
    my (%groups) = @_;
  
    my %merged;
  
    while (my ($default_name, $group) = each %groups) {
      while (my ($export_name, $gen) = each %$group) {
        $merged{$export_name} = sub {
          my ($class, $name, $arg, $col) = @_;
  
          my $merged_arg = exists $col->{$default_name}
                         ? { %{ $col->{$default_name} }, %$arg }
                         : $arg;
  
          if (Params::Util::_CODELIKE($gen)) { ## no critic Private
            $gen->($class, $name, $merged_arg, $col);
          } else {
            $class->$$gen($name, $merged_arg, $col);
          }
        }
      }
    }
  
    return %merged;
  }
  
  =head2 mixin_installer
  
    use Sub::Exporter -setup => {
      installer => Sub::Exporter::Util::mixin_installer,
      exports   => [ qw(foo bar baz) ],
    };
  
  This utility returns an installer that will install into a superclass and
  adjust the ISA importing class to include the newly generated superclass.
  
  If the target of importing is an object, the hierarchy is reversed: the new
  class will be ISA the object's class, and the object will be reblessed.
  
  B<Prerequisites>: This utility requires that Package::Generator be installed.
  
  =cut
  
  sub __mixin_class_for {
    my ($class, $mix_into) = @_;
    require Package::Generator;
    my $mixin_class = Package::Generator->new_package({
      base => "$class\:\:__mixin__",
    });
  
    ## no critic (ProhibitNoStrict)
    no strict 'refs';
    if (ref $mix_into) {
      unshift @{"$mixin_class" . "::ISA"}, ref $mix_into;
    } else {
      unshift @{"$mix_into" . "::ISA"}, $mixin_class;
    }
    return $mixin_class;
  }
  
  sub mixin_installer {
    sub {
      my ($arg, $to_export) = @_;
  
      my $mixin_class = __mixin_class_for($arg->{class}, $arg->{into});
      bless $arg->{into} => $mixin_class if ref $arg->{into};
  
      Sub::Exporter::default_installer(
        { %$arg, into => $mixin_class },
        $to_export,
      );
    };
  }
  
  sub mixin_exporter {
    Carp::cluck "mixin_exporter is deprecated; use mixin_installer instead; it behaves identically";
    return mixin_installer;
  }
  
  =head2 like
  
  It's a collector that adds imports for anything like given regex.
  
  If you provide this configuration:
  
    exports    => [ qw(igrep imap islurp exhausted) ],
    collectors => { -like => Sub::Exporter::Util::like },
  
  A user may import from your module like this:
  
    use Your::Iterator -like => qr/^i/; # imports igre, imap, islurp
  
  or
  
    use Your::Iterator -like => [ qr/^i/ => { -prefix => 'your_' } ];
  
  The group-like prefix and suffix arguments are respected; other arguments are
  passed on to the generators for matching exports.
  
  =cut
  
  sub like {
    sub {
      my ($value, $arg) = @_;
      Carp::croak "no regex supplied to regex group generator" unless $value;
  
      # Oh, qr//, how you bother me!  See the p5p thread from around now about
      # fixing this problem... too bad it won't help me. -- rjbs, 2006-04-25
      my @values = eval { $value->isa('Regexp') } ? ($value, undef)
                 :                                  @$value;
  
      while (my ($re, $opt) = splice @values, 0, 2) {
        Carp::croak "given pattern for regex group generater is not a Regexp"
          unless eval { $re->isa('Regexp') };
        my @exports  = keys %{ $arg->{config}->{exports} };
        my @matching = grep { $_ =~ $re } @exports;
  
        my %merge = $opt ? %$opt : ();
        my $prefix = (delete $merge{-prefix}) || '';
        my $suffix = (delete $merge{-suffix}) || '';
  
        for my $name (@matching) {
          my $as = $prefix . $name . $suffix;
          push @{ $arg->{import_args} }, [ $name => { %merge, -as => $as } ];
        }
      }
  
      1;
    }
  }
  
  use Sub::Exporter -setup => {
    exports => [ qw(
      like
      name_map
      merge_col
      curry_method curry_class
      curry_chain
      mixin_installer mixin_exporter
    ) ]
  };
  
  =head1 AUTHOR
  
  Ricardo SIGNES, C<< <rjbs@cpan.org> >>
  
  =head1 BUGS
  
  Please report any bugs or feature requests through the web interface at
  L<http://rt.cpan.org>. I will be notified, and then you'll automatically be
  notified of progress on your bug as I make changes.
  
  =head1 COPYRIGHT
  
  Copyright 2006-2007, Ricardo SIGNES.  This program is free software;  you can
  redistribute it and/or modify it under the same terms as Perl itself.
  
  =cut
  
  1;
SUB_EXPORTER_UTIL

$fatpacked{"Sub/Install.pm"} = <<'SUB_INSTALL';
  package Sub::Install;
  
  use warnings;
  use strict;
  
  use Carp;
  use Scalar::Util ();
  
  =head1 NAME
  
  Sub::Install - install subroutines into packages easily
  
  =head1 VERSION
  
  version 0.925
  
  =cut
  
  our $VERSION = '0.925';
  
  =head1 SYNOPSIS
  
    use Sub::Install;
  
    Sub::Install::install_sub({
      code => sub { ... },
      into => $package,
      as   => $subname
    });
  
  =head1 DESCRIPTION
  
  This module makes it easy to install subroutines into packages without the
  unslightly mess of C<no strict> or typeglobs lying about where just anyone can
  see them.
  
  =head1 FUNCTIONS
  
  =head2 install_sub
  
    Sub::Install::install_sub({
     code => \&subroutine,
     into => "Finance::Shady",
     as   => 'launder',
    });
  
  This routine installs a given code reference into a package as a normal
  subroutine.  The above is equivalent to:
  
    no strict 'refs';
    *{"Finance::Shady" . '::' . "launder"} = \&subroutine;
  
  If C<into> is not given, the sub is installed into the calling package.
  
  If C<code> is not a code reference, it is looked for as an existing sub in the
  package named in the C<from> parameter.  If C<from> is not given, it will look
  in the calling package.
  
  If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>.
  If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to
  find the name of the given code ref and use that as C<as>.
  
  That means that this code:
  
    Sub::Install::install_sub({
      code => 'twitch',
      from => 'Person::InPain',
      into => 'Person::Teenager',
      as   => 'dance',
    });
  
  is the same as:
  
    package Person::Teenager;
  
    Sub::Install::install_sub({
      code => Person::InPain->can('twitch'),
      as   => 'dance',
    });
  
  =head2 reinstall_sub
  
  This routine behaves exactly like C<L</install_sub>>, but does not emit a
  warning if warnings are on and the destination is already defined.
  
  =cut
  
  sub _name_of_code {
    my ($code) = @_;
    require B;
    my $name = B::svref_2object($code)->GV->NAME;
    return $name unless $name =~ /\A__ANON__/;
    return;
  }
  
  # See also Params::Util, to which this code was donated.
  sub _CODELIKE {
    (Scalar::Util::reftype($_[0])||'') eq 'CODE'
    || Scalar::Util::blessed($_[0])
    && (overload::Method($_[0],'&{}') ? $_[0] : undef);
  }
  
  # do the heavy lifting
  sub _build_public_installer {
    my ($installer) = @_;
  
    sub {
      my ($arg) = @_;
      my ($calling_pkg) = caller(0);
  
      # I'd rather use ||= but I'm whoring for Devel::Cover.
      for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} }
  
      # This is the only absolutely required argument, in many cases.
      Carp::croak "named argument 'code' is not optional" unless $arg->{code};
  
      if (_CODELIKE($arg->{code})) {
        $arg->{as} ||= _name_of_code($arg->{code});
      } else {
        Carp::croak
          "couldn't find subroutine named $arg->{code} in package $arg->{from}"
          unless my $code = $arg->{from}->can($arg->{code});
  
        $arg->{as}   = $arg->{code} unless $arg->{as};
        $arg->{code} = $code;
      }
  
      Carp::croak "couldn't determine name under which to install subroutine"
        unless $arg->{as};
  
      $installer->(@$arg{qw(into as code) });
    }
  }
  
  # do the ugly work
  
  my $_misc_warn_re;
  my $_redef_warn_re;
  BEGIN {
    $_misc_warn_re = qr/
      Prototype\ mismatch:\ sub\ .+?  |
      Constant subroutine \S+ redefined
    /x;
    $_redef_warn_re = qr/Subroutine\ \S+\ redefined/x;
  }
  
  my $eow_re;
  BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ };
  
  sub _do_with_warn {
    my ($arg) = @_;
    my $code = delete $arg->{code};
    my $wants_code = sub {
      my $code = shift;
      sub {
        my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic
        local $SIG{__WARN__} = sub {
          my ($error) = @_;
          for (@{ $arg->{suppress} }) {
              return if $error =~ $_;
          }
          for (@{ $arg->{croak} }) {
            if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
              Carp::croak $base_error;
            }
          }
          for (@{ $arg->{carp} }) {
            if (my ($base_error) = $error =~ /\A($_) $eow_re/x) {
              return $warn->(Carp::shortmess $base_error);
            }
          }
          ($arg->{default} || $warn)->($error);
        };
        $code->(@_);
      };
    };
    return $wants_code->($code) if $code;
    return $wants_code;
  }
  
  sub _installer {
    sub {
      my ($pkg, $name, $code) = @_;
      no strict 'refs'; ## no critic ProhibitNoStrict
      *{"$pkg\::$name"} = $code;
      return $code;
    }
  }
  
  BEGIN {
    *_ignore_warnings = _do_with_warn({
      carp => [ $_misc_warn_re, $_redef_warn_re ]
    });
  
    *install_sub = _build_public_installer(_ignore_warnings(_installer));
  
    *_carp_warnings =  _do_with_warn({
      carp     => [ $_misc_warn_re ],
      suppress => [ $_redef_warn_re ],
    });
  
    *reinstall_sub = _build_public_installer(_carp_warnings(_installer));
  
    *_install_fatal = _do_with_warn({
      code     => _installer,
      croak    => [ $_redef_warn_re ],
    });
  }
  
  =head2 install_installers
  
  This routine is provided to allow Sub::Install compatibility with
  Sub::Installer.  It installs C<install_sub> and C<reinstall_sub> methods into
  the package named by its argument.
  
   Sub::Install::install_installers('Code::Builder'); # just for us, please
   Code::Builder->install_sub({ name => $code_ref });
  
   Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk?
   Anything::At::All->install_sub({ name => $code_ref });
  
  The installed installers are similar, but not identical, to those provided by
  Sub::Installer.  They accept a single hash as an argument.  The key/value pairs
  are used as the C<as> and C<code> parameters to the C<install_sub> routine
  detailed above.  The package name on which the method is called is used as the
  C<into> parameter.
  
  Unlike Sub::Installer's C<install_sub> will not eval strings into code, but
  will look for named code in the calling package.
  
  =cut
  
  sub install_installers {
    my ($into) = @_;
  
    for my $method (qw(install_sub reinstall_sub)) {
      my $code = sub {
        my ($package, $subs) = @_;
        my ($caller) = caller(0);
        my $return;
        for (my ($name, $sub) = %$subs) {
          $return = Sub::Install->can($method)->({
            code => $sub,
            from => $caller,
            into => $package,
            as   => $name
          });
        }
        return $return;
      };
      install_sub({ code => $code, into => $into, as => $method });
    }
  }
  
  =head1 EXPORTS
  
  Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are
  requested.
  
  =head2 exporter
  
  Sub::Install has a never-exported subroutine called C<exporter>, which is used
  to implement its C<import> routine.  It takes a hashref of named arguments,
  only one of which is currently recognize: C<exports>.  This must be an arrayref
  of subroutines to offer for export.
  
  This routine is mainly for Sub::Install's own consumption.  Instead, consider
  L<Sub::Exporter>.
  
  =cut
  
  sub exporter {
    my ($arg) = @_;
    
    my %is_exported = map { $_ => undef } @{ $arg->{exports} };
  
    sub {
      my $class = shift;
      my $target = caller;
      for (@_) {
        Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_};
        install_sub({ code => $_, from => $class, into => $target });
      }
    }
  }
  
  BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); }
  
  =head1 SEE ALSO
  
  =over
  
  =item L<Sub::Installer>
  
  This module is (obviously) a reaction to Damian Conway's Sub::Installer, which
  does the same thing, but does it by getting its greasy fingers all over
  UNIVERSAL.  I was really happy about the idea of making the installation of
  coderefs less ugly, but I couldn't bring myself to replace the ugliness of
  typeglobs and loosened strictures with the ugliness of UNIVERSAL methods.
  
  =item L<Sub::Exporter>
  
  This is a complete Exporter.pm replacement, built atop Sub::Install.
  
  =back
  
  =head1 AUTHOR
  
  Ricardo Signes, C<< <rjbs@cpan.org> >>
  
  Several of the tests are adapted from tests that shipped with Damian Conway's
  Sub-Installer distribution.
  
  =head1 BUGS
  
  Please report any bugs or feature requests through the web interface at
  L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be
  notified of progress on your bug as I make changes.
  
  =head1 COPYRIGHT
  
  Copyright 2005-2006 Ricardo Signes, 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;
SUB_INSTALL

$fatpacked{"Try/Tiny.pm"} = <<'TRY_TINY';
  package Try::Tiny;
  
  use strict;
  #use warnings;
  
  use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA);
  
  BEGIN {
  	require Exporter;
  	@ISA = qw(Exporter);
  }
  
  $VERSION = "0.07";
  
  $VERSION = eval $VERSION;
  
  @EXPORT = @EXPORT_OK = qw(try catch finally);
  
  $Carp::Internal{+__PACKAGE__}++;
  
  # 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) {
  		next unless $code_ref;
  
  		my $ref = ref($code_ref);
  
  		if ( $ref eq 'Try::Tiny::Catch' ) {
  			$catch = ${$code_ref};
  		} elsif ( $ref eq 'Try::Tiny::Finally' ) {
  			push @finally, ${$code_ref};
  		} else {
  			use Carp;
  			confess("Unknown code ref type given '${ref}'. Check your usage & try again");
  		}
  	}
  
  	# save the value of $@ so we can set $@ back to it in the beginning of the eval
  	my $prev_error = $@;
  
  	my ( @ret, $error, $failed );
  
  	# 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->();
  
  	{
  		# localize $@ to prevent clobbering of previous value by a successful
  		# eval.
  		local $@;
  
  		# failed will be true if the eval dies, because 1 will not be returned
  		# from the eval body
  		$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
  		};
  
  		# copy $@ to $error; when we leave this scope, local $@ will revert $@
  		# back to its previous value
  		$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 ) = @_;
  
  	return (
  		bless(\$block, 'Try::Tiny::Catch'),
  		@rest,
  	);
  }
  
  sub finally (&;@) {
  	my ( $block, @rest ) = @_;
  
  	return (
  		bless(\$block, 'Try::Tiny::Finally'),
  		@rest,
  	);
  }
  
  {
    package Try::Tiny::ScopeGuard;
  
    sub _new {
      shift;
      bless [ @_ ];
    }
  
    sub DESTROY {
      my @guts = @{ shift() };
      my $code = shift @guts;
      $code->(@guts);
    }
  }
  
  __PACKAGE__
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Try::Tiny - minimal try/catch with proper localization of $@
  
  =head1 SYNOPSIS
  
  	# handle errors with a catch handler
  	try {
  		die "foo";
  	} catch {
  		warn "caught error: $_"; # not $@
  	};
  
  	# 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 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 try block dies, it returns the value of the last statement executed in
  the catch block, if there is one. Otherwise, it returns C<undef> in scalar
  context or the empty list in list context. The following two examples both
  assign C<"bar"> to C<$x>.
  
  	my $x = try { die "foo" } catch { "bar" };
  
  	my $x = eval { die "foo" } || "bar";
  
  You can add finally blocks making the following true.
  
  	my $x;
  	try { die 'foo' } finally { $x = 'bar' };
  	try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
  
  Finally blocks are always executed making them suitable for cleanup code
  which cannot be handled using local.  You can add as many finally blocks to a
  given 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 try subroutine, an optional catch subroutine & 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 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 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>. 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 finally block is passed the error that was caught.  If no
  error was caught, it is passed nothing.  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 finally block>. C<Try::Tiny> will
  not do anything about handling possible errors coming from code located in these
  blocks.
  
  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 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 (before
  the localization) in the beginning of the C<eval> block.
  
  =head2 Localizing $@ silently masks errors
  
  Inside an 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 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 bar {
  		try { return "foo" };
  		return "baz";
  	}
  
  	say bar(); # "baz"
  
  =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
  			}
  		}
  	}
  
  =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://nothingmuch.woobling.org/talks/takahashi.xul?data=yapc_asia_2009/try_tiny.txt>
  
  Or read the source:
  
  L<http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
  
  =head1 VERSION CONTROL
  
  L<http://github.com/nothingmuch/try-tiny/>
  
  =head1 AUTHOR
  
  Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
  
  =head1 COPYRIGHT
  
  	Copyright (c) 2009 Yuval Kogman. All rights reserved.
  	This program is free software; you can redistribute
  	it and/or modify it under the terms of the MIT license.
  
  =cut
  
TRY_TINY

$fatpacked{"URI.pm"} = <<'URI';
  package URI;
  
  use strict;
  use vars qw($VERSION);
  $VERSION = "1.56";
  
  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;
      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;
  
      $$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;
  	$$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 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
  
  Using regexp variables like $1 directly as arguments to the URI 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");
  
  =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 - Escape and unescape 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 escape and unescape URI strings as
  defined by RFC 3986.
  
  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 do 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.
  
  The call:
  
      $uri = uri_escape_utf8($string);
  
  will be the same as:
  
      use Encode qw(encode);
      $uri = uri_escape(encode("UTF-8", $string));
  
  but will even work for perl-5.6 for chars in the 128 .. 255 range.
  
  Note: JavaScript has a function called escape() that produces the
  sequence "%uXXXX" for chars in the 256 .. 65535 range.  This function
  has really nothing to do with URI escaping but some folks got confused
  since it "does the right thing" in the 0 .. 255 range.  Because of
  this you sometimes see "URIs" with these kind of escapes.  The
  JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
  
  =item uri_unescape($string,...)
  
  Returns a string with each %XX sequence replaced with the actual byte
  (octet).
  
  This does the same as:
  
     $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  
  but does not modify the string in-place as this RE would.  Using the
  uri_unescape() function instead of the RE might make the code look
  cleaner and is a few characters less to type.
  
  In a simple benchmark test I did,
  calling the function (instead of the inline RE above) if a few chars
  were unescaped was something like 40% slower, and something like 700% slower if none were.  If
  you are going to unescape a lot of times it might be a good idea to
  inline the RE.
  
  If the uri_unescape() function is passed multiple strings, then each
  one is returned unescaped.
  
  =back
  
  The module can also export the C<%escapes> hash, which contains the
  mapping from all 256 bytes to the corresponding escape codes.  Lookup
  in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
  each time.
  
  =head1 SEE ALSO
  
  L<URI>
  
  
  =head1 COPYRIGHT
  
  Copyright 1995-2004 Gisle Aas.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
  
  use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  use vars qw(%escapes);
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
  @EXPORT_OK = qw(%escapes);
  $VERSION = "3.30";
  
  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;
      if ($] < 5.008) {
  	$text =~ s/([^\0-\x7F])/do {my $o = ord($1); sprintf("%c%c", 0xc0 | ($o >> 6), 0x80 | ($o & 0x3f)) }/ge;
      }
      else {
  	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
  	foreach (@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.19";
  
  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)\./) {
  	$_ = "http://$_";
  
      } elsif (/^(ftp|gopher|news|wais|http|https)\./) {
  	$_ = "$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;
  
  	    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;
  		}
  	    }
  	    $_ = "http://$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;
  	my @keys;
  	for (my $i = 0; $i < @old; $i += 2) {
  	    push(@keys, $old[$i]) unless $seen{$old[$i]}++;
  	}
  	return @keys;
      }
  
      my $key = shift;
      my @i;
  
      for (my $i = 0; $i < @old; $i += 2) {
  	push(@i, $i) if $old[$i] eq $key;
      }
  
      if (@_) {
  	my @new = @old;
  	my @new_i = @i;
  	my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
  	#print "VALS:@vals [@i]\n";
  	while (@new_i > @vals) {
  	    #print "REMOVE $new_i[-1]\n";
  	    splice(@new, pop(@new_i), 2);
  	}
  	while (@vals > @new_i) {
  	    my $i = @new_i ? $new_i[-1] + 2 : @new;
  	    #print "SPLICE $i\n";
  	    splice(@new, $i, 0, $key => pop(@vals));
  	}
  	for (@vals) {
  	    #print "SET $new_i[0]\n";
  	    $new[shift(@new_i)+1] = $_;
  	}
  
  	$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;
      $self->query_form($self->query_form, $key => \@_);  # 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.03";
  
  # 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.19";
  
  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;
  	    $$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;
  	_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;
  	_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);
  
  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 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.11";
  
  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.03";
  
  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; # doesn't work in 5.6.x!
      my @input = map substr($input, $_, 1), 0..length($input)-1;
  
      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;
  	    $$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.20";
  
  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 uses ":" as path separator, but not in the same way
  as a generic URI. ":foo" is a relative name.  "foo:bar" is an absolute
  name.  Also, path segments can contain the "/" character as well as the
  literal "." or "..".  So the mapping looks like this:
  
    Mac                   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.11";
  
  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.10";
  
  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{"WWW/RobotRules.pm"} = <<'WWW_ROBOTRULES';
  package WWW::RobotRules;
  
  $VERSION = "6.01";
  sub Version { $VERSION; }
  
  use strict;
  use URI ();
  
  
  
  sub new {
      my($class, $ua) = @_;
  
      # This ugly hack is needed to ensure backwards compatibility.
      # The "WWW::RobotRules" class is now really abstract.
      $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules";
  
      my $self = bless { }, $class;
      $self->agent($ua);
      $self;
  }
  
  
  sub parse {
      my($self, $robot_txt_uri, $txt, $fresh_until) = @_;
      $robot_txt_uri = URI->new("$robot_txt_uri");
      my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port;
  
      $self->clear_rules($netloc);
      $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600));
  
      my $ua;
      my $is_me = 0;		# 1 iff this record is for me
      my $is_anon = 0;		# 1 iff this record is for *
      my $seen_disallow = 0;      # watch for missing record separators
      my @me_disallowed = ();	# rules disallowed for me
      my @anon_disallowed = ();	# rules disallowed for *
  
      # blank lines are significant, so turn CRLF into LF to avoid generating
      # false ones
      $txt =~ s/\015\012/\012/g;
  
      # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL)
      for(split(/[\012\015]/, $txt)) {
  
  	# Lines containing only a comment are discarded completely, and
          # therefore do not indicate a record boundary.
  	next if /^\s*\#/;
  
  	s/\s*\#.*//;        # remove comments at end-of-line
  
  	if (/^\s*$/) {	    # blank line
  	    last if $is_me; # That was our record. No need to read the rest.
  	    $is_anon = 0;
  	    $seen_disallow = 0;
  	}
          elsif (/^\s*User-Agent\s*:\s*(.*)/i) {
  	    $ua = $1;
  	    $ua =~ s/\s+$//;
  
  	    if ($seen_disallow) {
  		# treat as start of a new record
  		$seen_disallow = 0;
  		last if $is_me; # That was our record. No need to read the rest.
  		$is_anon = 0;
  	    }
  
  	    if ($is_me) {
  		# This record already had a User-agent that
  		# we matched, so just continue.
  	    }
  	    elsif ($ua eq '*') {
  		$is_anon = 1;
  	    }
  	    elsif($self->is_me($ua)) {
  		$is_me = 1;
  	    }
  	}
  	elsif (/^\s*Disallow\s*:\s*(.*)/i) {
  	    unless (defined $ua) {
  		warn "RobotRules <$robot_txt_uri>: Disallow without preceding User-agent\n" if $^W;
  		$is_anon = 1;  # assume that User-agent: * was intended
  	    }
  	    my $disallow = $1;
  	    $disallow =~ s/\s+$//;
  	    $seen_disallow = 1;
  	    if (length $disallow) {
  		my $ignore;
  		eval {
  		    my $u = URI->new_abs($disallow, $robot_txt_uri);
  		    $ignore++ if $u->scheme ne $robot_txt_uri->scheme;
  		    $ignore++ if lc($u->host) ne lc($robot_txt_uri->host);
  		    $ignore++ if $u->port ne $robot_txt_uri->port;
  		    $disallow = $u->path_query;
  		    $disallow = "/" unless length $disallow;
  		};
  		next if $@;
  		next if $ignore;
  	    }
  
  	    if ($is_me) {
  		push(@me_disallowed, $disallow);
  	    }
  	    elsif ($is_anon) {
  		push(@anon_disallowed, $disallow);
  	    }
  	}
          elsif (/\S\s*:/) {
               # ignore
          }
  	else {
  	    warn "RobotRules <$robot_txt_uri>: Malformed record: <$_>\n" if $^W;
  	}
      }
  
      if ($is_me) {
  	$self->push_rules($netloc, @me_disallowed);
      }
      else {
  	$self->push_rules($netloc, @anon_disallowed);
      }
  }
  
  
  #
  # Returns TRUE if the given name matches the
  # name of this robot
  #
  sub is_me {
      my($self, $ua_line) = @_;
      my $me = $self->agent;
  
      # See whether my short-name is a substring of the
      #  "User-Agent: ..." line that we were passed:
  
      if(index(lc($me), lc($ua_line)) >= 0) {
        return 1;
      }
      else {
        return '';
      }
  }
  
  
  sub allowed {
      my($self, $uri) = @_;
      $uri = URI->new("$uri");
  
      return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https';
       # Robots.txt applies to only those schemes.
  
      my $netloc = $uri->host . ":" . $uri->port;
  
      my $fresh_until = $self->fresh_until($netloc);
      return -1 if !defined($fresh_until) || $fresh_until < time;
  
      my $str = $uri->path_query;
      my $rule;
      for $rule ($self->rules($netloc)) {
  	return 1 unless length $rule;
  	return 0 if index($str, $rule) == 0;
      }
      return 1;
  }
  
  
  # The following methods must be provided by the subclass.
  sub agent;
  sub visit;
  sub no_visits;
  sub last_visits;
  sub fresh_until;
  sub push_rules;
  sub clear_rules;
  sub rules;
  sub dump;
  
  
  
  package WWW::RobotRules::InCore;
  
  use vars qw(@ISA);
  @ISA = qw(WWW::RobotRules);
  
  
  
  sub agent {
      my ($self, $name) = @_;
      my $old = $self->{'ua'};
      if ($name) {
          # Strip it so that it's just the short name.
          # I.e., "FooBot"                                      => "FooBot"
          #       "FooBot/1.2"                                  => "FooBot"
          #       "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot"
  
  	$name = $1 if $name =~ m/(\S+)/; # get first word
  	$name =~ s!/.*!!;  # get rid of version
  	unless ($old && $old eq $name) {
  	    delete $self->{'loc'}; # all old info is now stale
  	    $self->{'ua'} = $name;
  	}
      }
      $old;
  }
  
  
  sub visit {
      my($self, $netloc, $time) = @_;
      return unless $netloc;
      $time ||= time;
      $self->{'loc'}{$netloc}{'last'} = $time;
      my $count = \$self->{'loc'}{$netloc}{'count'};
      if (!defined $$count) {
  	$$count = 1;
      }
      else {
  	$$count++;
      }
  }
  
  
  sub no_visits {
      my ($self, $netloc) = @_;
      $self->{'loc'}{$netloc}{'count'};
  }
  
  
  sub last_visit {
      my ($self, $netloc) = @_;
      $self->{'loc'}{$netloc}{'last'};
  }
  
  
  sub fresh_until {
      my ($self, $netloc, $fresh_until) = @_;
      my $old = $self->{'loc'}{$netloc}{'fresh'};
      if (defined $fresh_until) {
  	$self->{'loc'}{$netloc}{'fresh'} = $fresh_until;
      }
      $old;
  }
  
  
  sub push_rules {
      my($self, $netloc, @rules) = @_;
      push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules);
  }
  
  
  sub clear_rules {
      my($self, $netloc) = @_;
      delete $self->{'loc'}{$netloc}{'rules'};
  }
  
  
  sub rules {
      my($self, $netloc) = @_;
      if (defined $self->{'loc'}{$netloc}{'rules'}) {
  	return @{$self->{'loc'}{$netloc}{'rules'}};
      }
      else {
  	return ();
      }
  }
  
  
  sub dump
  {
      my $self = shift;
      for (keys %$self) {
  	next if $_ eq 'loc';
  	print "$_ = $self->{$_}\n";
      }
      for (keys %{$self->{'loc'}}) {
  	my @rules = $self->rules($_);
  	print "$_: ", join("; ", @rules), "\n";
      }
  }
  
  
  1;
  
  __END__
  
  
  # Bender: "Well, I don't have anything else
  #          planned for today.  Let's get drunk!"
  
  =head1 NAME
  
  WWW::RobotRules - database of robots.txt-derived permissions
  
  =head1 SYNOPSIS
  
   use WWW::RobotRules;
   my $rules = WWW::RobotRules->new('MOMspider/1.0');
  
   use LWP::Simple qw(get);
  
   {
     my $url = "http://some.place/robots.txt";
     my $robots_txt = get $url;
     $rules->parse($url, $robots_txt) if defined $robots_txt;
   }
  
   {
     my $url = "http://some.other.place/robots.txt";
     my $robots_txt = get $url;
     $rules->parse($url, $robots_txt) if defined $robots_txt;
   }
  
   # Now we can check if a URL is valid for those servers
   # whose "robots.txt" files we've gotten and parsed:
   if($rules->allowed($url)) {
       $c = get $url;
       ...
   }
  
  =head1 DESCRIPTION
  
  This module parses F</robots.txt> files as specified in
  "A Standard for Robot Exclusion", at
  <http://www.robotstxt.org/wc/norobots.html>
  Webmasters can use the F</robots.txt> file to forbid conforming
  robots from accessing parts of their web site.
  
  The parsed files are kept in a WWW::RobotRules object, and this object
  provides methods to check if access to a given URL is prohibited.  The
  same WWW::RobotRules object can be used for one or more parsed
  F</robots.txt> files on any number of hosts.
  
  The following methods are provided:
  
  =over 4
  
  =item $rules = WWW::RobotRules->new($robot_name)
  
  This is the constructor for WWW::RobotRules objects.  The first
  argument given to new() is the name of the robot.
  
  =item $rules->parse($robot_txt_url, $content, $fresh_until)
  
  The parse() method takes as arguments the URL that was used to
  retrieve the F</robots.txt> file, and the contents of the file.
  
  =item $rules->allowed($uri)
  
  Returns TRUE if this robot is allowed to retrieve this URL.
  
  =item $rules->agent([$name])
  
  Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt
  rules and expire times out of the cache.
  
  =back
  
  =head1 ROBOTS.TXT
  
  The format and semantics of the "/robots.txt" file are as follows
  (this is an edited abstract of
  <http://www.robotstxt.org/wc/norobots.html>):
  
  The file consists of one or more records separated by one or more
  blank lines. Each record contains lines of the form
  
    <field-name>: <value>
  
  The field name is case insensitive.  Text after the '#' character on a
  line is ignored during parsing.  This is used for comments.  The
  following <field-names> can be used:
  
  =over 3
  
  =item User-Agent
  
  The value of this field is the name of the robot the record is
  describing access policy for.  If more than one I<User-Agent> field is
  present the record describes an identical access policy for more than
  one robot. At least one field needs to be present per record.  If the
  value is '*', the record describes the default access policy for any
  robot that has not not matched any of the other records.
  
  The I<User-Agent> fields must occur before the I<Disallow> fields.  If a
  record contains a I<User-Agent> field after a I<Disallow> field, that
  constitutes a malformed record.  This parser will assume that a blank
  line should have been placed before that I<User-Agent> field, and will
  break the record into two.  All the fields before the I<User-Agent> field
  will constitute a record, and the I<User-Agent> field will be the first
  field in a new record.
  
  =item Disallow
  
  The value of this field specifies a partial URL that is not to be
  visited. This can be a full path, or a partial path; any URL that
  starts with this value will not be retrieved
  
  =back
  
  Unrecognized records are ignored.
  
  =head1 ROBOTS.TXT EXAMPLES
  
  The following example "/robots.txt" file specifies that no robots
  should visit any URL starting with "/cyberworld/map/" or "/tmp/":
  
    User-agent: *
    Disallow: /cyberworld/map/ # This is an infinite virtual URL space
    Disallow: /tmp/ # these will soon disappear
  
  This example "/robots.txt" file specifies that no robots should visit
  any URL starting with "/cyberworld/map/", except the robot called
  "cybermapper":
  
    User-agent: *
    Disallow: /cyberworld/map/ # This is an infinite virtual URL space
  
    # Cybermapper knows where to go.
    User-agent: cybermapper
    Disallow:
  
  This example indicates that no robots should visit this site further:
  
    # go away
    User-agent: *
    Disallow: /
  
  This is an example of a malformed robots.txt file.
  
    # robots.txt for ancientcastle.example.com
    # I've locked myself away.
    User-agent: *
    Disallow: /
    # The castle is your home now, so you can go anywhere you like.
    User-agent: Belle
    Disallow: /west-wing/ # except the west wing!
    # It's good to be the Prince...
    User-agent: Beast
    Disallow:
  
  This file is missing the required blank lines between records.
  However, the intention is clear.
  
  =head1 SEE ALSO
  
  L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File>
  
  =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.
WWW_ROBOTRULES

$fatpacked{"WWW/RobotRules/AnyDBM_File.pm"} = <<'WWW_ROBOTRULES_ANYDBM_FILE';
  package WWW::RobotRules::AnyDBM_File;
  
  require  WWW::RobotRules;
  @ISA = qw(WWW::RobotRules);
  $VERSION = "6.00";
  
  use Carp ();
  use AnyDBM_File;
  use Fcntl;
  use strict;
  
  =head1 NAME
  
  WWW::RobotRules::AnyDBM_File - Persistent RobotRules
  
  =head1 SYNOPSIS
  
   require WWW::RobotRules::AnyDBM_File;
   require LWP::RobotUA;
  
   # Create a robot useragent that uses a diskcaching RobotRules
   my $rules = WWW::RobotRules::AnyDBM_File->new( 'my-robot/1.0', 'cachefile' );
   my $ua = WWW::RobotUA->new( 'my-robot/1.0', 'me@foo.com', $rules );
  
   # Then just use $ua as usual
   $res = $ua->request($req);
  
  =head1 DESCRIPTION
  
  This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File
  package to implement persistent diskcaching of F<robots.txt> and host
  visit information.
  
  The constructor (the new() method) takes an extra argument specifying
  the name of the DBM file to use.  If the DBM file already exists, then
  you can specify undef as agent name as the name can be obtained from
  the DBM database.
  
  =cut
  
  sub new 
  { 
    my ($class, $ua, $file) = @_;
    Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file;
  
    my $self = bless { }, $class;
    $self->{'filename'} = $file;
    tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640
      or Carp::croak("Can't open $file: $!");
    
    if ($ua) {
        $self->agent($ua);
    }
    else {
        # Try to obtain name from DBM file
        $ua = $self->{'dbm'}{"|ua-name|"};
        Carp::croak("No agent name specified") unless $ua;
    }
  
    $self;
  }
  
  sub agent {
      my($self, $newname) = @_;
      my $old = $self->{'dbm'}{"|ua-name|"};
      if (defined $newname) {
  	$newname =~ s!/?\s*\d+.\d+\s*$!!;  # loose version
  	unless ($old && $old eq $newname) {
  	# Old info is now stale.
  	    my $file = $self->{'filename'};
  	    untie %{$self->{'dbm'}};
  	    tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640;
  	    %{$self->{'dbm'}} = ();
  	    $self->{'dbm'}{"|ua-name|"} = $newname;
  	}
      }
      $old;
  }
  
  sub no_visits {
      my ($self, $netloc) = @_;
      my $t = $self->{'dbm'}{"$netloc|vis"};
      return 0 unless $t;
      (split(/;\s*/, $t))[0];
  }
  
  sub last_visit {
      my ($self, $netloc) = @_;
      my $t = $self->{'dbm'}{"$netloc|vis"};
      return undef unless $t;
      (split(/;\s*/, $t))[1];
  }
  
  sub fresh_until {
      my ($self, $netloc, $fresh) = @_;
      my $old = $self->{'dbm'}{"$netloc|exp"};
      if ($old) {
  	$old =~ s/;.*//;  # remove cleartext
      }
      if (defined $fresh) {
  	$fresh .= "; " . localtime($fresh);
  	$self->{'dbm'}{"$netloc|exp"} = $fresh;
      }
      $old;
  }
  
  sub visit {
      my($self, $netloc, $time) = @_;
      $time ||= time;
  
      my $count = 0;
      my $old = $self->{'dbm'}{"$netloc|vis"};
      if ($old) {
  	my $last;
  	($count,$last) = split(/;\s*/, $old);
  	$time = $last if $last > $time;
      }
      $count++;
      $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time);
  }
  
  sub push_rules {
      my($self, $netloc, @rules) = @_;
      my $cnt = 1;
      $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"};
  
      foreach (@rules) {
  	$self->{'dbm'}{"$netloc|r$cnt"} = $_;
  	$cnt++;
      }
  }
  
  sub clear_rules {
      my($self, $netloc) = @_;
      my $cnt = 1;
      while ($self->{'dbm'}{"$netloc|r$cnt"}) {
  	delete $self->{'dbm'}{"$netloc|r$cnt"};
  	$cnt++;
      }
  }
  
  sub rules {
      my($self, $netloc) = @_;
      my @rules = ();
      my $cnt = 1;
      while (1) {
  	my $rule = $self->{'dbm'}{"$netloc|r$cnt"};
  	last unless $rule;
  	push(@rules, $rule);
  	$cnt++;
      }
      @rules;
  }
  
  sub dump
  {
  }
  
  1;
  
  =head1 SEE ALSO
  
  L<WWW::RobotRules>, L<LWP::RobotUA>
  
  =head1 AUTHORS
  
  Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no>
  
  =cut
  
WWW_ROBOTRULES_ANYDBM_FILE

$fatpacked{"common/sense.pm"} = <<'COMMON_SENSE';
  
  =head1 NAME
  
  common::sense - save a tree AND a kitten, use common::sense!
  
  =head1 SYNOPSIS
  
   use common::sense;
  
   # supposed to be the same, with much lower memory usage, as:
   #
   # use utf8;
   # use strict qw(vars subs);
   # use feature qw(say state switch);
   # no warnings;
   # use warnings qw(FATAL closed threads internal debugging pack malloc
   #                 portable prototype inplace io pipe unpack regexp
   #                 deprecated exiting glob digit printf layer
   #                 reserved taint closure semicolon);
   # no warnings qw(exec newline unopened);
  
  =head1 DESCRIPTION
  
  This module implements some sane defaults for Perl programs, as defined by
  two typical (or not so typical - use your common sense) specimens of Perl
  coders. In fact, after working out details on which warnings and strict
  modes to enable and make fatal, we found that we (and our code written so
  far, and others) fully agree on every option, even though we never used
  warnings before, so it seems this module indeed reflects a "common" sense
  among some long-time Perl coders.
  
  The basic philosophy behind the choices made in common::sense can be
  summarised as: "enforcing strict policies to catch as many bugs as
  possible, while at the same time, not limiting the expressive power
  available to the programmer".
  
  Two typical examples of how this philosophy is applied in practise is the
  handling of uninitialised and malloc warnings:
  
  =over 4
  
  =item I<uninitialised>
  
  C<undef> is a well-defined feature of perl, and enabling warnings for
  using it rarely catches any bugs, but considerably limits you in what you
  can do, so uninitialised warnings are disabled.
  
  =item I<malloc>
  
  Freeing something twice on the C level is a serious bug, usually causing
  memory corruption. It often leads to side effects much later in the
  program and there are no advantages to not reporting this, so malloc
  warnings are fatal by default.
  
  =back
  
  What follows is a more thorough discussion of what this module does,
  and why it does it, and what the advantages (and disadvantages) of this
  approach are.
  
  =head1 RATIONALE
  
  =over 4
  
  =item use utf8
  
  While it's not common sense to write your programs in UTF-8, it's quickly
  becoming the most common encoding, is the designated future default
  encoding for perl sources, and the most convenient encoding available
  (you can do really nice quoting tricks...). Experience has shown that our
  programs were either all pure ascii or utf-8, both of which will stay the
  same.
  
  There are few drawbacks to enabling UTF-8 source code by default (mainly
  some speed hits due to bugs in older versions of perl), so this module
  enables UTF-8 source code encoding by default.
  
  
  =item use strict qw(subs vars)
  
  Using C<use strict> is definitely common sense, but C<use strict
  'refs'> definitely overshoots its usefulness. After almost two
  decades of Perl hacking, we decided that it does more harm than being
  useful. Specifically, constructs like these:
  
     @{ $var->[0] }
  
  Must be written like this (or similarly), when C<use strict 'refs'> is in
  scope, and C<$var> can legally be C<undef>:
  
     @{ $var->[0] || [] }
  
  This is annoying, and doesn't shield against obvious mistakes such as
  using C<"">, so one would even have to write (at least for the time
  being):
  
     @{ defined $var->[0] ? $var->[0] : [] }
  
  ... which nobody with a bit of common sense would consider
  writing: clear code is clearly something else.
  
  Curiously enough, sometimes perl is not so strict, as this works even with
  C<use strict> in scope:
  
     for (@{ $var->[0] }) { ...
  
  If that isn't hypocrisy! And all that from a mere program!
  
  
  =item use feature qw(say state given)
  
  We found it annoying that we always have to enable extra features. If
  something breaks because it didn't anticipate future changes, so be
  it. 5.10 broke almost all our XS modules and nobody cared either (or at
  least I know of nobody who really complained about gratuitous changes -
  as opposed to bugs).
  
  Few modules that are not actively maintained work with newer versions of
  Perl, regardless of use feature or not, so a new major perl release means
  changes to many modules - new keywords are just the tip of the iceberg.
  
  If your code isn't alive, it's dead, Jim - be an active maintainer.
  
  But nobody forces you to use those extra features in modules meant for
  older versions of perl - common::sense of course works there as well.
  There is also an important other mode where having additional features by
  default is useful: commandline hacks and internal use scripts: See "much
  reduced typing", below.
  
  
  =item no warnings, but a lot of new errors
  
  Ah, the dreaded warnings. Even worse, the horribly dreaded C<-w>
  switch: Even though we don't care if other people use warnings (and
  certainly there are useful ones), a lot of warnings simply go against the
  spirit of Perl.
  
  Most prominently, the warnings related to C<undef>. There is nothing wrong
  with C<undef>: it has well-defined semantics, it is useful, and spitting
  out warnings you never asked for is just evil.
  
  The result was that every one of our modules did C<no warnings> in the
  past, to avoid somebody accidentally using and forcing his bad standards
  on our code. Of course, this switched off all warnings, even the useful
  ones. Not a good situation. Really, the C<-w> switch should only enable
  warnings for the main program only.
  
  Funnily enough, L<perllexwarn> explicitly mentions C<-w> (and not in a
  favourable way, calling it outright "wrong"), but standard utilities, such
  as L<prove>, or MakeMaker when running C<make test>, still enable them
  blindly.
  
  For version 2 of common::sense, we finally sat down a few hours and went
  through I<every single warning message>, identifiying - according to
  common sense - all the useful ones.
  
  This resulted in the rather impressive list in the SYNOPSIS. When we
  weren't sure, we didn't include the warning, so the list might grow in
  the future (we might have made a mistake, too, so the list might shrink
  as well).
  
  Note the presence of C<FATAL> in the list: we do not think that the
  conditions caught by these warnings are worthy of a warning, we I<insist>
  that they are worthy of I<stopping> your program, I<instantly>. They are
  I<bugs>!
  
  Therefore we consider C<common::sense> to be much stricter than C<use
  warnings>, which is good if you are into strict things (we are not,
  actually, but these things tend to be subjective).
  
  After deciding on the list, we ran the module against all of our code that
  uses C<common::sense> (that is almost all of our code), and found only one
  occurence where one of them caused a problem: one of elmex's (unreleased)
  modules contained:
  
     $fmt =~ s/([^\s\[]*)\[( [^\]]* )\]/\x0$1\x1$2\x0/xgo;
  
  We quickly agreed that indeed the code should be changed, even though it
  happened to do the right thing when the warning was switched off.
  
  
  =item much reduced typing
  
  Especially with version 2.0 of common::sense, the amount of boilerplate
  code you need to add to gte I<this> policy is daunting. Nobody would write
  this out in throwaway scripts, commandline hacks or in quick internal-use
  scripts.
  
  By using common::sense you get a defined set of policies (ours, but maybe
  yours, too, if you accept them), and they are easy to apply to your
  scripts: typing C<use common::sense;> is even shorter than C<use warnings;
  use strict; use feature ...>.
  
  And you can immediately use the features of your installed perl, which
  is more difficult in code you release, but not usually an issue for
  internal-use code (downgrades of your production perl should be rare,
  right?).
  
  
  =item mucho reduced memory usage
  
  Just using all those pragmas mentioned in the SYNOPSIS together wastes
  <blink>I<< B<776> kilobytes >></blink> of precious memory in my perl, for
  I<every single perl process using our code>, which on our machines, is a
  lot. In comparison, this module only uses I<< B<four> >> kilobytes (I even
  had to write it out so it looks like more) of memory on the same platform.
  
  The money/time/effort/electricity invested in these gigabytes (probably
  petabytes globally!) of wasted memory could easily save 42 trees, and a
  kitten!
  
  Unfortunately, until everybods applies more common sense, there will still
  often be modules that pull in the monster pragmas. But one can hope...
  
  =cut
  
  package common::sense;
  
  our $VERSION = '3.2';
  
  # overload should be included
  
  sub import {
     # use warnings
     ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\xfc\x3f\x33\x00\x0f\xf3\x0f\xc0\xf0\xfc\x33\x00";
     # use strict, use utf8;
     $^H |= 0x800600;
     # use feature
     $^H{feature_switch} =
     $^H{feature_say}    =
     $^H{feature_state}  = 1;
  }
  
  1;
  
  =back
  
  =head1 THERE IS NO 'no common::sense'!!!! !!!! !!
  
  This module doesn't offer an unimport. First of all, it wastes even more
  memory, second, and more importantly, who with even a bit of common sense
  would want no common sense?
  
  =head1 STABILITY AND FUTURE VERSIONS
  
  Future versions might change just about everything in this module. We
  might test our modules and upload new ones working with newer versions of
  this module, and leave you standing in the rain because we didn't tell
  you. In fact, we did so when switching from 1.0 to 2.0, which enabled gobs
  of warnings, and made them FATAL on top.
  
  Maybe we will load some nifty modules that try to emulate C<say> or so
  with perls older than 5.10 (this module, of course, should work with older
  perl versions - supporting 5.8 for example is just common sense at this
  time. Maybe not in the future, but of course you can trust our common
  sense to be consistent with, uhm, our opinion).
  
  =head1 WHAT OTHER PEOPLE HAD TO SAY ABOUT THIS MODULE
  
  apeiron
  
     "... wow"
     "I hope common::sense is a joke."
  
  crab
  
     "i wonder how it would be if joerg schilling wrote perl modules."
  
  Adam Kennedy
  
     "Very interesting, efficient, and potentially something I'd use all the time."
     [...]
     "So no common::sense for me, alas."
  
  H.Merijn Brand
  
     "Just one more reason to drop JSON::XS from my distribution list"
  
  Pista Palo
  
     "Something in short supply these days..."
  
  Steffen Schwigon
  
     "This module is quite for sure *not* just a repetition of all the other
     'use strict, use warnings'-approaches, and it's also not the opposite.
     [...] And for its chosen middle-way it's also not the worst name ever.
     And everything is documented."
  
  BKB
  
     "[Deleted - thanks to Steffen Schwigon for pointing out this review was
     in error.]"
  
  Somni
  
     "the arrogance of the guy"
     "I swear he tacked somenoe else's name onto the module
     just so he could use the royal 'we' in the documentation"
  
  Anonymous Monk
  
     "You just gotta love this thing, its got META.json!!!"
  
  dngor
  
     "Heh.  '"<elmex at ta-sa.org>"'  The quotes are semantic
     distancing from that e-mail address."
  
  Jerad Pierce
  
     "Awful name (not a proper pragma), and the SYNOPSIS doesn't tell you
     anything either. Nor is it clear what features have to do with "common
     sense" or discipline."
  
  acme
  
     "THERE IS NO 'no common::sense'!!!! !!!! !!"
  
  apeiron (meta-comment about us commenting^Wquoting his comment)
  
     "How about quoting this: get a clue, you fucktarded amoeba."
  
  quanth
  
     "common sense is beautiful, json::xs is fast, Anyevent, EV are fast and
     furious. I love mlehmannware ;)"
  
  apeiron
  
     "... it's mlehmann's view of what common sense is. His view of common
     sense is certainly uncommon, insofar as anyone with a clue disagrees
     with him."
  
  apeiron (another meta-comment)
  
     "apeiron wonders if his little informant is here to steal more quotes"
  
  ew73
  
     "... I never got past the SYNOPSIS before calling it shit."
     [...]
     How come no one ever quotes me. :("
  
  =head1 FREQUENTLY ASKED QUESTIONS
  
  Or frequently-come-up confusions.
  
  =over 4
  
  =item Is this module meant to be serious?
  
  Yes, we would have put it under the C<Acme::> namespace otherwise.
  
  =item But the manpage is written in a funny/stupid/... way?
  
  This was meant to make it clear that our common sense is a subjective
  thing and other people can use their own notions, taking the steam out
  of anybody who might be offended (as some people are always offended no
  matter what you do).
  
  This was a failure.
  
  But we hope the manpage still is somewhat entertaining even though it
  explains boring rationale.
  
  =item Why do you impose your conventions on my code?
  
  For some reason people keep thinking that C<common::sense> imposes
  process-wide limits, even though the SYNOPSIS makes it clear that it works
  like other similar modules - i.e. only within the scope that C<use>s them.
  
  So, no, we don't - nobody is forced to use this module, and using a module
  that relies on common::sense does not impose anything on you.
  
  =item Why do you think only your notion of common::sense is valid?
  
  Well, we don't, and have clearly written this in the documentation to
  every single release. We were just faster than anybody else w.r.t. to
  grabbing the namespace.
  
  =item But everybody knows that you have to use strict and use warnings,
  why do you disable them?
  
  Well, we don't do this either - we selectively disagree with the
  usefulness of some warnings over others. This module is aimed at
  experienced Perl programmers, not people migrating from other languages
  who might be surprised about stuff such as C<undef>. On the other hand,
  this does not exclude the usefulness of this module for total newbies, due
  to its strictness in enforcing policy, while at the same time not limiting
  the expresive power of perl.
  
  This module is considerably I<more> strict than the canonical C<use
  strict; use warnings>, as it makes all its warnings fatal in nature, so
  you can not get away with as many things as with the canonical approach.
  
  This was not implemented in version 1.0 because of the daunting number
  of warning categories and the difficulty in getting exactly the set of
  warnings you wish (i.e. look at the SYNOPSIS in how complicated it is to
  get a specific set of warnings - it is not reasonable to put this into
  every module, the maintenance effort would be enourmous).
  
  =item But many modules C<use strict> or C<use warnings>, so the memory
  savings do not apply?
  
  I suddenly feel sad...
  
  But yes, that's true. Fortunately C<common::sense> still uses only a
  miniscule amount of RAM.
  
  =item But it adds another dependency to your modules!
  
  It's a fact, yeah. But it's trivial to install, most popular modules have
  many more dependencies and we consider dependencies a good thing - it
  leads to better APIs, more thought about interworking of modules and so
  on.
  
  =item Why do you use JSON and not YAML for your META.yml?
  
  This is not true - YAML supports a large subset of JSON, and this subset
  is what META.yml is written in, so it would be correct to say "the
  META.yml is written in a common subset of YAML and JSON".
  
  The META.yml follows the YAML, JSON and META.yml specifications, and is
  correctly parsed by CPAN, so if you have trouble with it, the problem is
  likely on your side.
  
  =item But! But!
  
  Yeah, we know.
  
  =back
  
  =head1 AUTHOR
  
   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/
  
   Robin Redeker, "<elmex at ta-sa.org>".
  
  =cut
  
COMMON_SENSE

$fatpacked{"darwin-thread-multi-2level/Bundle/DBI.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_BUNDLE_DBI';
  # -*- perl -*-
  
  package Bundle::DBI;
  
  our $VERSION = sprintf("12.%06d", q$Revision: 8695 $ =~ /(\d+)/o);
  
  1;
  
  __END__
  
  =head1 NAME
  
  Bundle::DBI - A bundle to install DBI and required modules.
  
  =head1 SYNOPSIS
  
    perl -MCPAN -e 'install Bundle::DBI'
  
  =head1 CONTENTS
  
  DBI - for to get to know thyself
  
  DBI::Shell 11.91 - the DBI command line shell
  
  Storable 2.06 - for DBD::Proxy, DBI::ProxyServer, DBD::Forward
  
  Net::Daemon 0.37 - for DBD::Proxy and DBI::ProxyServer
  
  RPC::PlServer 0.2016 - for DBD::Proxy and DBI::ProxyServer
  
  DBD::Multiplex 1.19 - treat multiple db handles as one
  
  =head1 DESCRIPTION
  
  This bundle includes all the modules used by the Perl Database
  Interface (DBI) module, created by Tim Bunce.
  
  A I<Bundle> is a module that simply defines a collection of other
  modules.  It is used by the L<CPAN> module to automate the fetching,
  building and installing of modules from the CPAN ftp archive sites.
  
  This bundle does not deal with the various database drivers (e.g.
  DBD::Informix, DBD::Oracle etc), most of which require software from
  sources other than CPAN. You'll need to fetch and build those drivers
  yourself.
  
  =head1 AUTHORS
  
  Jonathan Leffler, Jochen Wiedmann and Tim Bunce.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_BUNDLE_DBI

$fatpacked{"darwin-thread-multi-2level/Class/Load/XS.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_LOAD_XS';
  package Class::Load::XS;
  {
    $Class::Load::XS::VERSION = '0.03';
  }
  
  use strict;
  use warnings;
  
  use XSLoader;
  XSLoader::load(
      __PACKAGE__,
      exists $Class::Load::XS::{VERSION}
      ? ${ $Class::Load::XS::{VERSION} }
      : (),
  );
  
  1;
  
  # ABSTRACT: XS implementation of parts of Class::Load
  
  
  
  =pod
  
  =head1 NAME
  
  Class::Load::XS - XS implementation of parts of Class::Load
  
  =head1 VERSION
  
  version 0.03
  
  =head1 SYNOPSIS
  
      use Class::Load;
  
  =head1 DESCRIPTION
  
  This module provides an XS implementation for portions of L<Class::Load>. See
  L<Class::Load> for API details.
  
  =head1 AUTHOR
  
  Dave Rolsky <autarch@urth.org>
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is Copyright (c) 2011 by Dave Rolsky.
  
  This is free software, licensed under:
  
    The Artistic License 2.0 (GPL Compatible)
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_LOAD_XS

$fatpacked{"darwin-thread-multi-2level/Class/MOP.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP';
  
  package Class::MOP;
  BEGIN {
    $Class::MOP::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use 5.008;
  
  use MRO::Compat;
  
  use Carp          'confess';
  use Class::Load   ();
  use Scalar::Util  'weaken', 'isweak', 'reftype', 'blessed';
  use Data::OptList;
  use Try::Tiny;
  
  use Class::MOP::Mixin::AttributeCore;
  use Class::MOP::Mixin::HasAttributes;
  use Class::MOP::Mixin::HasMethods;
  use Class::MOP::Class;
  use Class::MOP::Attribute;
  use Class::MOP::Method;
  
  BEGIN {
      *IS_RUNNING_ON_5_10 = ($] < 5.009_005)
          ? sub () { 0 }
          : sub () { 1 };
  
      # this is either part of core or set up appropriately by MRO::Compat
      *check_package_cache_flag = \&mro::get_pkg_gen;
  }
  
  XSLoader::load(
      'Moose',
      $Class::MOP::{VERSION} ? ${ $Class::MOP::{VERSION} } : ()
  );
  
  {
      # Metaclasses are singletons, so we cache them here.
      # there is no need to worry about destruction though
      # because they should die only when the program dies.
      # After all, do package definitions even get reaped?
      # Anonymous classes manage their own destruction.
      my %METAS;
  
      sub get_all_metaclasses         {        %METAS         }
      sub get_all_metaclass_instances { values %METAS         }
      sub get_all_metaclass_names     { keys   %METAS         }
      sub get_metaclass_by_name       { $METAS{$_[0]}         }
      sub store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
      sub weaken_metaclass            { weaken($METAS{$_[0]}) }
      sub metaclass_is_weak           { isweak($METAS{$_[0]}) }
      sub does_metaclass_exist        { exists $METAS{$_[0]} && defined $METAS{$_[0]} }
      sub remove_metaclass_by_name    { delete $METAS{$_[0]}; return }
  
      # This handles instances as well as class names
      sub class_of {
          return unless defined $_[0];
          my $class = blessed($_[0]) || $_[0];
          return $METAS{$class};
      }
  
      # NOTE:
      # We only cache metaclasses, meaning instances of
      # Class::MOP::Class. We do not cache instance of
      # Class::MOP::Package or Class::MOP::Module. Mostly
      # because I don't yet see a good reason to do so.
  }
  
  sub load_class {
      goto &Class::Load::load_class;
  }
  
  sub load_first_existing_class {
      goto &Class::Load::load_first_existing_class;
  }
  
  sub is_class_loaded {
      goto &Class::Load::is_class_loaded;
  }
  
  sub _definition_context {
      my %context;
      @context{qw(package file line)} = caller(1);
  
      return (
          definition_context => \%context,
      );
  }
  
  ## ----------------------------------------------------------------------------
  ## Setting up our environment ...
  ## ----------------------------------------------------------------------------
  ## Class::MOP needs to have a few things in the global perl environment so
  ## that it can operate effectively. Those things are done here.
  ## ----------------------------------------------------------------------------
  
  # ... nothing yet actually ;)
  
  ## ----------------------------------------------------------------------------
  ## Bootstrapping
  ## ----------------------------------------------------------------------------
  ## The code below here is to bootstrap our MOP with itself. This is also
  ## sometimes called "tying the knot". By doing this, we make it much easier
  ## to extend the MOP through subclassing and such since now you can use the
  ## MOP itself to extend itself.
  ##
  ## Yes, I know, thats weird and insane, but it's a good thing, trust me :)
  ## ----------------------------------------------------------------------------
  
  # We need to add in the meta-attributes here so that
  # any subclass of Class::MOP::* will be able to
  # inherit them using _construct_instance
  
  ## --------------------------------------------------------
  ## Class::MOP::Mixin::HasMethods
  
  Class::MOP::Mixin::HasMethods->meta->add_attribute(
      Class::MOP::Attribute->new('_methods' => (
          reader   => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map
          },
          default => sub { {} },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::HasMethods->meta->add_attribute(
      Class::MOP::Attribute->new('method_metaclass' => (
          reader   => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass
          },
          default  => 'Class::MOP::Method',
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::HasMethods->meta->add_attribute(
      Class::MOP::Attribute->new('wrapped_method_metaclass' => (
          reader   => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass
          },
          default  => 'Class::MOP::Method::Wrapped',
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Mixin::HasMethods
  
  Class::MOP::Mixin::HasAttributes->meta->add_attribute(
      Class::MOP::Attribute->new('attributes' => (
          reader   => {
              # NOTE: we need to do this in order
              # for the instance meta-object to
              # not fall into meta-circular death
              #
              # we just alias the original method
              # rather than re-produce it here
              '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map
          },
          default  => sub { {} },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::HasAttributes->meta->add_attribute(
      Class::MOP::Attribute->new('attribute_metaclass' => (
          reader   => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass
          },
          default  => 'Class::MOP::Attribute',
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Package
  
  Class::MOP::Package->meta->add_attribute(
      Class::MOP::Attribute->new('package' => (
          reader   => {
              # NOTE: we need to do this in order
              # for the instance meta-object to
              # not fall into meta-circular death
              #
              # we just alias the original method
              # rather than re-produce it here
              'name' => \&Class::MOP::Package::name
          },
          _definition_context(),
      ))
  );
  
  Class::MOP::Package->meta->add_attribute(
      Class::MOP::Attribute->new('namespace' => (
          reader => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'namespace' => \&Class::MOP::Package::namespace
          },
          init_arg => undef,
          default  => sub { \undef },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Module
  
  # NOTE:
  # yeah this is kind of stretching things a bit,
  # but truthfully the version should be an attribute
  # of the Module, the weirdness comes from having to
  # stick to Perl 5 convention and store it in the
  # $VERSION package variable. Basically if you just
  # squint at it, it will look how you want it to look.
  # Either as a package variable, or as a attribute of
  # the metaclass, isn't abstraction great :)
  
  Class::MOP::Module->meta->add_attribute(
      Class::MOP::Attribute->new('version' => (
          reader => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'version' => \&Class::MOP::Module::version
          },
          init_arg => undef,
          default  => sub { \undef },
          _definition_context(),
      ))
  );
  
  # NOTE:
  # By following the same conventions as version here,
  # we are opening up the possibility that people can
  # use the $AUTHORITY in non-Class::MOP modules as
  # well.
  
  Class::MOP::Module->meta->add_attribute(
      Class::MOP::Attribute->new('authority' => (
          reader => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'authority' => \&Class::MOP::Module::authority
          },
          init_arg => undef,
          default  => sub { \undef },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Class
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('superclasses' => (
          accessor => {
              # NOTE:
              # we just alias the original method
              # rather than re-produce it here
              'superclasses' => \&Class::MOP::Class::superclasses
          },
          init_arg => undef,
          default  => sub { \undef },
          _definition_context(),
      ))
  );
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('instance_metaclass' => (
          reader   => {
              # NOTE: we need to do this in order
              # for the instance meta-object to
              # not fall into meta-circular death
              #
              # we just alias the original method
              # rather than re-produce it here
              'instance_metaclass' => \&Class::MOP::Class::instance_metaclass
          },
          default  => 'Class::MOP::Instance',
          _definition_context(),
      ))
  );
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('immutable_trait' => (
          reader   => {
              'immutable_trait' => \&Class::MOP::Class::immutable_trait
          },
          default => "Class::MOP::Class::Immutable::Trait",
          _definition_context(),
      ))
  );
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('constructor_name' => (
          reader   => {
              'constructor_name' => \&Class::MOP::Class::constructor_name,
          },
          default => "new",
          _definition_context(),
      ))
  );
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('constructor_class' => (
          reader   => {
              'constructor_class' => \&Class::MOP::Class::constructor_class,
          },
          default => "Class::MOP::Method::Constructor",
          _definition_context(),
      ))
  );
  
  
  Class::MOP::Class->meta->add_attribute(
      Class::MOP::Attribute->new('destructor_class' => (
          reader   => {
              'destructor_class' => \&Class::MOP::Class::destructor_class,
          },
          _definition_context(),
      ))
  );
  
  # NOTE:
  # we don't actually need to tie the knot with
  # Class::MOP::Class here, it is actually handled
  # within Class::MOP::Class itself in the
  # _construct_class_instance method.
  
  ## --------------------------------------------------------
  ## Class::MOP::Mixin::AttributeCore
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('name' => (
          reader   => {
              # NOTE: we need to do this in order
              # for the instance meta-object to
              # not fall into meta-circular death
              #
              # we just alias the original method
              # rather than re-produce it here
              'name' => \&Class::MOP::Mixin::AttributeCore::name
          },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('accessor' => (
          reader    => { 'accessor'     => \&Class::MOP::Mixin::AttributeCore::accessor     },
          predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('reader' => (
          reader    => { 'reader'     => \&Class::MOP::Mixin::AttributeCore::reader     },
          predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('initializer' => (
          reader    => { 'initializer'     => \&Class::MOP::Mixin::AttributeCore::initializer     },
          predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('definition_context' => (
          reader    => { 'definition_context'     => \&Class::MOP::Mixin::AttributeCore::definition_context     },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('writer' => (
          reader    => { 'writer'     => \&Class::MOP::Mixin::AttributeCore::writer     },
          predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('predicate' => (
          reader    => { 'predicate'     => \&Class::MOP::Mixin::AttributeCore::predicate     },
          predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('clearer' => (
          reader    => { 'clearer'     => \&Class::MOP::Mixin::AttributeCore::clearer     },
          predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('builder' => (
          reader    => { 'builder'     => \&Class::MOP::Mixin::AttributeCore::builder     },
          predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('init_arg' => (
          reader    => { 'init_arg'     => \&Class::MOP::Mixin::AttributeCore::init_arg     },
          predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('default' => (
          # default has a custom 'reader' method ...
          predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default },
          _definition_context(),
      ))
  );
  
  Class::MOP::Mixin::AttributeCore->meta->add_attribute(
      Class::MOP::Attribute->new('insertion_order' => (
          reader      => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order },
          writer      => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order },
          predicate   => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Attribute
  Class::MOP::Attribute->meta->add_attribute(
      Class::MOP::Attribute->new('associated_class' => (
          reader   => {
              # NOTE: we need to do this in order
              # for the instance meta-object to
              # not fall into meta-circular death
              #
              # we just alias the original method
              # rather than re-produce it here
              'associated_class' => \&Class::MOP::Attribute::associated_class
          },
          _definition_context(),
      ))
  );
  
  Class::MOP::Attribute->meta->add_attribute(
      Class::MOP::Attribute->new('associated_methods' => (
          reader   => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
          default  => sub { [] },
          _definition_context(),
      ))
  );
  
  Class::MOP::Attribute->meta->add_method('clone' => sub {
      my $self  = shift;
      $self->meta->clone_object($self, @_);
  });
  
  ## --------------------------------------------------------
  ## Class::MOP::Method
  Class::MOP::Method->meta->add_attribute(
      Class::MOP::Attribute->new('body' => (
          reader   => { 'body' => \&Class::MOP::Method::body },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method->meta->add_attribute(
      Class::MOP::Attribute->new('associated_metaclass' => (
          reader   => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method->meta->add_attribute(
      Class::MOP::Attribute->new('package_name' => (
          reader   => { 'package_name' => \&Class::MOP::Method::package_name },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method->meta->add_attribute(
      Class::MOP::Attribute->new('name' => (
          reader   => { 'name' => \&Class::MOP::Method::name },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method->meta->add_attribute(
      Class::MOP::Attribute->new('original_method' => (
          reader   => { 'original_method'      => \&Class::MOP::Method::original_method },
          writer   => { '_set_original_method' => \&Class::MOP::Method::_set_original_method },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Method::Wrapped
  
  # NOTE:
  # the way this item is initialized, this
  # really does not follow the standard
  # practices of attributes, but we put
  # it here for completeness
  Class::MOP::Method::Wrapped->meta->add_attribute(
      Class::MOP::Attribute->new('modifier_table' => (
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Method::Generated
  
  Class::MOP::Method::Generated->meta->add_attribute(
      Class::MOP::Attribute->new('is_inline' => (
          reader   => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline },
          default  => 0,
          _definition_context(),
      ))
  );
  
  Class::MOP::Method::Generated->meta->add_attribute(
      Class::MOP::Attribute->new('definition_context' => (
          reader   => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context },
          _definition_context(),
      ))
  );
  
  
  ## --------------------------------------------------------
  ## Class::MOP::Method::Inlined
  
  Class::MOP::Method::Inlined->meta->add_attribute(
      Class::MOP::Attribute->new('_expected_method_class' => (
          reader   => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Method::Accessor
  
  Class::MOP::Method::Accessor->meta->add_attribute(
      Class::MOP::Attribute->new('attribute' => (
          reader   => {
              'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
          },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method::Accessor->meta->add_attribute(
      Class::MOP::Attribute->new('accessor_type' => (
          reader   => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Method::Constructor
  
  Class::MOP::Method::Constructor->meta->add_attribute(
      Class::MOP::Attribute->new('options' => (
          reader   => {
              'options' => \&Class::MOP::Method::Constructor::options
          },
          default  => sub { +{} },
          _definition_context(),
      ))
  );
  
  Class::MOP::Method::Constructor->meta->add_attribute(
      Class::MOP::Attribute->new('associated_metaclass' => (
          init_arg => "metaclass", # FIXME alias and rename
          reader   => {
              'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass
          },
          _definition_context(),
      ))
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Instance
  
  # NOTE:
  # these don't yet do much of anything, but are just
  # included for completeness
  
  Class::MOP::Instance->meta->add_attribute(
      Class::MOP::Attribute->new('associated_metaclass',
          reader   => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass },
          _definition_context(),
      ),
  );
  
  Class::MOP::Instance->meta->add_attribute(
      Class::MOP::Attribute->new('_class_name',
          init_arg => undef,
          reader   => { _class_name => \&Class::MOP::Instance::_class_name },
          #lazy     => 1, # not yet supported by Class::MOP but out our version does it anyway
          #default  => sub { $_[0]->associated_metaclass->name },
          _definition_context(),
      ),
  );
  
  Class::MOP::Instance->meta->add_attribute(
      Class::MOP::Attribute->new('attributes',
          reader   => { attributes => \&Class::MOP::Instance::get_all_attributes },
          _definition_context(),
      ),
  );
  
  Class::MOP::Instance->meta->add_attribute(
      Class::MOP::Attribute->new('slots',
          reader   => { slots => \&Class::MOP::Instance::slots },
          _definition_context(),
      ),
  );
  
  Class::MOP::Instance->meta->add_attribute(
      Class::MOP::Attribute->new('slot_hash',
          reader   => { slot_hash => \&Class::MOP::Instance::slot_hash },
          _definition_context(),
      ),
  );
  
  ## --------------------------------------------------------
  ## Class::MOP::Object
  
  # need to replace the meta method there with a real meta method object
  Class::MOP::Object->meta->_add_meta_method('meta');
  
  ## --------------------------------------------------------
  ## Class::MOP::Mixin
  
  # need to replace the meta method there with a real meta method object
  Class::MOP::Mixin->meta->_add_meta_method('meta');
  
  require Class::MOP::Deprecated unless our $no_deprecated;
  
  # we need the meta instance of the meta instance to be created now, in order
  # for the constructor to be able to use it
  Class::MOP::Instance->meta->get_meta_instance;
  
  # pretend the add_method never happenned. it hasn't yet affected anything
  undef Class::MOP::Instance->meta->{_package_cache_flag};
  
  ## --------------------------------------------------------
  ## Now close all the Class::MOP::* classes
  
  # NOTE: we don't need to inline the the accessors this only lengthens
  # the compile time of the MOP, and gives us no actual benefits.
  
  $_->meta->make_immutable(
      inline_constructor  => 0,
      constructor_name    => "_new",
      inline_accessors => 0,
  ) for qw/
      Class::MOP::Package
      Class::MOP::Module
      Class::MOP::Class
  
      Class::MOP::Attribute
      Class::MOP::Method
      Class::MOP::Instance
  
      Class::MOP::Object
  
      Class::MOP::Method::Generated
      Class::MOP::Method::Inlined
  
      Class::MOP::Method::Accessor
      Class::MOP::Method::Constructor
      Class::MOP::Method::Wrapped
  
      Class::MOP::Method::Meta
  /;
  
  $_->meta->make_immutable(
      inline_constructor  => 0,
      constructor_name    => undef,
      inline_accessors => 0,
  ) for qw/
      Class::MOP::Mixin
      Class::MOP::Mixin::AttributeCore
      Class::MOP::Mixin::HasAttributes
      Class::MOP::Mixin::HasMethods
  /;
  
  1;
  
  # ABSTRACT: A Meta Object Protocol for Perl 5
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP - A Meta Object Protocol for Perl 5
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This module is a fully functioning meta object protocol for the
  Perl 5 object system. It makes no attempt to change the behavior or
  characteristics of the Perl 5 object system, only to create a
  protocol for its manipulation and introspection.
  
  That said, it does attempt to create the tools for building a rich set
  of extensions to the Perl 5 object system. Every attempt has been made
  to abide by the spirit of the Perl 5 object system that we all know
  and love.
  
  This documentation is sparse on conceptual details. We suggest looking
  at the items listed in the L<SEE ALSO> section for more
  information. In particular the book "The Art of the Meta Object
  Protocol" was very influential in the development of this system.
  
  =head2 What is a Meta Object Protocol?
  
  A meta object protocol is an API to an object system.
  
  To be more specific, it abstracts the components of an object system
  (classes, object, methods, object attributes, etc.). These
  abstractions can then be used to inspect and manipulate the object
  system which they describe.
  
  It can be said that there are two MOPs for any object system; the
  implicit MOP and the explicit MOP. The implicit MOP handles things
  like method dispatch or inheritance, which happen automatically as
  part of how the object system works. The explicit MOP typically
  handles the introspection/reflection features of the object system.
  
  All object systems have implicit MOPs. Without one, they would not
  work. Explicit MOPs are much less common, and depending on the
  language can vary from restrictive (Reflection in Java or C#) to wide
  open (CLOS is a perfect example).
  
  =head2 Yet Another Class Builder! Why?
  
  This is B<not> a class builder so much as a I<class builder
  B<builder>>. The intent is that an end user will not use this module
  directly, but instead this module is used by module authors to build
  extensions and features onto the Perl 5 object system.
  
  This system is used by L<Moose>, which supplies a powerful class
  builder system built entirely on top of C<Class::MOP>.
  
  =head2 Who is this module for?
  
  This module is for anyone who has ever created or wanted to create a
  module for the Class:: namespace. The tools which this module provides
  make doing complex Perl 5 wizardry simpler, by removing such barriers
  as the need to hack symbol tables, or understand the fine details of
  method dispatch.
  
  =head2 What changes do I have to make to use this module?
  
  This module was designed to be as unintrusive as possible. Many of its
  features are accessible without B<any> change to your existing
  code. It is meant to be a compliment to your existing code and not an
  intrusion on your code base. Unlike many other B<Class::> modules,
  this module B<does not> require you subclass it, or even that you
  C<use> it in within your module's package.
  
  The only features which requires additions to your code are the
  attribute handling and instance construction features, and these are
  both completely optional features. The only reason for this is because
  Perl 5's object system does not actually have these features built
  in. More information about this feature can be found below.
  
  =head2 About Performance
  
  It is a common misconception that explicit MOPs are a performance hit.
  This is not a universal truth, it is a side-effect of some specific
  implementations. For instance, using Java reflection is slow because
  the JVM cannot take advantage of any compiler optimizations, and the
  JVM has to deal with much more runtime type information as well.
  
  Reflection in C# is marginally better as it was designed into the
  language and runtime (the CLR). In contrast, CLOS (the Common Lisp
  Object System) was built to support an explicit MOP, and so
  performance is tuned for it.
  
  This library in particular does its absolute best to avoid putting
  B<any> drain at all upon your code's performance. In fact, by itself
  it does nothing to affect your existing code. So you only pay for what
  you actually use.
  
  =head2 About Metaclass compatibility
  
  This module makes sure that all metaclasses created are both upwards
  and downwards compatible. The topic of metaclass compatibility is
  highly esoteric and is something only encountered when doing deep and
  involved metaclass hacking. There are two basic kinds of metaclass
  incompatibility; upwards and downwards.
  
  Upwards metaclass compatibility means that the metaclass of a
  given class is either the same as (or a subclass of) all of the
  class's ancestors.
  
  Downward metaclass compatibility means that the metaclasses of a
  given class's ancestors are all either the same as (or a subclass
  of) that metaclass.
  
  Here is a diagram showing a set of two classes (C<A> and C<B>) and
  two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
  metaclass compatibility both upwards and downwards.
  
      +---------+     +---------+
      | Meta::A |<----| Meta::B |      <....... (instance of  )
      +---------+     +---------+      <------- (inherits from)
           ^               ^
           :               :
      +---------+     +---------+
      |    A    |<----|    B    |
      +---------+     +---------+
  
  In actuality, I<all> of a class's metaclasses must be compatible,
  not just the class metaclass. That includes the instance, attribute,
  and method metaclasses, as well as the constructor and destructor
  classes.
  
  C<Class::MOP> will attempt to fix some simple types of
  incompatibilities. If all the metaclasses for the parent class are
  I<subclasses> of the child's metaclasses then we can simply replace
  the child's metaclasses with the parent's. In addition, if the child
  is missing a metaclass that the parent has, we can also just make the
  child use the parent's metaclass.
  
  As I said this is a highly esoteric topic and one you will only run
  into if you do a lot of subclassing of L<Class::MOP::Class>. If you
  are interested in why this is an issue see the paper I<Uniform and
  safe metaclass composition> linked to in the L<SEE ALSO> section of
  this document.
  
  =head2 Using custom metaclasses
  
  Always use the L<metaclass> pragma when using a custom metaclass, this
  will ensure the proper initialization order and not accidentally
  create an incorrect type of metaclass for you. This is a very rare
  problem, and one which can only occur if you are doing deep metaclass
  programming. So in other words, don't worry about it.
  
  Note that if you're using L<Moose> we encourage you to I<not> use
  L<metaclass> pragma, and instead use L<Moose::Util::MetaRole> to apply
  roles to a class's metaclasses. This topic is covered at length in
  various L<Moose::Cookbook> recipes.
  
  =head1 PROTOCOLS
  
  The meta-object protocol is divided into 4 main sub-protocols:
  
  =head2 The Class protocol
  
  This provides a means of manipulating and introspecting a Perl 5
  class. It handles symbol table hacking for you, and provides a rich
  set of methods that go beyond simple package introspection.
  
  See L<Class::MOP::Class> for more details.
  
  =head2 The Attribute protocol
  
  This provides a consistent representation for an attribute of a Perl 5
  class. Since there are so many ways to create and handle attributes in
  Perl 5 OO, the Attribute protocol provide as much of a unified
  approach as possible. Of course, you are always free to extend this
  protocol by subclassing the appropriate classes.
  
  See L<Class::MOP::Attribute> for more details.
  
  =head2 The Method protocol
  
  This provides a means of manipulating and introspecting methods in the
  Perl 5 object system. As with attributes, there are many ways to
  approach this topic, so we try to keep it pretty basic, while still
  making it possible to extend the system in many ways.
  
  See L<Class::MOP::Method> for more details.
  
  =head2 The Instance protocol
  
  This provides a layer of abstraction for creating object instances.
  Since the other layers use this protocol, it is relatively easy to
  change the type of your instances from the default hash reference to
  some other type of reference. Several examples are provided in the
  F<examples/> directory included in this distribution.
  
  See L<Class::MOP::Instance> for more details.
  
  =head1 FUNCTIONS
  
  Note that this module does not export any constants or functions.
  
  =head2 Utility functions
  
  Note that these are all called as B<functions, not methods>.
  
  =over 4
  
  =item B<Class::MOP::get_code_info($code)>
  
  This function returns two values, the name of the package the C<$code>
  is from and the name of the C<$code> itself. This is used by several
  elements of the MOP to determine where a given C<$code> reference is
  from.
  
  =item B<Class::MOP::class_of($instance_or_class_name)>
  
  This will return the metaclass of the given instance or class name.  If the
  class lacks a metaclass, no metaclass will be initialized, and C<undef> will be
  returned.
  
  =back
  
  =head2 Metaclass cache functions
  
  Class::MOP holds a cache of metaclasses. The following are functions
  (B<not methods>) which can be used to access that cache. It is not
  recommended that you mess with these. Bad things could happen, but if
  you are brave and willing to risk it: go for it!
  
  =over 4
  
  =item B<Class::MOP::get_all_metaclasses>
  
  This will return a hash of all the metaclass instances that have
  been cached by L<Class::MOP::Class>, keyed by the package name.
  
  =item B<Class::MOP::get_all_metaclass_instances>
  
  This will return a list of all the metaclass instances that have
  been cached by L<Class::MOP::Class>.
  
  =item B<Class::MOP::get_all_metaclass_names>
  
  This will return a list of all the metaclass names that have
  been cached by L<Class::MOP::Class>.
  
  =item B<Class::MOP::get_metaclass_by_name($name)>
  
  This will return a cached L<Class::MOP::Class> instance, or nothing
  if no metaclass exists with that C<$name>.
  
  =item B<Class::MOP::store_metaclass_by_name($name, $meta)>
  
  This will store a metaclass in the cache at the supplied C<$key>.
  
  =item B<Class::MOP::weaken_metaclass($name)>
  
  In rare cases (e.g. anonymous metaclasses) it is desirable to
  store a weakened reference in the metaclass cache. This
  function will weaken the reference to the metaclass stored
  in C<$name>.
  
  =item B<Class::MOP::metaclass_is_weak($name)>
  
  Returns true if the metaclass for C<$name> has been weakened
  (via C<weaken_metaclass>).
  
  =item B<Class::MOP::does_metaclass_exist($name)>
  
  This will return true of there exists a metaclass stored in the
  C<$name> key, and return false otherwise.
  
  =item B<Class::MOP::remove_metaclass_by_name($name)>
  
  This will remove the metaclass stored in the C<$name> key.
  
  =back
  
  Some utility functions (such as C<Class::MOP::load_class>) that were
  previously defined in C<Class::MOP> regarding loading of classes have been
  extracted to L<Class::Load>. Please see L<Class::Load> for documentation.
  
  =head1 SEE ALSO
  
  =head2 Books
  
  There are very few books out on Meta Object Protocols and Metaclasses
  because it is such an esoteric topic. The following books are really
  the only ones I have found. If you know of any more, B<I<please>>
  email me and let me know, I would love to hear about them.
  
  =over 4
  
  =item I<The Art of the Meta Object Protocol>
  
  =item I<Advances in Object-Oriented Metalevel Architecture and Reflection>
  
  =item I<Putting MetaClasses to Work>
  
  =item I<Smalltalk: The Language>
  
  =back
  
  =head2 Papers
  
  =over 4
  
  =item "Uniform and safe metaclass composition"
  
  An excellent paper by the people who brought us the original Traits paper.
  This paper is on how Traits can be used to do safe metaclass composition,
  and offers an excellent introduction section which delves into the topic of
  metaclass compatibility.
  
  L<http://www.iam.unibe.ch/~scg/Archive/Papers/Duca05ySafeMetaclassTrait.pdf>
  
  =item "Safe Metaclass Programming"
  
  This paper seems to precede the above paper, and propose a mix-in based
  approach as opposed to the Traits based approach. Both papers have similar
  information on the metaclass compatibility problem space.
  
  L<http://citeseer.ist.psu.edu/37617.html>
  
  =back
  
  =head2 Prior Art
  
  =over 4
  
  =item The Perl 6 MetaModel work in the Pugs project
  
  =over 4
  
  =item L<http://svn.openfoundry.org/pugs/misc/Perl-MetaModel/>
  
  =item L<http://github.com/perl6/p5-modules/tree/master/Perl6-ObjectSpace/>
  
  =back
  
  =back
  
  =head2 Articles
  
  =over 4
  
  =item CPAN Module Review of Class::MOP
  
  L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html>
  
  =back
  
  =head1 SIMILAR MODULES
  
  As I have said above, this module is a class-builder-builder, so it is
  not the same thing as modules like L<Class::Accessor> and
  L<Class::MethodMaker>. That being said there are very few modules on CPAN
  with similar goals to this module. The one I have found which is most
  like this module is L<Class::Meta>, although its philosophy and the MOP it
  creates are very different from this modules.
  
  =head1 BUGS
  
  All complex software has bugs lurking in it, and this module is no
  exception.
  
  Please report any bugs to C<bug-class-mop@rt.cpan.org>, or through the
  web interface at L<http://rt.cpan.org>.
  
  You can also discuss feature requests or possible bugs on the Moose
  mailing list (moose@perl.org) or on IRC at
  L<irc://irc.perl.org/#moose>.
  
  =head1 ACKNOWLEDGEMENTS
  
  =over 4
  
  =item Rob Kinyon
  
  Thanks to Rob for actually getting the development of this module kick-started.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Attribute.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_ATTRIBUTE';
  
  package Class::MOP::Attribute;
  BEGIN {
    $Class::MOP::Attribute::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Attribute::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::Method::Accessor;
  
  use Carp         'confess';
  use Scalar::Util 'blessed', 'weaken';
  use Try::Tiny;
  
  use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore';
  
  # NOTE: (meta-circularity)
  # This method will be replaced in the
  # boostrap section of Class::MOP, by
  # a new version which uses the
  # &Class::MOP::Class::construct_instance
  # method to build an attribute meta-object
  # which itself is described with attribute
  # meta-objects.
  #     - Ain't meta-circularity grand? :)
  sub new {
      my ( $class, @args ) = @_;
  
      unshift @args, "name" if @args % 2 == 1;
      my %options = @args;
  
      my $name = $options{name};
  
      (defined $name)
          || confess "You must provide a name for the attribute";
  
      $options{init_arg} = $name
          if not exists $options{init_arg};
      if(exists $options{builder}){
          confess("builder must be a defined scalar value which is a method name")
              if ref $options{builder} || !(defined $options{builder});
          confess("Setting both default and builder is not allowed.")
              if exists $options{default};
      } else {
          ($class->is_default_a_coderef(\%options))
              || confess("References are not allowed as default values, you must ".
                         "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
                  if exists $options{default} && ref $options{default};
      }
      if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) {
          confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
      }
  
      $class->_new(\%options);
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $options = @_ == 1 ? $_[0] : {@_};
  
      bless {
          'name'               => $options->{name},
          'accessor'           => $options->{accessor},
          'reader'             => $options->{reader},
          'writer'             => $options->{writer},
          'predicate'          => $options->{predicate},
          'clearer'            => $options->{clearer},
          'builder'            => $options->{builder},
          'init_arg'           => $options->{init_arg},
          exists $options->{default}
              ? ('default'     => $options->{default})
              : (),
          'initializer'        => $options->{initializer},
          'definition_context' => $options->{definition_context},
          # keep a weakened link to the
          # class we are associated with
          'associated_class' => undef,
          # and a list of the methods
          # associated with this attr
          'associated_methods' => [],
          # this let's us keep track of
          # our order inside the associated
          # class
          'insertion_order'    => undef,
      }, $class;
  }
  
  # NOTE:
  # this is a primative (and kludgy) clone operation
  # for now, it will be replaced in the Class::MOP
  # bootstrap with a proper one, however we know
  # that this one will work fine for now.
  sub clone {
      my $self    = shift;
      my %options = @_;
      (blessed($self))
          || confess "Can only clone an instance";
      return bless { %{$self}, %options } => ref($self);
  }
  
  sub initialize_instance_slot {
      my ($self, $meta_instance, $instance, $params) = @_;
      my $init_arg = $self->{'init_arg'};
  
      # try to fetch the init arg from the %params ...
  
      # if nothing was in the %params, we can use the
      # attribute's default value (if it has one)
      if(defined $init_arg and exists $params->{$init_arg}){
          $self->_set_initial_slot_value(
              $meta_instance,
              $instance,
              $params->{$init_arg},
          );
      }
      elsif (exists $self->{'default'}) {
          $self->_set_initial_slot_value(
              $meta_instance,
              $instance,
              $self->default($instance),
          );
      }
      elsif (defined( my $builder = $self->{'builder'})) {
          if ($builder = $instance->can($builder)) {
              $self->_set_initial_slot_value(
                  $meta_instance,
                  $instance,
                  $instance->$builder,
              );
          }
          else {
              confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
          }
      }
  }
  
  sub _set_initial_slot_value {
      my ($self, $meta_instance, $instance, $value) = @_;
  
      my $slot_name = $self->name;
  
      return $meta_instance->set_slot_value($instance, $slot_name, $value)
          unless $self->has_initializer;
  
      my $callback = $self->_make_initializer_writer_callback(
          $meta_instance, $instance, $slot_name
      );
  
      my $initializer = $self->initializer;
  
      # most things will just want to set a value, so make it first arg
      $instance->$initializer($value, $callback, $self);
  }
  
  sub _make_initializer_writer_callback {
      my $self = shift;
      my ($meta_instance, $instance, $slot_name) = @_;
  
      return sub {
          $meta_instance->set_slot_value($instance, $slot_name, $_[0]);
      };
  }
  
  sub get_read_method  {
      my $self   = shift;
      my $reader = $self->reader || $self->accessor;
      # normal case ...
      return $reader unless ref $reader;
      # the HASH ref case
      my ($name) = %$reader;
      return $name;
  }
  
  sub get_write_method {
      my $self   = shift;
      my $writer = $self->writer || $self->accessor;
      # normal case ...
      return $writer unless ref $writer;
      # the HASH ref case
      my ($name) = %$writer;
      return $name;
  }
  
  sub get_read_method_ref {
      my $self = shift;
      if ((my $reader = $self->get_read_method) && $self->associated_class) {
          return $self->associated_class->get_method($reader);
      }
      else {
          my $code = sub { $self->get_value(@_) };
          if (my $class = $self->associated_class) {
              return $class->method_metaclass->wrap(
                  $code,
                  package_name => $class->name,
                  name         => '__ANON__'
              );
          }
          else {
              return $code;
          }
      }
  }
  
  sub get_write_method_ref {
      my $self = shift;
      if ((my $writer = $self->get_write_method) && $self->associated_class) {
          return $self->associated_class->get_method($writer);
      }
      else {
          my $code = sub { $self->set_value(@_) };
          if (my $class = $self->associated_class) {
              return $class->method_metaclass->wrap(
                  $code,
                  package_name => $class->name,
                  name         => '__ANON__'
              );
          }
          else {
              return $code;
          }
      }
  }
  
  # slots
  
  sub slots { (shift)->name }
  
  # class association
  
  sub attach_to_class {
      my ($self, $class) = @_;
      (blessed($class) && $class->isa('Class::MOP::Class'))
          || confess "You must pass a Class::MOP::Class instance (or a subclass)";
      weaken($self->{'associated_class'} = $class);
  }
  
  sub detach_from_class {
      my $self = shift;
      $self->{'associated_class'} = undef;
  }
  
  # method association
  
  sub associate_method {
      my ($self, $method) = @_;
      push @{$self->{'associated_methods'}} => $method;
  }
  
  ## Slot management
  
  sub set_initial_value {
      my ($self, $instance, $value) = @_;
      $self->_set_initial_slot_value(
          Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
          $instance,
          $value
      );
  }
  
  sub set_value { shift->set_raw_value(@_) }
  
  sub set_raw_value {
      my $self = shift;
      my ($instance, $value) = @_;
  
      my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
      return $mi->set_slot_value($instance, $self->name, $value);
  }
  
  sub _inline_set_value {
      my $self = shift;
      return $self->_inline_instance_set(@_) . ';';
  }
  
  sub _inline_instance_set {
      my $self = shift;
      my ($instance, $value) = @_;
  
      my $mi = $self->associated_class->get_meta_instance;
      return $mi->inline_set_slot_value($instance, $self->name, $value);
  }
  
  sub get_value { shift->get_raw_value(@_) }
  
  sub get_raw_value {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
      return $mi->get_slot_value($instance, $self->name);
  }
  
  sub _inline_get_value {
      my $self = shift;
      return $self->_inline_instance_get(@_) . ';';
  }
  
  sub _inline_instance_get {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = $self->associated_class->get_meta_instance;
      return $mi->inline_get_slot_value($instance, $self->name);
  }
  
  sub has_value {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
      return $mi->is_slot_initialized($instance, $self->name);
  }
  
  sub _inline_has_value {
      my $self = shift;
      return $self->_inline_instance_has(@_) . ';';
  }
  
  sub _inline_instance_has {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = $self->associated_class->get_meta_instance;
      return $mi->inline_is_slot_initialized($instance, $self->name);
  }
  
  sub clear_value {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
      return $mi->deinitialize_slot($instance, $self->name);
  }
  
  sub _inline_clear_value {
      my $self = shift;
      return $self->_inline_instance_clear(@_) . ';';
  }
  
  sub _inline_instance_clear {
      my $self = shift;
      my ($instance) = @_;
  
      my $mi = $self->associated_class->get_meta_instance;
      return $mi->inline_deinitialize_slot($instance, $self->name);
  }
  
  ## load em up ...
  
  sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
  
  sub _process_accessors {
      my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
  
      my $method_ctx = { %{ $self->definition_context || {} } };
  
      if (ref($accessor)) {
          (ref($accessor) eq 'HASH')
              || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
          my ($name, $method) = %{$accessor};
  
          $method_ctx->{description} = $self->_accessor_description($name, $type);
  
          $method = $self->accessor_metaclass->wrap(
              $method,
              attribute    => $self,
              package_name => $self->associated_class->name,
              name         => $name,
              associated_metaclass => $self->associated_class,
              definition_context => $method_ctx,
          );
          $self->associate_method($method);
          return ($name, $method);
      }
      else {
          my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
          my $method;
          try {
              $method_ctx->{description} = $self->_accessor_description($accessor, $type);
  
              $method = $self->accessor_metaclass->new(
                  attribute     => $self,
                  is_inline     => $inline_me,
                  accessor_type => $type,
                  package_name  => $self->associated_class->name,
                  name          => $accessor,
                  associated_metaclass => $self->associated_class,
                  definition_context => $method_ctx,
              );
          }
          catch {
              confess "Could not create the '$type' method for " . $self->name . " because : $_";
          };
          $self->associate_method($method);
          return ($accessor, $method);
      }
  }
  
  sub _accessor_description {
      my $self = shift;
      my ($name, $type) = @_;
  
      my $desc = "$type " . $self->associated_class->name . "::$name";
      if ( $name ne $self->name ) {
          $desc .= " of attribute " . $self->name;
      }
  
      return $desc;
  }
  
  sub install_accessors {
      my $self   = shift;
      my $inline = shift;
      my $class  = $self->associated_class;
  
      $class->add_method(
          $self->_process_accessors('accessor' => $self->accessor(), $inline)
      ) if $self->has_accessor();
  
      $class->add_method(
          $self->_process_accessors('reader' => $self->reader(), $inline)
      ) if $self->has_reader();
  
      $class->add_method(
          $self->_process_accessors('writer' => $self->writer(), $inline)
      ) if $self->has_writer();
  
      $class->add_method(
          $self->_process_accessors('predicate' => $self->predicate(), $inline)
      ) if $self->has_predicate();
  
      $class->add_method(
          $self->_process_accessors('clearer' => $self->clearer(), $inline)
      ) if $self->has_clearer();
  
      return;
  }
  
  {
      my $_remove_accessor = sub {
          my ($accessor, $class) = @_;
          if (ref($accessor) && ref($accessor) eq 'HASH') {
              ($accessor) = keys %{$accessor};
          }
          my $method = $class->get_method($accessor);
          $class->remove_method($accessor)
              if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
      };
  
      sub remove_accessors {
          my $self = shift;
          # TODO:
          # we really need to make sure to remove from the
          # associates methods here as well. But this is
          # such a slimly used method, I am not worried
          # about it right now.
          $_remove_accessor->($self->accessor(),  $self->associated_class()) if $self->has_accessor();
          $_remove_accessor->($self->reader(),    $self->associated_class()) if $self->has_reader();
          $_remove_accessor->($self->writer(),    $self->associated_class()) if $self->has_writer();
          $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
          $_remove_accessor->($self->clearer(),   $self->associated_class()) if $self->has_clearer();
          return;
      }
  
  }
  
  1;
  
  # ABSTRACT: Attribute Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Attribute - Attribute Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    Class::MOP::Attribute->new(
        foo => (
            accessor  => 'foo',           # dual purpose get/set accessor
            predicate => 'has_foo',       # predicate check for defined-ness
            init_arg  => '-foo',          # class->new will look for a -foo key
            default   => 'BAR IS BAZ!'    # if no -foo key is provided, use this
        )
    );
  
    Class::MOP::Attribute->new(
        bar => (
            reader    => 'bar',           # getter
            writer    => 'set_bar',       # setter
            predicate => 'has_bar',       # predicate check for defined-ness
            init_arg  => ':bar',          # class->new will look for a :bar key
                                          # no default value means it is undef
        )
    );
  
  =head1 DESCRIPTION
  
  The Attribute Protocol is almost entirely an invention of
  C<Class::MOP>. Perl 5 does not have a consistent notion of
  attributes. There are so many ways in which this is done, and very few
  (if any) are easily discoverable by this module.
  
  With that said, this module attempts to inject some order into this
  chaos, by introducing a consistent API which can be used to create
  object attributes.
  
  =head1 METHODS
  
  =head2 Creation
  
  =over 4
  
  =item B<< Class::MOP::Attribute->new($name, ?%options) >>
  
  An attribute must (at the very least), have a C<$name>. All other
  C<%options> are added as key-value pairs.
  
  =over 8
  
  =item * init_arg
  
  This is a string value representing the expected key in an
  initialization hash. For instance, if we have an C<init_arg> value of
  C<-foo>, then the following code will Just Work.
  
    MyClass->meta->new_object( -foo => 'Hello There' );
  
  If an init_arg is not assigned, it will automatically use the
  attribute's name. If C<init_arg> is explicitly set to C<undef>, the
  attribute cannot be specified during initialization.
  
  =item * builder
  
  This provides the name of a method that will be called to initialize
  the attribute. This method will be called on the object after it is
  constructed. It is expected to return a valid value for the attribute.
  
  =item * default
  
  This can be used to provide an explicit default for initializing the
  attribute. If the default you provide is a subroutine reference, then
  this reference will be called I<as a method> on the object.
  
  If the value is a simple scalar (string or number), then it can be
  just passed as is. However, if you wish to initialize it with a HASH
  or ARRAY ref, then you need to wrap that inside a subroutine
  reference:
  
    Class::MOP::Attribute->new(
        'foo' => (
            default => sub { [] },
        )
    );
  
    # or ...
  
    Class::MOP::Attribute->new(
        'foo' => (
            default => sub { {} },
        )
    );
  
  If you wish to initialize an attribute with a subroutine reference
  itself, then you need to wrap that in a subroutine as well:
  
    Class::MOP::Attribute->new(
        'foo' => (
            default => sub {
                sub { print "Hello World" }
            },
        )
    );
  
  And lastly, if the value of your attribute is dependent upon some
  other aspect of the instance structure, then you can take advantage of
  the fact that when the C<default> value is called as a method:
  
    Class::MOP::Attribute->new(
        'object_identity' => (
            default => sub { Scalar::Util::refaddr( $_[0] ) },
        )
    );
  
  Note that there is no guarantee that attributes are initialized in any
  particular order, so you cannot rely on the value of some other
  attribute when generating the default.
  
  =item * initializer
  
  This option can be either a method name or a subroutine
  reference. This method will be called when setting the attribute's
  value in the constructor. Unlike C<default> and C<builder>, the
  initializer is only called when a value is provided to the
  constructor. The initializer allows you to munge this value during
  object construction.
  
  The initializer is called as a method with three arguments. The first
  is the value that was passed to the constructor. The second is a
  subroutine reference that can be called to actually set the
  attribute's value, and the last is the associated
  C<Class::MOP::Attribute> object.
  
  This contrived example shows an initializer that sets the attribute to
  twice the given value.
  
    Class::MOP::Attribute->new(
        'doubled' => (
            initializer => sub {
                my ( $self, $value, $set, $attr ) = @_;
                $set->( $value * 2 );
            },
        )
    );
  
  Since an initializer can be a method name, you can easily make
  attribute initialization use the writer:
  
    Class::MOP::Attribute->new(
        'some_attr' => (
            writer      => 'some_attr',
            initializer => 'some_attr',
        )
    );
  
  Your writer (actually, a wrapper around the writer, using
  L<method modifications|Moose::Manual::MethodModifiers>) will need to examine
  C<@_> and determine under which
  context it is being called:
  
    around 'some_attr' => sub {
        my $orig = shift;
        my $self = shift;
        # $value is not defined if being called as a reader
        # $setter and $attr are only defined if being called as an initializer
        my ($value, $setter, $attr) = @_;
  
        # the reader behaves normally
        return $self->$orig if not @_;
  
        # mutate $value as desired
        # $value = <something($value);
  
        # if called as an initializer, set the value and we're done
        return $setter->($row) if $setter;
  
        # otherwise, call the real writer with the new value
        $self->$orig($row);
    };
  
  =back
  
  The C<accessor>, C<reader>, C<writer>, C<predicate> and C<clearer>
  options all accept the same parameters. You can provide the name of
  the method, in which case an appropriate default method will be
  generated for you. Or instead you can also provide hash reference
  containing exactly one key (the method name) and one value. The value
  should be a subroutine reference, which will be installed as the
  method itself.
  
  =over 8
  
  =item * accessor
  
  An C<accessor> is a standard Perl-style read/write accessor. It will
  return the value of the attribute, and if a value is passed as an
  argument, it will assign that value to the attribute.
  
  Note that C<undef> is a legitimate value, so this will work:
  
    $object->set_something(undef);
  
  =item * reader
  
  This is a basic read-only accessor. It returns the value of the
  attribute.
  
  =item * writer
  
  This is a basic write accessor, it accepts a single argument, and
  assigns that value to the attribute.
  
  Note that C<undef> is a legitimate value, so this will work:
  
    $object->set_something(undef);
  
  =item * predicate
  
  The predicate method returns a boolean indicating whether or not the
  attribute has been explicitly set.
  
  Note that the predicate returns true even if the attribute was set to
  a false value (C<0> or C<undef>).
  
  =item * clearer
  
  This method will uninitialize the attribute. After an attribute is
  cleared, its C<predicate> will return false.
  
  =item * definition_context
  
  Mostly, this exists as a hook for the benefit of Moose.
  
  This option should be a hash reference containing several keys which
  will be used when inlining the attribute's accessors. The keys should
  include C<line>, the line number where the attribute was created, and
  either C<file> or C<description>.
  
  This information will ultimately be used when eval'ing inlined
  accessor code so that error messages report a useful line and file
  name.
  
  =back
  
  =item B<< $attr->clone(%options) >>
  
  This clones the attribute. Any options you provide will override the
  settings of the original attribute. You can change the name of the new
  attribute by passing a C<name> key in C<%options>.
  
  =back
  
  =head2 Informational
  
  These are all basic read-only accessors for the values passed into
  the constructor.
  
  =over 4
  
  =item B<< $attr->name >>
  
  Returns the attribute's name.
  
  =item B<< $attr->accessor >>
  
  =item B<< $attr->reader >>
  
  =item B<< $attr->writer >>
  
  =item B<< $attr->predicate >>
  
  =item B<< $attr->clearer >>
  
  The C<accessor>, C<reader>, C<writer>, C<predicate>, and C<clearer>
  methods all return exactly what was passed to the constructor, so it
  can be either a string containing a method name, or a hash reference.
  
  =item B<< $attr->initializer >>
  
  Returns the initializer as passed to the constructor, so this may be
  either a method name or a subroutine reference.
  
  =item B<< $attr->init_arg >>
  
  =item B<< $attr->is_default_a_coderef >>
  
  =item B<< $attr->default($instance) >>
  
  The C<$instance> argument is optional. If you don't pass it, the
  return value for this method is exactly what was passed to the
  constructor, either a simple scalar or a subroutine reference.
  
  If you I<do> pass an C<$instance> and the default is a subroutine
  reference, then the reference is called as a method on the
  C<$instance> and the generated value is returned.
  
  =item B<< $attr->slots >>
  
  Return a list of slots required by the attribute. This is usually just
  one, the name of the attribute.
  
  A slot is the name of the hash key used to store the attribute in an
  object instance.
  
  =item B<< $attr->get_read_method >>
  
  =item B<< $attr->get_write_method >>
  
  Returns the name of a method suitable for reading or writing the value
  of the attribute in the associated class.
  
  If an attribute is read- or write-only, then these methods can return
  C<undef> as appropriate.
  
  =item B<< $attr->has_read_method >>
  
  =item B<< $attr->has_write_method >>
  
  This returns a boolean indicating whether the attribute has a I<named>
  read or write method.
  
  =item B<< $attr->get_read_method_ref >>
  
  =item B<< $attr->get_write_method_ref >>
  
  Returns the subroutine reference of a method suitable for reading or
  writing the attribute's value in the associated class. These methods
  always return a subroutine reference, regardless of whether or not the
  attribute is read- or write-only.
  
  =item B<< $attr->insertion_order >>
  
  If this attribute has been inserted into a class, this returns a zero
  based index regarding the order of insertion.
  
  =back
  
  =head2 Informational predicates
  
  These are all basic predicate methods for the values passed into C<new>.
  
  =over 4
  
  =item B<< $attr->has_accessor >>
  
  =item B<< $attr->has_reader >>
  
  =item B<< $attr->has_writer >>
  
  =item B<< $attr->has_predicate >>
  
  =item B<< $attr->has_clearer >>
  
  =item B<< $attr->has_initializer >>
  
  =item B<< $attr->has_init_arg >>
  
  This will be I<false> if the C<init_arg> was set to C<undef>.
  
  =item B<< $attr->has_default >>
  
  This will be I<false> if the C<default> was set to C<undef>, since
  C<undef> is the default C<default> anyway.
  
  =item B<< $attr->has_builder >>
  
  =item B<< $attr->has_insertion_order >>
  
  This will be I<false> if this attribute has not be inserted into a class
  
  =back
  
  =head2 Value management
  
  These methods are basically "back doors" to the instance, and can be
  used to bypass the regular accessors, but still stay within the MOP.
  
  These methods are not for general use, and should only be used if you
  really know what you are doing.
  
  =over 4
  
  =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
  
  This method is used internally to initialize the attribute's slot in
  the object C<$instance>.
  
  The C<$params> is a hash reference of the values passed to the object
  constructor.
  
  It's unlikely that you'll need to call this method yourself.
  
  =item B<< $attr->set_value($instance, $value) >>
  
  Sets the value without going through the accessor. Note that this
  works even with read-only attributes.
  
  =item B<< $attr->set_raw_value($instance, $value) >>
  
  Sets the value with no side effects such as a trigger.
  
  This doesn't actually apply to Class::MOP attributes, only to subclasses.
  
  =item B<< $attr->set_initial_value($instance, $value) >>
  
  Sets the value without going through the accessor. This method is only
  called when the instance is first being initialized.
  
  =item B<< $attr->get_value($instance) >>
  
  Returns the value without going through the accessor. Note that this
  works even with write-only accessors.
  
  =item B<< $attr->get_raw_value($instance) >>
  
  Returns the value without any side effects such as lazy attributes.
  
  Doesn't actually apply to Class::MOP attributes, only to subclasses.
  
  =item B<< $attr->has_value($instance) >>
  
  Return a boolean indicating whether the attribute has been set in
  C<$instance>. This how the default C<predicate> method works.
  
  =item B<< $attr->clear_value($instance) >>
  
  This will clear the attribute's value in C<$instance>. This is what
  the default C<clearer> calls.
  
  Note that this works even if the attribute does not have any
  associated read, write or clear methods.
  
  =back
  
  =head2 Class association
  
  These methods allow you to manage the attributes association with
  the class that contains it. These methods should not be used
  lightly, nor are they very magical, they are mostly used internally
  and by metaclass instances.
  
  =over 4
  
  =item B<< $attr->associated_class >>
  
  This returns the C<Class::MOP::Class> with which this attribute is
  associated, if any.
  
  =item B<< $attr->attach_to_class($metaclass) >>
  
  This method stores a weakened reference to the C<$metaclass> object
  internally.
  
  This method does not remove the attribute from its old class,
  nor does it create any accessors in the new class.
  
  It is probably best to use the L<Class::MOP::Class> C<add_attribute>
  method instead.
  
  =item B<< $attr->detach_from_class >>
  
  This method removes the associate metaclass object from the attribute
  it has one.
  
  This method does not remove the attribute itself from the class, or
  remove its accessors.
  
  It is probably best to use the L<Class::MOP::Class>
  C<remove_attribute> method instead.
  
  =back
  
  =head2 Attribute Accessor generation
  
  =over 4
  
  =item B<< $attr->accessor_metaclass >>
  
  Accessor methods are generated using an accessor metaclass. By
  default, this is L<Class::MOP::Method::Accessor>. This method returns
  the name of the accessor metaclass that this attribute uses.
  
  =item B<< $attr->associate_method($method) >>
  
  This associates a L<Class::MOP::Method> object with the
  attribute. Typically, this is called internally when an attribute
  generates its accessors.
  
  =item B<< $attr->associated_methods >>
  
  This returns the list of methods which have been associated with the
  attribute.
  
  =item B<< $attr->install_accessors >>
  
  This method generates and installs code the attributes various
  accessors. It is typically called from the L<Class::MOP::Class>
  C<add_attribute> method.
  
  =item B<< $attr->remove_accessors >>
  
  This method removes all of the accessors associated with the
  attribute.
  
  This does not currently remove methods from the list returned by
  C<associated_methods>.
  
  =item B<< $attr->inline_get >>
  
  =item B<< $attr->inline_set >>
  
  =item B<< $attr->inline_has >>
  
  =item B<< $attr->inline_clear >>
  
  These methods return a code snippet suitable for inlining the relevant
  operation. They expect strings containing variable names to be used in the
  inlining, like C<'$self'> or C<'$_[1]'>.
  
  =back
  
  =head2 Introspection
  
  =over 4
  
  =item B<< Class::MOP::Attribute->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  It should also be noted that L<Class::MOP> will actually bootstrap
  this module by installing a number of attribute meta-objects into its
  metaclass.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_ATTRIBUTE

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Class.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_CLASS';
  
  package Class::MOP::Class;
  BEGIN {
    $Class::MOP::Class::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Class::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::Instance;
  use Class::MOP::Method::Wrapped;
  use Class::MOP::Method::Accessor;
  use Class::MOP::Method::Constructor;
  use Class::MOP::MiniTrait;
  
  use Carp         'confess';
  use Class::Load  'is_class_loaded', 'load_class';
  use Scalar::Util 'blessed', 'reftype', 'weaken';
  use Sub::Name    'subname';
  use Try::Tiny;
  use List::MoreUtils 'all';
  
  use base 'Class::MOP::Module',
           'Class::MOP::Mixin::HasAttributes',
           'Class::MOP::Mixin::HasMethods';
  
  # Creation
  
  sub initialize {
      my $class = shift;
  
      my $package_name;
  
      if ( @_ % 2 ) {
          $package_name = shift;
      } else {
          my %options = @_;
          $package_name = $options{package};
      }
  
      ($package_name && !ref($package_name))
          || confess "You must pass a package name and it cannot be blessed";
  
      return Class::MOP::get_metaclass_by_name($package_name)
          || $class->_construct_class_instance(package => $package_name, @_);
  }
  
  sub reinitialize {
      my ( $class, @args ) = @_;
      unshift @args, "package" if @args % 2;
      my %options = @args;
      my $old_metaclass = blessed($options{package})
          ? $options{package}
          : Class::MOP::get_metaclass_by_name($options{package});
      $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name)
          if !exists $options{weaken}
          && blessed($old_metaclass)
          && $old_metaclass->isa('Class::MOP::Class');
      $old_metaclass->_remove_generated_metaobjects
          if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
      my $new_metaclass = $class->SUPER::reinitialize(%options);
      $new_metaclass->_restore_metaobjects_from($old_metaclass)
          if $old_metaclass && $old_metaclass->isa('Class::MOP::Class');
      return $new_metaclass;
  }
  
  # NOTE: (meta-circularity)
  # this is a special form of _construct_instance
  # (see below), which is used to construct class
  # meta-object instances for any Class::MOP::*
  # class. All other classes will use the more
  # normal &construct_instance.
  sub _construct_class_instance {
      my $class        = shift;
      my $options      = @_ == 1 ? $_[0] : {@_};
      my $package_name = $options->{package};
      (defined $package_name && $package_name)
          || confess "You must pass a package name";
      # NOTE:
      # return the metaclass if we have it cached,
      # and it is still defined (it has not been
      # reaped by DESTROY yet, which can happen
      # annoyingly enough during global destruction)
  
      if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) {
          return $meta;
      }
  
      $class
          = ref $class
          ? $class->_real_ref_name
          : $class;
  
      # now create the metaclass
      my $meta;
      if ($class eq 'Class::MOP::Class') {
          $meta = $class->_new($options);
      }
      else {
          # NOTE:
          # it is safe to use meta here because
          # class will always be a subclass of
          # Class::MOP::Class, which defines meta
          $meta = $class->meta->_construct_instance($options)
      }
  
      # and check the metaclass compatibility
      $meta->_check_metaclass_compatibility();
  
      Class::MOP::store_metaclass_by_name($package_name, $meta);
  
      # NOTE:
      # we need to weaken any anon classes
      # so that they can call DESTROY properly
      Class::MOP::weaken_metaclass($package_name) if $options->{weaken};
  
      $meta;
  }
  
  sub _real_ref_name {
      my $self = shift;
  
      # NOTE: we need to deal with the possibility of class immutability here,
      # and then get the name of the class appropriately
      return $self->is_immutable
          ? $self->_get_mutable_metaclass_name()
          : ref $self;
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $options = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          # inherited from Class::MOP::Package
          'package' => $options->{package},
  
          # NOTE:
          # since the following attributes will
          # actually be loaded from the symbol
          # table, and actually bypass the instance
          # entirely, we can just leave these things
          # listed here for reference, because they
          # should not actually have a value associated
          # with the slot.
          'namespace' => \undef,
          'methods'   => {},
  
          # inherited from Class::MOP::Module
          'version'   => \undef,
          'authority' => \undef,
  
          # defined in Class::MOP::Class
          'superclasses' => \undef,
  
          'attributes' => {},
          'attribute_metaclass' =>
              ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
          'method_metaclass' =>
              ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
          'wrapped_method_metaclass' => (
              $options->{'wrapped_method_metaclass'}
                  || 'Class::MOP::Method::Wrapped'
          ),
          'instance_metaclass' =>
              ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
          'immutable_trait' => (
              $options->{'immutable_trait'}
                  || 'Class::MOP::Class::Immutable::Trait'
          ),
          'constructor_name' => ( $options->{constructor_name} || 'new' ),
          'constructor_class' => (
              $options->{constructor_class} || 'Class::MOP::Method::Constructor'
          ),
          'destructor_class' => $options->{destructor_class},
      }, $class;
  }
  
  ## Metaclass compatibility
  {
      my %base_metaclass = (
          attribute_metaclass      => 'Class::MOP::Attribute',
          method_metaclass         => 'Class::MOP::Method',
          wrapped_method_metaclass => 'Class::MOP::Method::Wrapped',
          instance_metaclass       => 'Class::MOP::Instance',
          constructor_class        => 'Class::MOP::Method::Constructor',
          destructor_class         => 'Class::MOP::Method::Destructor',
      );
  
      sub _base_metaclasses { %base_metaclass }
  }
  
  sub _check_metaclass_compatibility {
      my $self = shift;
  
      my @superclasses = $self->superclasses
          or return;
  
      $self->_fix_metaclass_incompatibility(@superclasses);
  
      my %base_metaclass = $self->_base_metaclasses;
  
      # this is always okay ...
      return
          if ref($self) eq 'Class::MOP::Class'
              && all {
                  my $meta = $self->$_;
                  !defined($meta) || $meta eq $base_metaclass{$_};
          }
          keys %base_metaclass;
  
      for my $superclass (@superclasses) {
          $self->_check_class_metaclass_compatibility($superclass);
      }
  
      for my $metaclass_type ( keys %base_metaclass ) {
          next unless defined $self->$metaclass_type;
          for my $superclass (@superclasses) {
              $self->_check_single_metaclass_compatibility( $metaclass_type,
                  $superclass );
          }
      }
  }
  
  sub _check_class_metaclass_compatibility {
      my $self = shift;
      my ( $superclass_name ) = @_;
  
      if (!$self->_class_metaclass_is_compatible($superclass_name)) {
          my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
  
          my $super_meta_type = $super_meta->_real_ref_name;
  
          confess "The metaclass of " . $self->name . " ("
                . (ref($self)) . ")" .  " is not compatible with "
                . "the metaclass of its superclass, "
                . $superclass_name . " (" . ($super_meta_type) . ")";
      }
  }
  
  sub _class_metaclass_is_compatible {
      my $self = shift;
      my ( $superclass_name ) = @_;
  
      my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
          || return 1;
  
      my $super_meta_name = $super_meta->_real_ref_name;
  
      return $self->_is_compatible_with($super_meta_name);
  }
  
  sub _check_single_metaclass_compatibility {
      my $self = shift;
      my ( $metaclass_type, $superclass_name ) = @_;
  
      if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) {
          my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name);
          my $metaclass_type_name = $metaclass_type;
          $metaclass_type_name =~ s/_(?:meta)?class$//;
          $metaclass_type_name =~ s/_/ /g;
          confess "The $metaclass_type_name metaclass for "
                . $self->name . " (" . ($self->$metaclass_type)
                . ")" . " is not compatible with the "
                . "$metaclass_type_name metaclass of its "
                . "superclass, $superclass_name ("
                . ($super_meta->$metaclass_type) . ")";
      }
  }
  
  sub _single_metaclass_is_compatible {
      my $self = shift;
      my ( $metaclass_type, $superclass_name ) = @_;
  
      my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name)
          || return 1;
  
      # for instance, Moose::Meta::Class has a error_class attribute, but
      # Class::MOP::Class doesn't - this shouldn't be an error
      return 1 unless $super_meta->can($metaclass_type);
      # for instance, Moose::Meta::Class has a destructor_class, but
      # Class::MOP::Class doesn't - this shouldn't be an error
      return 1 unless defined $super_meta->$metaclass_type;
      # if metaclass is defined in superclass but not here, it's not compatible
      # this is a really odd case
      return 0 unless defined $self->$metaclass_type;
  
      return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type);
  }
  
  sub _fix_metaclass_incompatibility {
      my $self = shift;
      my @supers = map { Class::MOP::Class->initialize($_) } @_;
  
      my $necessary = 0;
      for my $super (@supers) {
          $necessary = 1
              if $self->_can_fix_metaclass_incompatibility($super);
      }
      return unless $necessary;
  
      for my $super (@supers) {
          if (!$self->_class_metaclass_is_compatible($super->name)) {
              $self->_fix_class_metaclass_incompatibility($super);
          }
      }
  
      my %base_metaclass = $self->_base_metaclasses;
      for my $metaclass_type (keys %base_metaclass) {
          for my $super (@supers) {
              if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) {
                  $self->_fix_single_metaclass_incompatibility(
                      $metaclass_type, $super
                  );
              }
          }
      }
  }
  
  sub _can_fix_metaclass_incompatibility {
      my $self = shift;
      my ($super_meta) = @_;
  
      return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta);
  
      my %base_metaclass = $self->_base_metaclasses;
      for my $metaclass_type (keys %base_metaclass) {
          return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type);
      }
  
      return;
  }
  
  sub _class_metaclass_can_be_made_compatible {
      my $self = shift;
      my ($super_meta) = @_;
  
      return $self->_can_be_made_compatible_with($super_meta->_real_ref_name);
  }
  
  sub _single_metaclass_can_be_made_compatible {
      my $self = shift;
      my ($super_meta, $metaclass_type) = @_;
  
      my $specific_meta = $self->$metaclass_type;
  
      return unless $super_meta->can($metaclass_type);
      my $super_specific_meta = $super_meta->$metaclass_type;
  
      # for instance, Moose::Meta::Class has a destructor_class, but
      # Class::MOP::Class doesn't - this shouldn't be an error
      return unless defined $super_specific_meta;
  
      # if metaclass is defined in superclass but not here, it's fixable
      # this is a really odd case
      return 1 unless defined $specific_meta;
  
      return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta);
  }
  
  sub _fix_class_metaclass_incompatibility {
      my $self = shift;
      my ( $super_meta ) = @_;
  
      if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
          ($self->is_pristine)
              || confess "Can't fix metaclass incompatibility for "
                       . $self->name
                       . " because it is not pristine.";
  
          my $super_meta_name = $super_meta->_real_ref_name;
  
          $self->_make_compatible_with($super_meta_name);
      }
  }
  
  sub _fix_single_metaclass_incompatibility {
      my $self = shift;
      my ( $metaclass_type, $super_meta ) = @_;
  
      if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
          ($self->is_pristine)
              || confess "Can't fix metaclass incompatibility for "
                       . $self->name
                       . " because it is not pristine.";
  
          my $new_metaclass = $self->$metaclass_type
              ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type)
              : $super_meta->$metaclass_type;
          $self->{$metaclass_type} = $new_metaclass;
      }
  }
  
  sub _restore_metaobjects_from {
      my $self = shift;
      my ($old_meta) = @_;
  
      $self->_restore_metamethods_from($old_meta);
      $self->_restore_metaattributes_from($old_meta);
  }
  
  sub _remove_generated_metaobjects {
      my $self = shift;
  
      for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) {
          $attr->remove_accessors;
      }
  }
  
  # creating classes with MOP ...
  
  sub create {
      my $class = shift;
      my @args = @_;
  
      unshift @args, 'package' if @args % 2 == 1;
      my %options = @args;
  
      (ref $options{superclasses} eq 'ARRAY')
          || confess "You must pass an ARRAY ref of superclasses"
              if exists $options{superclasses};
  
      (ref $options{attributes} eq 'ARRAY')
          || confess "You must pass an ARRAY ref of attributes"
              if exists $options{attributes};
  
      (ref $options{methods} eq 'HASH')
          || confess "You must pass a HASH ref of methods"
              if exists $options{methods};
  
      my $package      = delete $options{package};
      my $superclasses = delete $options{superclasses};
      my $attributes   = delete $options{attributes};
      my $methods      = delete $options{methods};
      my $meta_name    = exists $options{meta_name}
                           ? delete $options{meta_name}
                           : 'meta';
  
      my $meta = $class->SUPER::create($package => %options);
  
      $meta->_add_meta_method($meta_name)
          if defined $meta_name;
  
      $meta->superclasses(@{$superclasses})
          if defined $superclasses;
      # NOTE:
      # process attributes first, so that they can
      # install accessors, but locally defined methods
      # can then overwrite them. It is maybe a little odd, but
      # I think this should be the order of things.
      if (defined $attributes) {
          foreach my $attr (@{$attributes}) {
              $meta->add_attribute($attr);
          }
      }
      if (defined $methods) {
          foreach my $method_name (keys %{$methods}) {
              $meta->add_method($method_name, $methods->{$method_name});
          }
      }
      return $meta;
  }
  
  # XXX: something more intelligent here?
  sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' }
  
  sub create_anon_class { shift->create_anon(@_) }
  sub is_anon_class     { shift->is_anon(@_)     }
  
  sub _anon_cache_key {
      my $class = shift;
      my %options = @_;
      # Makes something like Super::Class|Super::Class::2
      return join '=' => (
          join( '|', sort @{ $options{superclasses} || [] } ),
      );
  }
  
  # Instance Construction & Cloning
  
  sub new_object {
      my $class = shift;
  
      # NOTE:
      # we need to protect the integrity of the
      # Class::MOP::Class singletons here, so we
      # delegate this to &construct_class_instance
      # which will deal with the singletons
      return $class->_construct_class_instance(@_)
          if $class->name->isa('Class::MOP::Class');
      return $class->_construct_instance(@_);
  }
  
  sub _construct_instance {
      my $class = shift;
      my $params = @_ == 1 ? $_[0] : {@_};
      my $meta_instance = $class->get_meta_instance();
      # FIXME:
      # the code below is almost certainly incorrect
      # but this is foreign inheritance, so we might
      # have to kludge it in the end.
      my $instance;
      if (my $instance_class = blessed($params->{__INSTANCE__})) {
          ($instance_class eq $class->name)
              || confess "Objects passed as the __INSTANCE__ parameter must "
                       . "already be blessed into the correct class, but "
                       . "$params->{__INSTANCE__} is not a " . $class->name;
          $instance = $params->{__INSTANCE__};
      }
      elsif (exists $params->{__INSTANCE__}) {
          confess "The __INSTANCE__ parameter must be a blessed reference, not "
                . $params->{__INSTANCE__};
      }
      else {
          $instance = $meta_instance->create_instance();
      }
      foreach my $attr ($class->get_all_attributes()) {
          $attr->initialize_instance_slot($meta_instance, $instance, $params);
      }
      if (Class::MOP::metaclass_is_weak($class->name)) {
          $meta_instance->_set_mop_slot($instance, $class);
      }
      return $instance;
  }
  
  sub _inline_new_object {
      my $self = shift;
  
      return (
          'my $class = shift;',
          '$class = Scalar::Util::blessed($class) || $class;',
          $self->_inline_fallback_constructor('$class'),
          $self->_inline_params('$params', '$class'),
          $self->_inline_generate_instance('$instance', '$class'),
          $self->_inline_slot_initializers,
          $self->_inline_preserve_weak_metaclasses,
          $self->_inline_extra_init,
          'return $instance',
      );
  }
  
  sub _inline_fallback_constructor {
      my $self = shift;
      my ($class) = @_;
      return (
          'return ' . $self->_generate_fallback_constructor($class),
              'if ' . $class . ' ne \'' . $self->name . '\';',
      );
  }
  
  sub _generate_fallback_constructor {
      my $self = shift;
      my ($class) = @_;
      return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)',
  }
  
  sub _inline_params {
      my $self = shift;
      my ($params, $class) = @_;
      return (
          'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};',
      );
  }
  
  sub _inline_generate_instance {
      my $self = shift;
      my ($inst, $class) = @_;
      return (
          'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';',
      );
  }
  
  sub _inline_create_instance {
      my $self = shift;
  
      return $self->get_meta_instance->inline_create_instance(@_);
  }
  
  sub _inline_slot_initializers {
      my $self = shift;
  
      my $idx = 0;
  
      return map { $self->_inline_slot_initializer($_, $idx++) }
                 sort { $a->name cmp $b->name } $self->get_all_attributes;
  }
  
  sub _inline_slot_initializer {
      my $self  = shift;
      my ($attr, $idx) = @_;
  
      if (defined(my $init_arg = $attr->init_arg)) {
          my @source = (
              'if (exists $params->{\'' . $init_arg . '\'}) {',
                  $self->_inline_init_attr_from_constructor($attr, $idx),
              '}',
          );
          if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
              push @source, (
                  'else {',
                      @default,
                  '}',
              );
          }
          return @source;
      }
      elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) {
          return (
              '{',
                  @default,
              '}',
          );
      }
      else {
          return ();
      }
  }
  
  sub _inline_init_attr_from_constructor {
      my $self = shift;
      my ($attr, $idx) = @_;
  
      my @initial_value = $attr->_inline_set_value(
          '$instance', '$params->{\'' . $attr->init_arg . '\'}',
      );
  
      push @initial_value, (
          '$attrs->[' . $idx . ']->set_initial_value(',
              '$instance,',
              $attr->_inline_instance_get('$instance'),
          ');',
      ) if $attr->has_initializer;
  
      return @initial_value;
  }
  
  sub _inline_init_attr_from_default {
      my $self = shift;
      my ($attr, $idx) = @_;
  
      my $default = $self->_inline_default_value($attr, $idx);
      return unless $default;
  
      my @initial_value = $attr->_inline_set_value('$instance', $default);
  
      push @initial_value, (
          '$attrs->[' . $idx . ']->set_initial_value(',
              '$instance,',
              $attr->_inline_instance_get('$instance'),
          ');',
      ) if $attr->has_initializer;
  
      return @initial_value;
  }
  
  sub _inline_default_value {
      my $self = shift;
      my ($attr, $index) = @_;
  
      if ($attr->has_default) {
          # NOTE:
          # default values can either be CODE refs
          # in which case we need to call them. Or
          # they can be scalars (strings/numbers)
          # in which case we can just deal with them
          # in the code we eval.
          if ($attr->is_default_a_coderef) {
              return '$defaults->[' . $index . ']->($instance)';
          }
          else {
              return '$defaults->[' . $index . ']';
          }
      }
      elsif ($attr->has_builder) {
          return '$instance->' . $attr->builder;
      }
      else {
          return;
      }
  }
  
  sub _inline_preserve_weak_metaclasses {
      my $self = shift;
      if (Class::MOP::metaclass_is_weak($self->name)) {
          return (
              $self->_inline_set_mop_slot(
                  '$instance', 'Class::MOP::class_of($class)'
              ) . ';'
          );
      }
      else {
          return ();
      }
  }
  
  sub _inline_extra_init { }
  
  sub _eval_environment {
      my $self = shift;
  
      my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
  
      my $defaults = [map { $_->default } @attrs];
  
      return {
          '$defaults' => \$defaults,
      };
  }
  
  
  sub get_meta_instance {
      my $self = shift;
      $self->{'_meta_instance'} ||= $self->_create_meta_instance();
  }
  
  sub _create_meta_instance {
      my $self = shift;
  
      my $instance = $self->instance_metaclass->new(
          associated_metaclass => $self,
          attributes => [ $self->get_all_attributes() ],
      );
  
      $self->add_meta_instance_dependencies()
          if $instance->is_dependent_on_superclasses();
  
      return $instance;
  }
  
  # TODO: this is actually not being used!
  sub _inline_rebless_instance {
      my $self = shift;
  
      return $self->get_meta_instance->inline_rebless_instance_structure(@_);
  }
  
  sub _inline_get_mop_slot {
      my $self = shift;
  
      return $self->get_meta_instance->_inline_get_mop_slot(@_);
  }
  
  sub _inline_set_mop_slot {
      my $self = shift;
  
      return $self->get_meta_instance->_inline_set_mop_slot(@_);
  }
  
  sub _inline_clear_mop_slot {
      my $self = shift;
  
      return $self->get_meta_instance->_inline_clear_mop_slot(@_);
  }
  
  sub clone_object {
      my $class    = shift;
      my $instance = shift;
      (blessed($instance) && $instance->isa($class->name))
          || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)";
  
      # NOTE:
      # we need to protect the integrity of the
      # Class::MOP::Class singletons here, they
      # should not be cloned.
      return $instance if $instance->isa('Class::MOP::Class');
      $class->_clone_instance($instance, @_);
  }
  
  sub _clone_instance {
      my ($class, $instance, %params) = @_;
      (blessed($instance))
          || confess "You can only clone instances, ($instance) is not a blessed instance";
      my $meta_instance = $class->get_meta_instance();
      my $clone = $meta_instance->clone_instance($instance);
      foreach my $attr ($class->get_all_attributes()) {
          if ( defined( my $init_arg = $attr->init_arg ) ) {
              if (exists $params{$init_arg}) {
                  $attr->set_value($clone, $params{$init_arg});
              }
          }
      }
      return $clone;
  }
  
  sub _force_rebless_instance {
      my ($self, $instance, %params) = @_;
      my $old_metaclass = Class::MOP::class_of($instance);
  
      $old_metaclass->rebless_instance_away($instance, $self, %params)
          if $old_metaclass;
  
      my $meta_instance = $self->get_meta_instance;
  
      if (Class::MOP::metaclass_is_weak($old_metaclass->name)) {
          $meta_instance->_clear_mop_slot($instance);
      }
  
      # rebless!
      # we use $_[1] here because of t/cmop/rebless_overload.t regressions
      # on 5.8.8
      $meta_instance->rebless_instance_structure($_[1], $self);
  
      $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params);
  
      if (Class::MOP::metaclass_is_weak($self->name)) {
          $meta_instance->_set_mop_slot($instance, $self);
      }
  }
  
  sub rebless_instance {
      my ($self, $instance, %params) = @_;
      my $old_metaclass = Class::MOP::class_of($instance);
  
      my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
      $self->name->isa($old_class)
          || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
  
      $self->_force_rebless_instance($_[1], %params);
  
      return $instance;
  }
  
  sub rebless_instance_back {
      my ( $self, $instance ) = @_;
      my $old_metaclass = Class::MOP::class_of($instance);
  
      my $old_class
          = $old_metaclass ? $old_metaclass->name : blessed($instance);
      $old_class->isa( $self->name )
          || confess
          "You may rebless only into a superclass of ($old_class), of which ("
          . $self->name
          . ") isn't.";
  
      $self->_force_rebless_instance($_[1]);
  
      return $instance;
  }
  
  sub rebless_instance_away {
      # this intentionally does nothing, it is just a hook
  }
  
  sub _fixup_attributes_after_rebless {
      my $self = shift;
      my ($instance, $rebless_from, %params) = @_;
      my $meta_instance = $self->get_meta_instance;
  
      for my $attr ( $rebless_from->get_all_attributes ) {
          next if $self->find_attribute_by_name( $attr->name );
          $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots;
      }
  
      foreach my $attr ( $self->get_all_attributes ) {
          if ( $attr->has_value($instance) ) {
              if ( defined( my $init_arg = $attr->init_arg ) ) {
                  $params{$init_arg} = $attr->get_value($instance)
                      unless exists $params{$init_arg};
              }
              else {
                  $attr->set_value($instance, $attr->get_value($instance));
              }
          }
      }
  
      foreach my $attr ($self->get_all_attributes) {
          $attr->initialize_instance_slot($meta_instance, $instance, \%params);
      }
  }
  
  sub _attach_attribute {
      my ($self, $attribute) = @_;
      $attribute->attach_to_class($self);
  }
  
  sub _post_add_attribute {
      my ( $self, $attribute ) = @_;
  
      $self->invalidate_meta_instances;
  
      # invalidate package flag here
      try {
          local $SIG{__DIE__};
          $attribute->install_accessors;
      }
      catch {
          $self->remove_attribute( $attribute->name );
          die $_;
      };
  }
  
  sub remove_attribute {
      my $self = shift;
  
      my $removed_attribute = $self->SUPER::remove_attribute(@_)
          or return;
  
      $self->invalidate_meta_instances;
  
      $removed_attribute->remove_accessors;
      $removed_attribute->detach_from_class;
  
      return$removed_attribute;
  }
  
  sub find_attribute_by_name {
      my ( $self, $attr_name ) = @_;
  
      foreach my $class ( $self->linearized_isa ) {
          # fetch the meta-class ...
          my $meta = Class::MOP::Class->initialize($class);
          return $meta->get_attribute($attr_name)
              if $meta->has_attribute($attr_name);
      }
  
      return;
  }
  
  sub get_all_attributes {
      my $self = shift;
      my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } }
          reverse $self->linearized_isa;
      return values %attrs;
  }
  
  # Inheritance
  
  sub superclasses {
      my $self     = shift;
  
      my $isa = $self->get_or_add_package_symbol('@ISA');
  
      if (@_) {
          my @supers = @_;
          @{$isa} = @supers;
  
          # NOTE:
          # on 5.8 and below, we need to call
          # a method to get Perl to detect
          # a cycle in the class hierarchy
          my $class = $self->name;
          $class->isa($class);
  
          # NOTE:
          # we need to check the metaclass
          # compatibility here so that we can
          # be sure that the superclass is
          # not potentially creating an issues
          # we don't know about
  
          $self->_check_metaclass_compatibility();
          $self->_superclasses_updated();
      }
  
      return @{$isa};
  }
  
  sub _superclasses_updated {
      my $self = shift;
      $self->update_meta_instance_dependencies();
      # keep strong references to all our parents, so they don't disappear if
      # they are anon classes and don't have any direct instances
      $self->_superclass_metas(
          map { Class::MOP::class_of($_) } $self->superclasses
      );
  }
  
  sub _superclass_metas {
      my $self = shift;
      $self->{_superclass_metas} = [@_];
  }
  
  sub subclasses {
      my $self = shift;
      my $super_class = $self->name;
  
      return @{ $super_class->mro::get_isarev() };
  }
  
  sub direct_subclasses {
      my $self = shift;
      my $super_class = $self->name;
  
      return grep {
          grep {
              $_ eq $super_class
          } Class::MOP::Class->initialize($_)->superclasses
      } $self->subclasses;
  }
  
  sub linearized_isa {
      return @{ mro::get_linear_isa( (shift)->name ) };
  }
  
  sub class_precedence_list {
      my $self = shift;
      my $name = $self->name;
  
      unless (Class::MOP::IS_RUNNING_ON_5_10()) {
          # NOTE:
          # We need to check for circular inheritance here
          # if we are are not on 5.10, cause 5.8 detects it
          # late. This will do nothing if all is well, and
          # blow up otherwise. Yes, it's an ugly hack, better
          # suggestions are welcome.
          # - SL
          ($name || return)->isa('This is a test for circular inheritance')
      }
  
      # if our mro is c3, we can
      # just grab the linear_isa
      if (mro::get_mro($name) eq 'c3') {
          return @{ mro::get_linear_isa($name) }
      }
      else {
          # NOTE:
          # we can't grab the linear_isa for dfs
          # since it has all the duplicates
          # already removed.
          return (
              $name,
              map {
                  Class::MOP::Class->initialize($_)->class_precedence_list()
              } $self->superclasses()
          );
      }
  }
  
  sub _method_lookup_order {
      return (shift->linearized_isa, 'UNIVERSAL');
  }
  
  ## Methods
  
  {
      my $fetch_and_prepare_method = sub {
          my ($self, $method_name) = @_;
          my $wrapped_metaclass = $self->wrapped_method_metaclass;
          # fetch it locally
          my $method = $self->get_method($method_name);
          # if we dont have local ...
          unless ($method) {
              # try to find the next method
              $method = $self->find_next_method_by_name($method_name);
              # die if it does not exist
              (defined $method)
                  || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name;
              # and now make sure to wrap it
              # even if it is already wrapped
              # because we need a new sub ref
              $method = $wrapped_metaclass->wrap($method,
                  package_name => $self->name,
                  name         => $method_name,
              );
          }
          else {
              # now make sure we wrap it properly
              $method = $wrapped_metaclass->wrap($method,
                  package_name => $self->name,
                  name         => $method_name,
              ) unless $method->isa($wrapped_metaclass);
          }
          $self->add_method($method_name => $method);
          return $method;
      };
  
      sub add_before_method_modifier {
          my ($self, $method_name, $method_modifier) = @_;
          (defined $method_name && length $method_name)
              || confess "You must pass in a method name";
          my $method = $fetch_and_prepare_method->($self, $method_name);
          $method->add_before_modifier(
              subname(':before' => $method_modifier)
          );
      }
  
      sub add_after_method_modifier {
          my ($self, $method_name, $method_modifier) = @_;
          (defined $method_name && length $method_name)
              || confess "You must pass in a method name";
          my $method = $fetch_and_prepare_method->($self, $method_name);
          $method->add_after_modifier(
              subname(':after' => $method_modifier)
          );
      }
  
      sub add_around_method_modifier {
          my ($self, $method_name, $method_modifier) = @_;
          (defined $method_name && length $method_name)
              || confess "You must pass in a method name";
          my $method = $fetch_and_prepare_method->($self, $method_name);
          $method->add_around_modifier(
              subname(':around' => $method_modifier)
          );
      }
  
      # NOTE:
      # the methods above used to be named like this:
      #    ${pkg}::${method}:(before|after|around)
      # but this proved problematic when using one modifier
      # to wrap multiple methods (something which is likely
      # to happen pretty regularly IMO). So instead of naming
      # it like this, I have chosen to just name them purely
      # with their modifier names, like so:
      #    :(before|after|around)
      # The fact is that in a stack trace, it will be fairly
      # evident from the context what method they are attached
      # to, and so don't need the fully qualified name.
  }
  
  sub find_method_by_name {
      my ($self, $method_name) = @_;
      (defined $method_name && length $method_name)
          || confess "You must define a method name to find";
      foreach my $class ($self->_method_lookup_order) {
          my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
          return $method if defined $method;
      }
      return;
  }
  
  sub get_all_methods {
      my $self = shift;
  
      my %methods;
      for my $class ( reverse $self->_method_lookup_order ) {
          my $meta = Class::MOP::Class->initialize($class);
  
          $methods{ $_->name } = $_ for $meta->_get_local_methods;
      }
  
      return values %methods;
  }
  
  sub get_all_method_names {
      my $self = shift;
      map { $_->name } $self->get_all_methods;
  }
  
  sub find_all_methods_by_name {
      my ($self, $method_name) = @_;
      (defined $method_name && length $method_name)
          || confess "You must define a method name to find";
      my @methods;
      foreach my $class ($self->_method_lookup_order) {
          # fetch the meta-class ...
          my $meta = Class::MOP::Class->initialize($class);
          push @methods => {
              name  => $method_name,
              class => $class,
              code  => $meta->get_method($method_name)
          } if $meta->has_method($method_name);
      }
      return @methods;
  }
  
  sub find_next_method_by_name {
      my ($self, $method_name) = @_;
      (defined $method_name && length $method_name)
          || confess "You must define a method name to find";
      my @cpl = ($self->_method_lookup_order);
      shift @cpl; # discard ourselves
      foreach my $class (@cpl) {
          my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
          return $method if defined $method;
      }
      return;
  }
  
  sub update_meta_instance_dependencies {
      my $self = shift;
  
      if ( $self->{meta_instance_dependencies} ) {
          return $self->add_meta_instance_dependencies;
      }
  }
  
  sub add_meta_instance_dependencies {
      my $self = shift;
  
      $self->remove_meta_instance_dependencies;
  
      my @attrs = $self->get_all_attributes();
  
      my %seen;
      my @classes = grep { not $seen{ $_->name }++ }
          map { $_->associated_class } @attrs;
  
      foreach my $class (@classes) {
          $class->add_dependent_meta_instance($self);
      }
  
      $self->{meta_instance_dependencies} = \@classes;
  }
  
  sub remove_meta_instance_dependencies {
      my $self = shift;
  
      if ( my $classes = delete $self->{meta_instance_dependencies} ) {
          foreach my $class (@$classes) {
              $class->remove_dependent_meta_instance($self);
          }
  
          return $classes;
      }
  
      return;
  
  }
  
  sub add_dependent_meta_instance {
      my ( $self, $metaclass ) = @_;
      push @{ $self->{dependent_meta_instances} }, $metaclass;
  }
  
  sub remove_dependent_meta_instance {
      my ( $self, $metaclass ) = @_;
      my $name = $metaclass->name;
      @$_ = grep { $_->name ne $name } @$_
          for $self->{dependent_meta_instances};
  }
  
  sub invalidate_meta_instances {
      my $self = shift;
      $_->invalidate_meta_instance()
          for $self, @{ $self->{dependent_meta_instances} };
  }
  
  sub invalidate_meta_instance {
      my $self = shift;
      undef $self->{_meta_instance};
  }
  
  # check if we can reinitialize
  sub is_pristine {
      my $self = shift;
  
      # if any local attr is defined
      return if $self->get_attribute_list;
  
      # or any non-declared methods
      for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
          return if $method->isa("Class::MOP::Method::Generated");
          # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
      }
  
      return 1;
  }
  
  ## Class closing
  
  sub is_mutable   { 1 }
  sub is_immutable { 0 }
  
  sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
  
  sub _immutable_options {
      my ( $self, @args ) = @_;
  
      return (
          inline_accessors   => 1,
          inline_constructor => 1,
          inline_destructor  => 0,
          debug              => 0,
          immutable_trait    => $self->immutable_trait,
          constructor_name   => $self->constructor_name,
          constructor_class  => $self->constructor_class,
          destructor_class   => $self->destructor_class,
          @args,
      );
  }
  
  sub make_immutable {
      my ( $self, @args ) = @_;
  
      return $self unless $self->is_mutable;
  
      my ($file, $line) = (caller)[1..2];
  
      $self->_initialize_immutable(
          file => $file,
          line => $line,
          $self->_immutable_options(@args),
      );
      $self->_rebless_as_immutable(@args);
  
      return $self;
  }
  
  sub make_mutable {
      my $self = shift;
  
      if ( $self->is_immutable ) {
          my @args = $self->immutable_options;
          $self->_rebless_as_mutable();
          $self->_remove_inlined_code(@args);
          delete $self->{__immutable};
          return $self;
      }
      else {
          return;
      }
  }
  
  sub _rebless_as_immutable {
      my ( $self, @args ) = @_;
  
      $self->{__immutable}{original_class} = ref $self;
  
      bless $self => $self->_immutable_metaclass(@args);
  }
  
  sub _immutable_metaclass {
      my ( $self, %args ) = @_;
  
      if ( my $class = $args{immutable_metaclass} ) {
          return $class;
      }
  
      my $trait = $args{immutable_trait} = $self->immutable_trait
          || confess "no immutable trait specified for $self";
  
      my $meta      = $self->meta;
      my $meta_attr = $meta->find_attribute_by_name("immutable_trait");
  
      my $class_name;
  
      if ( $meta_attr and $trait eq $meta_attr->default ) {
          # if the trait is the same as the default we try and pick a
          # predictable name for the immutable metaclass
          $class_name = 'Class::MOP::Class::Immutable::' . ref($self);
      }
      else {
          $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
              $trait, 'ForMetaClass', ref($self);
      }
  
      return $class_name
          if is_class_loaded($class_name);
  
      # If the metaclass is a subclass of CMOP::Class which has had
      # metaclass roles applied (via Moose), then we want to make sure
      # that we preserve that anonymous class (see Fey::ORM for an
      # example of where this matters).
      my $meta_name = $meta->_real_ref_name;
  
      my $immutable_meta = $meta_name->create(
          $class_name,
          superclasses => [ ref $self ],
      );
  
      Class::MOP::MiniTrait::apply( $immutable_meta, $trait );
  
      $immutable_meta->make_immutable(
          inline_constructor => 0,
          inline_accessors   => 0,
      );
  
      return $class_name;
  }
  
  sub _remove_inlined_code {
      my $self = shift;
  
      $self->remove_method( $_->name ) for $self->_inlined_methods;
  
      delete $self->{__immutable}{inlined_methods};
  }
  
  sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
  
  sub _add_inlined_method {
      my ( $self, $method ) = @_;
  
      push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
  }
  
  sub _initialize_immutable {
      my ( $self, %args ) = @_;
  
      $self->{__immutable}{options} = \%args;
      $self->_install_inlined_code(%args);
  }
  
  sub _install_inlined_code {
      my ( $self, %args ) = @_;
  
      # FIXME
      $self->_inline_accessors(%args)   if $args{inline_accessors};
      $self->_inline_constructor(%args) if $args{inline_constructor};
      $self->_inline_destructor(%args)  if $args{inline_destructor};
  }
  
  sub _rebless_as_mutable {
      my $self = shift;
  
      bless $self, $self->_get_mutable_metaclass_name;
  
      return $self;
  }
  
  sub _inline_accessors {
      my $self = shift;
  
      foreach my $attr_name ( $self->get_attribute_list ) {
          $self->get_attribute($attr_name)->install_accessors(1);
      }
  }
  
  sub _inline_constructor {
      my ( $self, %args ) = @_;
  
      my $name = $args{constructor_name};
      # A class may not even have a constructor, and that's okay.
      return unless defined $name;
  
      if ( $self->has_method($name) && !$args{replace_constructor} ) {
          my $class = $self->name;
          warn "Not inlining a constructor for $class since it defines"
              . " its own constructor.\n"
              . "If you are certain you don't need to inline your"
              . " constructor, specify inline_constructor => 0 in your"
              . " call to $class->meta->make_immutable\n";
          return;
      }
  
      my $constructor_class = $args{constructor_class};
  
      load_class($constructor_class);
  
      my $constructor = $constructor_class->new(
          options      => \%args,
          metaclass    => $self,
          is_inline    => 1,
          package_name => $self->name,
          name         => $name,
          definition_context => {
              description => "constructor " . $self->name . "::" . $name,
              file        => $args{file},
              line        => $args{line},
          },
      );
  
      if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
          $self->add_method( $name => $constructor );
          $self->_add_inlined_method($constructor);
      }
  }
  
  sub _inline_destructor {
      my ( $self, %args ) = @_;
  
      ( exists $args{destructor_class} && defined $args{destructor_class} )
          || confess "The 'inline_destructor' option is present, but "
          . "no destructor class was specified";
  
      if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) {
          my $class = $self->name;
          warn "Not inlining a destructor for $class since it defines"
              . " its own destructor.\n";
          return;
      }
  
      my $destructor_class = $args{destructor_class};
  
      load_class($destructor_class);
  
      return unless $destructor_class->is_needed($self);
  
      my $destructor = $destructor_class->new(
          options      => \%args,
          metaclass    => $self,
          package_name => $self->name,
          name         => 'DESTROY',
          definition_context => {
              description => "destructor " . $self->name . "::DESTROY",
              file        => $args{file},
              line        => $args{line},
          },
      );
  
      if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
          $self->add_method( 'DESTROY' => $destructor );
          $self->_add_inlined_method($destructor);
      }
  }
  
  1;
  
  # ABSTRACT: Class Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Class - Class Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    # assuming that class Foo
    # has been defined, you can
  
    # use this for introspection ...
  
    # add a method to Foo ...
    Foo->meta->add_method( 'bar' => sub {...} )
  
    # get a list of all the classes searched
    # the method dispatcher in the correct order
    Foo->meta->class_precedence_list()
  
    # remove a method from Foo
    Foo->meta->remove_method('bar');
  
    # or use this to actually create classes ...
  
    Class::MOP::Class->create(
        'Bar' => (
            version      => '0.01',
            superclasses => ['Foo'],
            attributes   => [
                Class::MOP::Attribute->new('$bar'),
                Class::MOP::Attribute->new('$baz'),
            ],
            methods => {
                calculate_bar => sub {...},
                construct_baz => sub {...}
            }
        )
    );
  
  =head1 DESCRIPTION
  
  The Class Protocol is the largest and most complex part of the
  Class::MOP meta-object protocol. It controls the introspection and
  manipulation of Perl 5 classes, and it can create them as well. The
  best way to understand what this module can do is to read the
  documentation for each of its methods.
  
  =head1 INHERITANCE
  
  C<Class::MOP::Class> is a subclass of L<Class::MOP::Module>.
  
  =head1 METHODS
  
  =head2 Class construction
  
  These methods all create new C<Class::MOP::Class> objects. These
  objects can represent existing classes or they can be used to create
  new classes from scratch.
  
  The metaclass object for a given class is a singleton. If you attempt
  to create a metaclass for the same class twice, you will just get the
  existing object.
  
  =over 4
  
  =item B<< Class::MOP::Class->create($package_name, %options) >>
  
  This method creates a new C<Class::MOP::Class> object with the given
  package name. It accepts a number of options:
  
  =over 8
  
  =item * version
  
  An optional version number for the newly created package.
  
  =item * authority
  
  An optional authority for the newly created package.
  
  =item * superclasses
  
  An optional array reference of superclass names.
  
  =item * methods
  
  An optional hash reference of methods for the class. The keys of the
  hash reference are method names and values are subroutine references.
  
  =item * attributes
  
  An optional array reference of L<Class::MOP::Attribute> objects.
  
  =item * meta_name
  
  Specifies the name to install the C<meta> method for this class under.
  If it is not passed, C<meta> is assumed, and if C<undef> is explicitly
  given, no meta method will be installed.
  
  =item * weaken
  
  If true, the metaclass that is stored in the global cache will be a
  weak reference.
  
  Classes created in this way are destroyed once the metaclass they are
  attached to goes out of scope, and will be removed from Perl's internal
  symbol table.
  
  All instances of a class with a weakened metaclass keep a special
  reference to the metaclass object, which prevents the metaclass from
  going out of scope while any instances exist.
  
  This only works if the instance is based on a hash reference, however.
  
  =back
  
  =item B<< Class::MOP::Class->create_anon_class(%options) >>
  
  This method works just like C<< Class::MOP::Class->create >> but it
  creates an "anonymous" class. In fact, the class does have a name, but
  that name is a unique name generated internally by this module.
  
  It accepts the same C<superclasses>, C<methods>, and C<attributes>
  parameters that C<create> accepts.
  
  Anonymous classes default to C<< weaken => 1 >>, although this can be
  overridden.
  
  =item B<< Class::MOP::Class->initialize($package_name, %options) >>
  
  This method will initialize a C<Class::MOP::Class> object for the
  named package. Unlike C<create>, this method I<will not> create a new
  class.
  
  The purpose of this method is to retrieve a C<Class::MOP::Class>
  object for introspecting an existing class.
  
  If an existing C<Class::MOP::Class> object exists for the named
  package, it will be returned, and any options provided will be
  ignored!
  
  If the object does not yet exist, it will be created.
  
  The valid options that can be passed to this method are
  C<attribute_metaclass>, C<method_metaclass>,
  C<wrapped_method_metaclass>, and C<instance_metaclass>. These are all
  optional, and default to the appropriate class in the C<Class::MOP>
  distribution.
  
  =back
  
  =head2 Object instance construction and cloning
  
  These methods are all related to creating and/or cloning object
  instances.
  
  =over 4
  
  =item B<< $metaclass->clone_object($instance, %params) >>
  
  This method clones an existing object instance. Any parameters you
  provide are will override existing attribute values in the object.
  
  This is a convenience method for cloning an object instance, then
  blessing it into the appropriate package.
  
  You could implement a clone method in your class, using this method:
  
    sub clone {
        my ($self, %params) = @_;
        $self->meta->clone_object($self, %params);
    }
  
  =item B<< $metaclass->rebless_instance($instance, %params) >>
  
  This method changes the class of C<$instance> to the metaclass's class.
  
  You can only rebless an instance into a subclass of its current
  class. If you pass any additional parameters, these will be treated
  like constructor parameters and used to initialize the object's
  attributes. Any existing attributes that are already set will be
  overwritten.
  
  Before reblessing the instance, this method will call
  C<rebless_instance_away> on the instance's current metaclass. This method
  will be passed the instance, the new metaclass, and any parameters
  specified to C<rebless_instance>. By default, C<rebless_instance_away>
  does nothing; it is merely a hook.
  
  =item B<< $metaclass->rebless_instance_back($instance) >>
  
  Does the same thing as C<rebless_instance>, except that you can only
  rebless an instance into one of its superclasses. Any attributes that
  do not exist in the superclass will be deinitialized.
  
  This is a much more dangerous operation than C<rebless_instance>,
  especially when multiple inheritance is involved, so use this carefully!
  
  =item B<< $metaclass->new_object(%params) >>
  
  This method is used to create a new object of the metaclass's
  class. Any parameters you provide are used to initialize the
  instance's attributes. A special C<__INSTANCE__> key can be passed to
  provide an already generated instance, rather than having Class::MOP
  generate it for you. This is mostly useful for using Class::MOP with
  foreign classes which generate instances using their own constructors.
  
  =item B<< $metaclass->instance_metaclass >>
  
  Returns the class name of the instance metaclass. See
  L<Class::MOP::Instance> for more information on the instance
  metaclass.
  
  =item B<< $metaclass->get_meta_instance >>
  
  Returns an instance of the C<instance_metaclass> to be used in the
  construction of a new instance of the class.
  
  =back
  
  =head2 Informational predicates
  
  These are a few predicate methods for asking information about the
  class itself.
  
  =over 4
  
  =item B<< $metaclass->is_anon_class >>
  
  This returns true if the class was created by calling C<<
  Class::MOP::Class->create_anon_class >>.
  
  =item B<< $metaclass->is_mutable >>
  
  This returns true if the class is still mutable.
  
  =item B<< $metaclass->is_immutable >>
  
  This returns true if the class has been made immutable.
  
  =item B<< $metaclass->is_pristine >>
  
  A class is I<not> pristine if it has non-inherited attributes or if it
  has any generated methods.
  
  =back
  
  =head2 Inheritance Relationships
  
  =over 4
  
  =item B<< $metaclass->superclasses(@superclasses) >>
  
  This is a read-write accessor which represents the superclass
  relationships of the metaclass's class.
  
  This is basically sugar around getting and setting C<@ISA>.
  
  =item B<< $metaclass->class_precedence_list >>
  
  This returns a list of all of the class's ancestor classes. The
  classes are returned in method dispatch order.
  
  =item B<< $metaclass->linearized_isa >>
  
  This returns a list based on C<class_precedence_list> but with all
  duplicates removed.
  
  =item B<< $metaclass->subclasses >>
  
  This returns a list of all subclasses for this class, even indirect
  subclasses.
  
  =item B<< $metaclass->direct_subclasses >>
  
  This returns a list of immediate subclasses for this class, which does not
  include indirect subclasses.
  
  =back
  
  =head2 Method introspection and creation
  
  These methods allow you to introspect a class's methods, as well as
  add, remove, or change methods.
  
  Determining what is truly a method in a Perl 5 class requires some
  heuristics (aka guessing).
  
  Methods defined outside the package with a fully qualified name (C<sub
  Package::name { ... }>) will be included. Similarly, methods named
  with a fully qualified name using L<Sub::Name> are also included.
  
  However, we attempt to ignore imported functions.
  
  Ultimately, we are using heuristics to determine what truly is a
  method in a class, and these heuristics may get the wrong answer in
  some edge cases. However, for most "normal" cases the heuristics work
  correctly.
  
  =over 4
  
  =item B<< $metaclass->get_method($method_name) >>
  
  This will return a L<Class::MOP::Method> for the specified
  C<$method_name>. If the class does not have the specified method, it
  returns C<undef>
  
  =item B<< $metaclass->has_method($method_name) >>
  
  Returns a boolean indicating whether or not the class defines the
  named method. It does not include methods inherited from parent
  classes.
  
  =item B<< $metaclass->get_method_list >>
  
  This will return a list of method I<names> for all methods defined in
  this class.
  
  =item B<< $metaclass->add_method($method_name, $method) >>
  
  This method takes a method name and a subroutine reference, and adds
  the method to the class.
  
  The subroutine reference can be a L<Class::MOP::Method>, and you are
  strongly encouraged to pass a meta method object instead of a code
  reference. If you do so, that object gets stored as part of the
  class's method map directly. If not, the meta information will have to
  be recreated later, and may be incorrect.
  
  If you provide a method object, this method will clone that object if
  the object's package name does not match the class name. This lets us
  track the original source of any methods added from other classes
  (notably Moose roles).
  
  =item B<< $metaclass->remove_method($method_name) >>
  
  Remove the named method from the class. This method returns the
  L<Class::MOP::Method> object for the method.
  
  =item B<< $metaclass->method_metaclass >>
  
  Returns the class name of the method metaclass, see
  L<Class::MOP::Method> for more information on the method metaclass.
  
  =item B<< $metaclass->wrapped_method_metaclass >>
  
  Returns the class name of the wrapped method metaclass, see
  L<Class::MOP::Method::Wrapped> for more information on the wrapped
  method metaclass.
  
  =item B<< $metaclass->get_all_methods >>
  
  This will traverse the inheritance hierarchy and return a list of all
  the L<Class::MOP::Method> objects for this class and its parents.
  
  =item B<< $metaclass->find_method_by_name($method_name) >>
  
  This will return a L<Class::MOP::Method> for the specified
  C<$method_name>. If the class does not have the specified method, it
  returns C<undef>
  
  Unlike C<get_method>, this method I<will> look for the named method in
  superclasses.
  
  =item B<< $metaclass->get_all_method_names >>
  
  This will return a list of method I<names> for all of this class's
  methods, including inherited methods.
  
  =item B<< $metaclass->find_all_methods_by_name($method_name) >>
  
  This method looks for the named method in the class and all of its
  parents. It returns every matching method it finds in the inheritance
  tree, so it returns a list of methods.
  
  Each method is returned as a hash reference with three keys. The keys
  are C<name>, C<class>, and C<code>. The C<code> key has a
  L<Class::MOP::Method> object as its value.
  
  The list of methods is distinct.
  
  =item B<< $metaclass->find_next_method_by_name($method_name) >>
  
  This method returns the first method in any superclass matching the
  given name. It is effectively the method that C<SUPER::$method_name>
  would dispatch to.
  
  =back
  
  =head2 Attribute introspection and creation
  
  Because Perl 5 does not have a core concept of attributes in classes,
  we can only return information about attributes which have been added
  via this class's methods. We cannot discover information about
  attributes which are defined in terms of "regular" Perl 5 methods.
  
  =over 4
  
  =item B<< $metaclass->get_attribute($attribute_name) >>
  
  This will return a L<Class::MOP::Attribute> for the specified
  C<$attribute_name>. If the class does not have the specified
  attribute, it returns C<undef>.
  
  NOTE that get_attribute does not search superclasses, for that you
  need to use C<find_attribute_by_name>.
  
  =item B<< $metaclass->has_attribute($attribute_name) >>
  
  Returns a boolean indicating whether or not the class defines the
  named attribute. It does not include attributes inherited from parent
  classes.
  
  =item B<< $metaclass->get_attribute_list >>
  
  This will return a list of attributes I<names> for all attributes
  defined in this class.  Note that this operates on the current class
  only, it does not traverse the inheritance hierarchy.
  
  =item B<< $metaclass->get_all_attributes >>
  
  This will traverse the inheritance hierarchy and return a list of all
  the L<Class::MOP::Attribute> objects for this class and its parents.
  
  =item B<< $metaclass->find_attribute_by_name($attribute_name) >>
  
  This will return a L<Class::MOP::Attribute> for the specified
  C<$attribute_name>. If the class does not have the specified
  attribute, it returns C<undef>.
  
  Unlike C<get_attribute>, this attribute I<will> look for the named
  attribute in superclasses.
  
  =item B<< $metaclass->add_attribute(...) >>
  
  This method accepts either an existing L<Class::MOP::Attribute>
  object or parameters suitable for passing to that class's C<new>
  method.
  
  The attribute provided will be added to the class.
  
  Any accessor methods defined by the attribute will be added to the
  class when the attribute is added.
  
  If an attribute of the same name already exists, the old attribute
  will be removed first.
  
  =item B<< $metaclass->remove_attribute($attribute_name) >>
  
  This will remove the named attribute from the class, and
  L<Class::MOP::Attribute> object.
  
  Removing an attribute also removes any accessor methods defined by the
  attribute.
  
  However, note that removing an attribute will only affect I<future>
  object instances created for this class, not existing instances.
  
  =item B<< $metaclass->attribute_metaclass >>
  
  Returns the class name of the attribute metaclass for this class. By
  default, this is L<Class::MOP::Attribute>.
  
  =back
  
  =head2 Class Immutability
  
  Making a class immutable "freezes" the class definition. You can no
  longer call methods which alter the class, such as adding or removing
  methods or attributes.
  
  Making a class immutable lets us optimize the class by inlining some
  methods, and also allows us to optimize some methods on the metaclass
  object itself.
  
  After immutabilization, the metaclass object will cache most informational
  methods that returns information about methods or attributes. Methods which
  would alter the class, such as C<add_attribute> and C<add_method>, will
  throw an error on an immutable metaclass object.
  
  The immutabilization system in L<Moose> takes much greater advantage
  of the inlining features than Class::MOP itself does.
  
  =over 4
  
  =item B<< $metaclass->make_immutable(%options) >>
  
  This method will create an immutable transformer and use it to make
  the class and its metaclass object immutable, and returns true
  (you should not rely on the details of this value apart from its truth).
  
  This method accepts the following options:
  
  =over 8
  
  =item * inline_accessors
  
  =item * inline_constructor
  
  =item * inline_destructor
  
  These are all booleans indicating whether the specified method(s)
  should be inlined.
  
  By default, accessors and the constructor are inlined, but not the
  destructor.
  
  =item * immutable_trait
  
  The name of a class which will be used as a parent class for the
  metaclass object being made immutable. This "trait" implements the
  post-immutability functionality of the metaclass (but not the
  transformation itself).
  
  This defaults to L<Class::MOP::Class::Immutable::Trait>.
  
  =item * constructor_name
  
  This is the constructor method name. This defaults to "new".
  
  =item * constructor_class
  
  The name of the method metaclass for constructors. It will be used to
  generate the inlined constructor. This defaults to
  "Class::MOP::Method::Constructor".
  
  =item * replace_constructor
  
  This is a boolean indicating whether an existing constructor should be
  replaced when inlining a constructor. This defaults to false.
  
  =item * destructor_class
  
  The name of the method metaclass for destructors. It will be used to
  generate the inlined destructor. This defaults to
  "Class::MOP::Method::Denstructor".
  
  =item * replace_destructor
  
  This is a boolean indicating whether an existing destructor should be
  replaced when inlining a destructor. This defaults to false.
  
  =back
  
  =item B<< $metaclass->immutable_options >>
  
  Returns a hash of the options used when making the class immutable, including
  both defaults and anything supplied by the user in the call to C<<
  $metaclass->make_immutable >>. This is useful if you need to temporarily make
  a class mutable and then restore immutability as it was before.
  
  =item B<< $metaclass->make_mutable >>
  
  Calling this method reverse the immutabilization transformation.
  
  =back
  
  =head2 Method Modifiers
  
  Method modifiers are hooks which allow a method to be wrapped with
  I<before>, I<after> and I<around> method modifiers. Every time a
  method is called, its modifiers are also called.
  
  A class can modify its own methods, as well as methods defined in
  parent classes.
  
  =head3 How method modifiers work?
  
  Method modifiers work by wrapping the original method and then
  replacing it in the class's symbol table. The wrappers will handle
  calling all the modifiers in the appropriate order and preserving the
  calling context for the original method.
  
  The return values of C<before> and C<after> modifiers are
  ignored. This is because their purpose is B<not> to filter the input
  and output of the primary method (this is done with an I<around>
  modifier).
  
  This may seem like an odd restriction to some, but doing this allows
  for simple code to be added at the beginning or end of a method call
  without altering the function of the wrapped method or placing any
  extra responsibility on the code of the modifier.
  
  Of course if you have more complex needs, you can use the C<around>
  modifier which allows you to change both the parameters passed to the
  wrapped method, as well as its return value.
  
  Before and around modifiers are called in last-defined-first-called
  order, while after modifiers are called in first-defined-first-called
  order. So the call tree might looks something like this:
  
    before 2
     before 1
      around 2
       around 1
        primary
       around 1
      around 2
     after 1
    after 2
  
  =head3 What is the performance impact?
  
  Of course there is a performance cost associated with method
  modifiers, but we have made every effort to make that cost directly
  proportional to the number of modifier features you use.
  
  The wrapping method does its best to B<only> do as much work as it
  absolutely needs to. In order to do this we have moved some of the
  performance costs to set-up time, where they are easier to amortize.
  
  All this said, our benchmarks have indicated the following:
  
    simple wrapper with no modifiers             100% slower
    simple wrapper with simple before modifier   400% slower
    simple wrapper with simple after modifier    450% slower
    simple wrapper with simple around modifier   500-550% slower
    simple wrapper with all 3 modifiers          1100% slower
  
  These numbers may seem daunting, but you must remember, every feature
  comes with some cost. To put things in perspective, just doing a
  simple C<AUTOLOAD> which does nothing but extract the name of the
  method called and return it costs about 400% over a normal method
  call.
  
  =over 4
  
  =item B<< $metaclass->add_before_method_modifier($method_name, $code) >>
  
  This wraps the specified method with the supplied subroutine
  reference. The modifier will be called as a method itself, and will
  receive the same arguments as are passed to the method.
  
  When the modifier exits, the wrapped method will be called.
  
  The return value of the modifier will be ignored.
  
  =item B<< $metaclass->add_after_method_modifier($method_name, $code) >>
  
  This wraps the specified method with the supplied subroutine
  reference. The modifier will be called as a method itself, and will
  receive the same arguments as are passed to the method.
  
  When the wrapped methods exits, the modifier will be called.
  
  The return value of the modifier will be ignored.
  
  =item B<< $metaclass->add_around_method_modifier($method_name, $code) >>
  
  This wraps the specified method with the supplied subroutine
  reference.
  
  The first argument passed to the modifier will be a subroutine
  reference to the wrapped method. The second argument is the object,
  and after that come any arguments passed when the method is called.
  
  The around modifier can choose to call the original method, as well as
  what arguments to pass if it does so.
  
  The return value of the modifier is what will be seen by the caller.
  
  =back
  
  =head2 Introspection
  
  =over 4
  
  =item B<< Class::MOP::Class->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  It should also be noted that L<Class::MOP> will actually bootstrap
  this module by installing a number of attribute meta-objects into its
  metaclass.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_CLASS

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Class/Immutable/Trait.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_CLASS_IMMUTABLE_TRAIT';
  package Class::MOP::Class::Immutable::Trait;
  BEGIN {
    $Class::MOP::Class::Immutable::Trait::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Class::Immutable::Trait::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use MRO::Compat;
  
  use Carp 'confess';
  use Scalar::Util 'blessed', 'weaken';
  
  # the original class of the metaclass instance
  sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
  
  sub is_mutable   { 0 }
  sub is_immutable { 1 }
  
  sub _immutable_metaclass { ref $_[1] }
  
  sub _immutable_read_only {
      my $name = shift;
      confess "The '$name' method is read-only when called on an immutable instance";
  }
  
  sub _immutable_cannot_call {
      my $name = shift;
      Carp::confess "The '$name' method cannot be called on an immutable instance";
  }
  
  for my $name (qw/superclasses/) {
      no strict 'refs';
      *{__PACKAGE__."::$name"} = sub {
          my $orig = shift;
          my $self = shift;
          _immutable_read_only($name) if @_;
          $self->$orig;
      };
  }
  
  for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) {
      no strict 'refs';
      *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
  }
  
  sub class_precedence_list {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{class_precedence_list}
              ||= [ $self->$orig ] };
  }
  
  sub linearized_isa {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
  }
  
  sub get_all_methods {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
  }
  
  sub get_all_method_names {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
  }
  
  sub get_all_attributes {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
  }
  
  sub get_meta_instance {
      my $orig = shift;
      my $self = shift;
      $self->{__immutable}{get_meta_instance} ||= $self->$orig;
  }
  
  sub _method_map {
      my $orig = shift;
      my $self = shift;
      $self->{__immutable}{_method_map} ||= $self->$orig;
  }
  
  1;
  
  # ABSTRACT: Implements immutability for metaclass objects
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class provides a pseudo-trait that is applied to immutable metaclass
  objects. In reality, it is simply a parent class.
  
  It implements caching and read-only-ness for various metaclass methods.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_CLASS_IMMUTABLE_TRAIT

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Deprecated.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_DEPRECATED';
  package Class::MOP::Deprecated;
  BEGIN {
    $Class::MOP::Deprecated::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Deprecated::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Package::DeprecationManager -deprecations => {
  };
  
  1;
  
  # ABSTRACT: Manages deprecation warnings for Class::MOP
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
      use Class::MOP::Deprecated -api_version => $version;
  
  =head1 FUNCTIONS
  
  This module manages deprecation warnings for features that have been
  deprecated in Class::MOP.
  
  If you specify C<< -api_version => $version >>, you can use deprecated features
  without warnings. Note that this special treatment is limited to the package
  that loads C<Class::MOP::Deprecated>.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_DEPRECATED

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Instance.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_INSTANCE';
  
  package Class::MOP::Instance;
  BEGIN {
    $Class::MOP::Instance::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Instance::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util 'isweak', 'weaken', 'blessed';
  
  use base 'Class::MOP::Object';
  
  # make this not a valid method name, to avoid (most) attribute conflicts
  my $RESERVED_MOP_SLOT = '<<MOP>>';
  
  sub BUILDARGS {
      my ($class, @args) = @_;
  
      if ( @args == 1 ) {
          unshift @args, "associated_metaclass";
      } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
          # compat mode
          my ( $meta, @attrs ) = @args;
          @args = ( associated_metaclass => $meta, attributes => \@attrs );
      }
  
      my %options = @args;
      # FIXME lazy_build
      $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
      $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
  
      return \%options;
  }
  
  sub new {
      my $class = shift;
      my $options = $class->BUILDARGS(@_);
  
      # FIXME replace with a proper constructor
      my $instance = $class->_new(%$options);
  
      # FIXME weak_ref => 1,
      weaken($instance->{'associated_metaclass'});
  
      return $instance;
  }
  
  sub _new {
      my $class = shift;
      return Class::MOP::Class->initialize($class)->new_object(@_)
        if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
      return bless {
          # NOTE:
          # I am not sure that it makes
          # sense to pass in the meta
          # The ideal would be to just
          # pass in the class name, but
          # that is placing too much of
          # an assumption on bless(),
          # which is *probably* a safe
          # assumption,.. but you can
          # never tell <:)
          'associated_metaclass' => $params->{associated_metaclass},
          'attributes'           => $params->{attributes},
          'slots'                => $params->{slots},
          'slot_hash'            => $params->{slot_hash},
      } => $class;
  }
  
  sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
  
  sub create_instance {
      my $self = shift;
      bless {}, $self->_class_name;
  }
  
  sub clone_instance {
      my ($self, $instance) = @_;
  
      my $clone = $self->create_instance;
      for my $attr ($self->get_all_attributes) {
          next unless $attr->has_value($instance);
          for my $slot ($attr->slots) {
              my $val = $self->get_slot_value($instance, $slot);
              $self->set_slot_value($clone, $slot, $val);
              $self->weaken_slot_value($clone, $slot)
                  if $self->slot_value_is_weak($instance, $slot);
          }
      }
  
      $self->_set_mop_slot($clone, $self->_get_mop_slot($instance))
          if $self->_has_mop_slot($instance);
  
      return $clone;
  }
  
  # operations on meta instance
  
  sub get_all_slots {
      my $self = shift;
      return @{$self->{'slots'}};
  }
  
  sub get_all_attributes {
      my $self = shift;
      return @{$self->{attributes}};
  }
  
  sub is_valid_slot {
      my ($self, $slot_name) = @_;
      exists $self->{'slot_hash'}->{$slot_name};
  }
  
  # operations on created instances
  
  sub get_slot_value {
      my ($self, $instance, $slot_name) = @_;
      $instance->{$slot_name};
  }
  
  sub set_slot_value {
      my ($self, $instance, $slot_name, $value) = @_;
      $instance->{$slot_name} = $value;
  }
  
  sub initialize_slot {
      my ($self, $instance, $slot_name) = @_;
      return;
  }
  
  sub deinitialize_slot {
      my ( $self, $instance, $slot_name ) = @_;
      delete $instance->{$slot_name};
  }
  
  sub initialize_all_slots {
      my ($self, $instance) = @_;
      foreach my $slot_name ($self->get_all_slots) {
          $self->initialize_slot($instance, $slot_name);
      }
  }
  
  sub deinitialize_all_slots {
      my ($self, $instance) = @_;
      foreach my $slot_name ($self->get_all_slots) {
          $self->deinitialize_slot($instance, $slot_name);
      }
  }
  
  sub is_slot_initialized {
      my ($self, $instance, $slot_name, $value) = @_;
      exists $instance->{$slot_name};
  }
  
  sub weaken_slot_value {
      my ($self, $instance, $slot_name) = @_;
      weaken $instance->{$slot_name};
  }
  
  sub slot_value_is_weak {
      my ($self, $instance, $slot_name) = @_;
      isweak $instance->{$slot_name};
  }
  
  sub strengthen_slot_value {
      my ($self, $instance, $slot_name) = @_;
      $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
  }
  
  sub rebless_instance_structure {
      my ($self, $instance, $metaclass) = @_;
  
      # we use $_[1] here because of t/cmop/rebless_overload.t regressions
      # on 5.8.8
      bless $_[1], $metaclass->name;
  }
  
  sub is_dependent_on_superclasses {
      return; # for meta instances that require updates on inherited slot changes
  }
  
  sub _get_mop_slot {
      my ($self, $instance) = @_;
      $self->get_slot_value($instance, $RESERVED_MOP_SLOT);
  }
  
  sub _has_mop_slot {
      my ($self, $instance) = @_;
      $self->is_slot_initialized($instance, $RESERVED_MOP_SLOT);
  }
  
  sub _set_mop_slot {
      my ($self, $instance, $value) = @_;
      $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
  }
  
  sub _clear_mop_slot {
      my ($self, $instance) = @_;
      $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT);
  }
  
  # inlinable operation snippets
  
  sub is_inlinable { 1 }
  
  sub inline_create_instance {
      my ($self, $class_variable) = @_;
      'bless {} => ' . $class_variable;
  }
  
  sub inline_slot_access {
      my ($self, $instance, $slot_name) = @_;
      sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name);
  }
  
  sub inline_get_is_lvalue { 1 }
  
  sub inline_get_slot_value {
      my ($self, $instance, $slot_name) = @_;
      $self->inline_slot_access($instance, $slot_name);
  }
  
  sub inline_set_slot_value {
      my ($self, $instance, $slot_name, $value) = @_;
      $self->inline_slot_access($instance, $slot_name) . " = $value",
  }
  
  sub inline_initialize_slot {
      my ($self, $instance, $slot_name) = @_;
      return '';
  }
  
  sub inline_deinitialize_slot {
      my ($self, $instance, $slot_name) = @_;
      "delete " . $self->inline_slot_access($instance, $slot_name);
  }
  sub inline_is_slot_initialized {
      my ($self, $instance, $slot_name) = @_;
      "exists " . $self->inline_slot_access($instance, $slot_name);
  }
  
  sub inline_weaken_slot_value {
      my ($self, $instance, $slot_name) = @_;
      sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
  }
  
  sub inline_strengthen_slot_value {
      my ($self, $instance, $slot_name) = @_;
      $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
  }
  
  sub inline_rebless_instance_structure {
      my ($self, $instance, $class_variable) = @_;
      "bless $instance => $class_variable";
  }
  
  sub _inline_get_mop_slot {
      my ($self, $instance) = @_;
      $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
  }
  
  sub _inline_set_mop_slot {
      my ($self, $instance, $value) = @_;
      $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
  }
  
  sub _inline_clear_mop_slot {
      my ($self, $instance) = @_;
      $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
  }
  
  1;
  
  # ABSTRACT: Instance Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Instance - Instance Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  The Instance Protocol controls the creation of object instances, and
  the storage of attribute values in those instances.
  
  Using this API directly in your own code violates encapsulation, and
  we recommend that you use the appropriate APIs in L<Class::MOP::Class>
  and L<Class::MOP::Attribute> instead. Those APIs in turn call the
  methods in this class as appropriate.
  
  This class also participates in generating inlined code by providing
  snippets of code to access an object instance.
  
  =head1 METHODS
  
  =head2 Object construction
  
  =over 4
  
  =item B<< Class::MOP::Instance->new(%options) >>
  
  This method creates a new meta-instance object.
  
  It accepts the following keys in C<%options>:
  
  =over 8
  
  =item * associated_metaclass
  
  The L<Class::MOP::Class> object for which instances will be created.
  
  =item * attributes
  
  An array reference of L<Class::MOP::Attribute> objects. These are the
  attributes which can be stored in each instance.
  
  =back
  
  =back
  
  =head2 Creating and altering instances
  
  =over 4
  
  =item B<< $metainstance->create_instance >>
  
  This method returns a reference blessed into the associated
  metaclass's class.
  
  The default is to use a hash reference. Subclasses can override this.
  
  =item B<< $metainstance->clone_instance($instance) >>
  
  Given an instance, this method creates a new object by making
  I<shallow> clone of the original.
  
  =back
  
  =head2 Introspection
  
  =over 4
  
  =item B<< $metainstance->associated_metaclass >>
  
  This returns the L<Class::MOP::Class> object associated with the
  meta-instance object.
  
  =item B<< $metainstance->get_all_slots >>
  
  This returns a list of slot names stored in object instances. In
  almost all cases, slot names correspond directly attribute names.
  
  =item B<< $metainstance->is_valid_slot($slot_name) >>
  
  This will return true if C<$slot_name> is a valid slot name.
  
  =item B<< $metainstance->get_all_attributes >>
  
  This returns a list of attributes corresponding to the attributes
  passed to the constructor.
  
  =back
  
  =head2 Operations on Instance Structures
  
  It's important to understand that the meta-instance object is a
  different entity from the actual instances it creates. For this
  reason, any operations on the C<$instance_structure> always require
  that the object instance be passed to the method.
  
  =over 4
  
  =item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
  
  =item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->initialize_all_slots($instance_structure) >>
  
  =item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
  
  =item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->slot_value_is_weak($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
  
  =item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
  
  The exact details of what each method does should be fairly obvious
  from the method name.
  
  =back
  
  =head2 Inlinable Instance Operations
  
  =over 4
  
  =item B<< $metainstance->is_inlinable >>
  
  This is a boolean that indicates whether or not slot access operations
  can be inlined. By default it is true, but subclasses can override
  this.
  
  =item B<< $metainstance->inline_create_instance($class_variable) >>
  
  This method expects a string that, I<when inlined>, will become a
  class name. This would literally be something like C<'$class'>, not an
  actual class name.
  
  It returns a snippet of code that creates a new object for the
  class. This is something like C< bless {}, $class_name >.
  
  =item B<< $metainstance->inline_get_is_lvalue >>
  
  Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be
  used to do extra optimizations when generating inlined methods.
  
  =item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
  
  =item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
  
  =item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
  
  These methods all expect two arguments. The first is the name of a
  variable, than when inlined, will represent the object
  instance. Typically this will be a literal string like C<'$_[0]'>.
  
  The second argument is a slot name.
  
  The method returns a snippet of code that, when inlined, performs some
  operation on the instance.
  
  =item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
  
  This takes the name of a variable that will, when inlined, represent the object
  instance, and the name of a variable that will represent the class to rebless
  into, and returns code to rebless an instance into a class.
  
  =back
  
  =head2 Introspection
  
  =over 4
  
  =item B<< Class::MOP::Instance->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  It should also be noted that L<Class::MOP> will actually bootstrap
  this module by installing a number of attribute meta-objects into its
  metaclass.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_INSTANCE

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD';
  
  package Class::MOP::Method;
  BEGIN {
    $Class::MOP::Method::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'weaken', 'reftype', 'blessed';
  
  use base 'Class::MOP::Object';
  
  # NOTE:
  # if poked in the right way,
  # they should act like CODE refs.
  use overload '&{}' => sub { $_[0]->body }, fallback => 1;
  
  # construction
  
  sub wrap {
      my ( $class, @args ) = @_;
  
      unshift @args, 'body' if @args % 2 == 1;
  
      my %params = @args;
      my $code = $params{body};
  
      if (blessed($code) && $code->isa(__PACKAGE__)) {
          my $method = $code->clone;
          delete $params{body};
          Class::MOP::class_of($class)->rebless_instance($method, %params);
          return $method;
      }
      elsif (!ref $code || 'CODE' ne reftype($code)) {
          confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
      }
  
      ($params{package_name} && $params{name})
          || confess "You must supply the package_name and name parameters";
  
      my $self = $class->_new(\%params);
  
      weaken($self->{associated_metaclass}) if $self->{associated_metaclass};
  
      return $self;
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          'body'                 => $params->{body},
          'associated_metaclass' => $params->{associated_metaclass},
          'package_name'         => $params->{package_name},
          'name'                 => $params->{name},
          'original_method'      => $params->{original_method},
      } => $class;
  }
  
  ## accessors
  
  sub associated_metaclass { shift->{'associated_metaclass'} }
  
  sub attach_to_class {
      my ( $self, $class ) = @_;
      $self->{associated_metaclass} = $class;
      weaken($self->{associated_metaclass});
  }
  
  sub detach_from_class {
      my $self = shift;
      delete $self->{associated_metaclass};
  }
  
  sub fully_qualified_name {
      my $self = shift;
      $self->package_name . '::' . $self->name;
  }
  
  sub original_method { (shift)->{'original_method'} }
  
  sub _set_original_method { $_[0]->{'original_method'} = $_[1] }
  
  # It's possible that this could cause a loop if there is a circular
  # reference in here. That shouldn't ever happen in normal
  # circumstances, since original method only gets set when clone is
  # called. We _could_ check for such a loop, but it'd involve some sort
  # of package-lexical variable, and wouldn't be terribly subclassable.
  sub original_package_name {
      my $self = shift;
  
      $self->original_method
          ? $self->original_method->original_package_name
          : $self->package_name;
  }
  
  sub original_name {
      my $self = shift;
  
      $self->original_method
          ? $self->original_method->original_name
          : $self->name;
  }
  
  sub original_fully_qualified_name {
      my $self = shift;
  
      $self->original_method
          ? $self->original_method->original_fully_qualified_name
          : $self->fully_qualified_name;
  }
  
  sub execute {
      my $self = shift;
      $self->body->(@_);
  }
  
  # We used to go through use Class::MOP::Class->clone_instance to do this, but
  # this was awfully slow. This method may be called a number of times when
  # classes are loaded (especially during Moose role application), so it is
  # worth optimizing. - DR
  sub clone {
      my $self = shift;
  
      my $clone = bless { %{$self}, @_ }, blessed($self);
  
      $clone->_set_original_method($self);
  
      return $clone;
  }
  
  1;
  
  # ABSTRACT: Method Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method - Method Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  The Method Protocol is very small, since methods in Perl 5 are just
  subroutines in a specific package. We provide a very basic
  introspection interface.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Method->wrap($code, %options) >>
  
  This is the constructor. It accepts a method body in the form of
  either a code reference or a L<Class::MOP::Method> instance, followed
  by a hash of options.
  
  The options are:
  
  =over 8
  
  =item * name
  
  The method name (without a package name). This is required if C<$code>
  is a coderef.
  
  =item * package_name
  
  The package name for the method. This is required if C<$code> is a
  coderef.
  
  =item * associated_metaclass
  
  An optional L<Class::MOP::Class> object. This is the metaclass for the
  method's class.
  
  =back
  
  =item B<< $metamethod->clone(%params) >>
  
  This makes a shallow clone of the method object. In particular,
  subroutine reference itself is shared between all clones of a given
  method.
  
  When a method is cloned, the original method object will be available
  by calling C<original_method> on the clone.
  
  =item B<< $metamethod->body >>
  
  This returns a reference to the method's subroutine.
  
  =item B<< $metamethod->name >>
  
  This returns the method's name
  
  =item B<< $metamethod->package_name >>
  
  This returns the method's package name.
  
  =item B<< $metamethod->fully_qualified_name >>
  
  This returns the method's fully qualified name (package name and
  method name).
  
  =item B<< $metamethod->associated_metaclass >>
  
  This returns the L<Class::MOP::Class> object for the method, if one
  exists.
  
  =item B<< $metamethod->original_method >>
  
  If this method object was created as a clone of some other method
  object, this returns the object that was cloned.
  
  =item B<< $metamethod->original_name >>
  
  This returns the method's original name, wherever it was first
  defined.
  
  If this method is a clone of a clone (of a clone, etc.), this method
  returns the name from the I<first> method in the chain of clones.
  
  =item B<< $metamethod->original_package_name >>
  
  This returns the method's original package name, wherever it was first
  defined.
  
  If this method is a clone of a clone (of a clone, etc.), this method
  returns the package name from the I<first> method in the chain of
  clones.
  
  =item B<< $metamethod->original_fully_qualified_name >>
  
  This returns the method's original fully qualified name, wherever it
  was first defined.
  
  If this method is a clone of a clone (of a clone, etc.), this method
  returns the fully qualified name from the I<first> method in the chain
  of clones.
  
  =item B<< $metamethod->is_stub >>
  
  Returns true if the method is just a stub:
  
    sub foo;
  
  =item B<< $metamethod->attach_to_class($metaclass) >>
  
  Given a L<Class::MOP::Class> object, this method sets the associated
  metaclass for the method. This will overwrite any existing associated
  metaclass.
  
  =item B<< $metamethod->detach_from_class >>
  
  Removes any associated metaclass object for the method.
  
  =item B<< $metamethod->execute(...) >>
  
  This executes the method. Any arguments provided will be passed on to
  the method itself.
  
  =item B<< Class::MOP::Method->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  It should also be noted that L<Class::MOP> will actually bootstrap
  this module by installing a number of attribute meta-objects into its
  metaclass.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Accessor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_ACCESSOR';
  
  package Class::MOP::Method::Accessor;
  BEGIN {
    $Class::MOP::Method::Accessor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Accessor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed', 'weaken';
  use Try::Tiny;
  
  use base 'Class::MOP::Method::Generated';
  
  sub new {
      my $class   = shift;
      my %options = @_;
  
      (exists $options{attribute})
          || confess "You must supply an attribute to construct with";
  
      (exists $options{accessor_type})
          || confess "You must supply an accessor_type to construct with";
  
      (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
          || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
  
      ($options{package_name} && $options{name})
          || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  
      my $self = $class->_new(\%options);
  
      # we don't want this creating
      # a cycle in the code, if not
      # needed
      weaken($self->{'attribute'});
  
      $self->_initialize_body;
  
      return $self;
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          # inherited from Class::MOP::Method
          body                 => $params->{body},
          associated_metaclass => $params->{associated_metaclass},
          package_name         => $params->{package_name},
          name                 => $params->{name},
          original_method      => $params->{original_method},
  
          # inherit from Class::MOP::Generated
          is_inline            => $params->{is_inline} || 0,
          definition_context   => $params->{definition_context},
  
          # defined in this class
          attribute            => $params->{attribute},
          accessor_type        => $params->{accessor_type},
      } => $class;
  }
  
  ## accessors
  
  sub associated_attribute { (shift)->{'attribute'}     }
  sub accessor_type        { (shift)->{'accessor_type'} }
  
  ## factory
  
  sub _initialize_body {
      my $self = shift;
  
      my $method_name = join "_" => (
          '_generate',
          $self->accessor_type,
          'method',
          ($self->is_inline ? 'inline' : ())
      );
  
      $self->{'body'} = $self->$method_name();
  }
  
  ## generators
  
  sub _generate_accessor_method {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return sub {
          if (@_ >= 2) {
              $attr->set_value($_[0], $_[1]);
          }
          $attr->get_value($_[0]);
      };
  }
  
  sub _generate_accessor_method_inline {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return try {
          $self->_compile_code([
              'sub {',
                  'if (@_ > 1) {',
                      $attr->_inline_set_value('$_[0]', '$_[1]'),
                  '}',
                  $attr->_inline_get_value('$_[0]'),
              '}',
          ]);
      }
      catch {
          confess "Could not generate inline accessor because : $_";
      };
  }
  
  sub _generate_reader_method {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return sub {
          confess "Cannot assign a value to a read-only accessor"
              if @_ > 1;
          $attr->get_value($_[0]);
      };
  }
  
  sub _generate_reader_method_inline {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return try {
          $self->_compile_code([
              'sub {',
                  'if (@_ > 1) {',
                      # XXX: this is a hack, but our error stuff is terrible
                      $self->_inline_throw_error(
                          '"Cannot assign a value to a read-only accessor"',
                          'data => \@_'
                      ) . ';',
                  '}',
                  $attr->_inline_get_value('$_[0]'),
              '}',
          ]);
      }
      catch {
          confess "Could not generate inline reader because : $_";
      };
  }
  
  sub _inline_throw_error {
      my $self = shift;
      return 'Carp::confess ' . $_[0];
  }
  
  sub _generate_writer_method {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return sub {
          $attr->set_value($_[0], $_[1]);
      };
  }
  
  sub _generate_writer_method_inline {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return try {
          $self->_compile_code([
              'sub {',
                  $attr->_inline_set_value('$_[0]', '$_[1]'),
              '}',
          ]);
      }
      catch {
          confess "Could not generate inline writer because : $_";
      };
  }
  
  sub _generate_predicate_method {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return sub {
          $attr->has_value($_[0])
      };
  }
  
  sub _generate_predicate_method_inline {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return try {
          $self->_compile_code([
              'sub {',
                  $attr->_inline_has_value('$_[0]'),
              '}',
          ]);
      }
      catch {
          confess "Could not generate inline predicate because : $_";
      };
  }
  
  sub _generate_clearer_method {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return sub {
          $attr->clear_value($_[0])
      };
  }
  
  sub _generate_clearer_method_inline {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      return try {
          $self->_compile_code([
              'sub {',
                  $attr->_inline_clear_value('$_[0]'),
              '}',
          ]);
      }
      catch {
          confess "Could not generate inline clearer because : $_";
      };
  }
  
  1;
  
  # ABSTRACT: Method Meta Object for accessors
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Accessor - Method Meta Object for accessors
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
      use Class::MOP::Method::Accessor;
  
      my $reader = Class::MOP::Method::Accessor->new(
          attribute     => $attribute,
          is_inline     => 1,
          accessor_type => 'reader',
      );
  
      $reader->body->execute($instance); # call the reader method
  
  =head1 DESCRIPTION
  
  This is a subclass of C<Class::MOP::Method> which is used by
  C<Class::MOP::Attribute> to generate accessor code. It handles
  generation of readers, writers, predicates and clearers. For each type
  of method, it can either create a subroutine reference, or actually
  inline code by generating a string and C<eval>'ing it.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Method::Accessor->new(%options) >>
  
  This returns a new C<Class::MOP::Method::Accessor> based on the
  C<%options> provided.
  
  =over 4
  
  =item * attribute
  
  This is the C<Class::MOP::Attribute> for which accessors are being
  generated. This option is required.
  
  =item * accessor_type
  
  This is a string which should be one of "reader", "writer",
  "accessor", "predicate", or "clearer". This is the type of method
  being generated. This option is required.
  
  =item * is_inline
  
  This indicates whether or not the accessor should be inlined. This
  defaults to false.
  
  =item * name
  
  The method name (without a package name). This is required.
  
  =item * package_name
  
  The package name for the method. This is required.
  
  =back
  
  =item B<< $metamethod->accessor_type >>
  
  Returns the accessor type which was passed to C<new>.
  
  =item B<< $metamethod->is_inline >>
  
  Returns a boolean indicating whether or not the accessor is inlined.
  
  =item B<< $metamethod->associated_attribute >>
  
  This returns the L<Class::MOP::Attribute> object which was passed to
  C<new>.
  
  =item B<< $metamethod->body >>
  
  The method itself is I<generated> when the accessor object is
  constructed.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_ACCESSOR

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Constructor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_CONSTRUCTOR';
  
  package Class::MOP::Method::Constructor;
  BEGIN {
    $Class::MOP::Method::Constructor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Constructor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed', 'weaken';
  use Try::Tiny;
  
  use base 'Class::MOP::Method::Inlined';
  
  sub new {
      my $class   = shift;
      my %options = @_;
  
      (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
          || confess "You must pass a metaclass instance if you want to inline"
              if $options{is_inline};
  
      ($options{package_name} && $options{name})
          || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  
      my $self = $class->_new(\%options);
  
      # we don't want this creating
      # a cycle in the code, if not
      # needed
      weaken($self->{'associated_metaclass'});
  
      $self->_initialize_body;
  
      return $self;
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          # inherited from Class::MOP::Method
          body                 => $params->{body},
          # associated_metaclass => $params->{associated_metaclass}, # overriden
          package_name         => $params->{package_name},
          name                 => $params->{name},
          original_method      => $params->{original_method},
  
          # inherited from Class::MOP::Generated
          is_inline            => $params->{is_inline} || 0,
          definition_context   => $params->{definition_context},
  
          # inherited from Class::MOP::Inlined
          _expected_method_class => $params->{_expected_method_class},
  
          # defined in this subclass
          options              => $params->{options} || {},
          associated_metaclass => $params->{metaclass},
      }, $class;
  }
  
  ## accessors
  
  sub options              { (shift)->{'options'}              }
  sub associated_metaclass { (shift)->{'associated_metaclass'} }
  
  ## method
  
  sub _initialize_body {
      my $self        = shift;
      my $method_name = '_generate_constructor_method';
  
      $method_name .= '_inline' if $self->is_inline;
  
      $self->{'body'} = $self->$method_name;
  }
  
  sub _eval_environment {
      my $self = shift;
      return $self->associated_metaclass->_eval_environment;
  }
  
  sub _generate_constructor_method {
      return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
  }
  
  sub _generate_constructor_method_inline {
      my $self = shift;
  
      my $meta = $self->associated_metaclass;
  
      my @source = (
          'sub {',
              $meta->_inline_new_object,
          '}',
      );
  
      warn join("\n", @source) if $self->options->{debug};
  
      my $code = try {
          $self->_compile_code(\@source);
      }
      catch {
          my $source = join("\n", @source);
          confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_";
      };
  
      return $code;
  }
  
  1;
  
  # ABSTRACT: Method Meta Object for constructors
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Constructor - Method Meta Object for constructors
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    use Class::MOP::Method::Constructor;
  
    my $constructor = Class::MOP::Method::Constructor->new(
        metaclass => $metaclass,
        options   => {
            debug => 1, # this is all for now
        },
    );
  
    # calling the constructor ...
    $constructor->body->execute($metaclass->name, %params);
  
  =head1 DESCRIPTION
  
  This is a subclass of C<Class::MOP::Method> which generates
  constructor methods.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Method::Constructor->new(%options) >>
  
  This creates a new constructor object. It accepts a hash reference of
  options.
  
  =over 8
  
  =item * metaclass
  
  This should be a L<Class::MOP::Class> object. It is required.
  
  =item * name
  
  The method name (without a package name). This is required.
  
  =item * package_name
  
  The package name for the method. This is required.
  
  =item * is_inline
  
  This indicates whether or not the constructor should be inlined. This
  defaults to false.
  
  =back
  
  =item B<< $metamethod->is_inline >>
  
  Returns a boolean indicating whether or not the constructor is
  inlined.
  
  =item B<< $metamethod->associated_metaclass >>
  
  This returns the L<Class::MOP::Class> object for the method.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_CONSTRUCTOR

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Generated.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_GENERATED';
  
  package Class::MOP::Method::Generated;
  BEGIN {
    $Class::MOP::Method::Generated::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Generated::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp 'confess';
  use Eval::Closure;
  
  use base 'Class::MOP::Method';
  
  ## accessors
  
  sub new {
      confess __PACKAGE__ . " is an abstract base class, you must provide a constructor.";
  }
  
  sub _initialize_body {
      confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class";
  }
  
  sub _generate_description {
      my ( $self, $context ) = @_;
      $context ||= $self->definition_context;
  
      my $desc = "generated method";
      my $origin = "unknown origin";
  
      if (defined $context) {
          if (defined $context->{description}) {
              $desc = $context->{description};
          }
  
          if (defined $context->{file} || defined $context->{line}) {
              $origin = "defined at "
                      . (defined $context->{file}
                          ? $context->{file} : "<unknown file>")
                      . " line "
                      . (defined $context->{line}
                          ? $context->{line} : "<unknown line>");
          }
      }
  
      return "$desc ($origin)";
  }
  
  sub _compile_code {
      my ( $self, @args ) = @_;
      unshift @args, 'source' if @args % 2;
      my %args = @args;
  
      my $context = delete $args{context};
      my $environment = $self->can('_eval_environment')
          ? $self->_eval_environment
          : {};
  
      return eval_closure(
          environment => $environment,
          description => $self->_generate_description($context),
          %args,
      );
  }
  
  1;
  
  # ABSTRACT: Abstract base class for generated methods
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Generated - Abstract base class for generated methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a C<Class::MOP::Method> subclass which is subclassed by
  C<Class::MOP::Method::Accessor> and
  C<Class::MOP::Method::Constructor>.
  
  It is not intended to be used directly.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_GENERATED

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Inlined.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_INLINED';
  package Class::MOP::Method::Inlined;
  BEGIN {
    $Class::MOP::Method::Inlined::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Inlined::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
  
  use base 'Class::MOP::Method::Generated';
  
  sub _uninlined_body {
      my $self = shift;
  
      my $super_method
          = $self->associated_metaclass->find_next_method_by_name( $self->name )
          or return;
  
      if ( $super_method->isa(__PACKAGE__) ) {
          return $super_method->_uninlined_body;
      }
      else {
          return $super_method->body;
      }
  }
  
  sub can_be_inlined {
      my $self      = shift;
      my $metaclass = $self->associated_metaclass;
      my $class     = $metaclass->name;
  
      # If we don't find an inherited method, this is a rather weird
      # case where we have no method in the inheritance chain even
      # though we're expecting one to be there
      my $inherited_method
          = $metaclass->find_next_method_by_name( $self->name );
  
      if (   $inherited_method
          && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
          warn "Not inlining '"
              . $self->name
              . "' for $class since it "
              . "has method modifiers which would be lost if it were inlined\n";
  
          return 0;
      }
  
      my $expected_class = $self->_expected_method_class
          or return 1;
  
      # if we are shadowing a method we first verify that it is
      # compatible with the definition we are replacing it with
      my $expected_method = $expected_class->can( $self->name );
  
      if ( ! $expected_method ) {
          warn "Not inlining '"
              . $self->name
              . "' for $class since ${expected_class}::"
              . $self->name
              . " is not defined\n";
  
          return 0;
      }
  
      my $actual_method = $class->can( $self->name )
          or return 1;
  
      # the method is what we wanted (probably Moose::Object::new)
      return 1
          if refaddr($expected_method) == refaddr($actual_method);
  
      # otherwise we have to check that the actual method is an inlined
      # version of what we're expecting
      if ( $inherited_method->isa(__PACKAGE__) ) {
          if ( $inherited_method->_uninlined_body
               && refaddr( $inherited_method->_uninlined_body )
               == refaddr($expected_method) ) {
              return 1;
          }
      }
      elsif ( refaddr( $inherited_method->body )
              == refaddr($expected_method) ) {
          return 1;
      }
  
      my $warning
          = "Not inlining '"
          . $self->name
          . "' for $class since it is not"
          . " inheriting the default ${expected_class}::"
          . $self->name . "\n";
  
      if ( $self->isa("Class::MOP::Method::Constructor") ) {
  
          # FIXME kludge, refactor warning generation to a method
          $warning
              .= "If you are certain you don't need to inline your"
              . " constructor, specify inline_constructor => 0 in your"
              . " call to $class->meta->make_immutable\n";
      }
  
      warn $warning;
  
      return 0;
  }
  
  1;
  
  # ABSTRACT: Method base class for methods which have been inlined
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Inlined - Method base class for methods which have been inlined
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a L<Class::MOP::Method::Generated> subclass for methods which
  can be inlined.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< $metamethod->can_be_inlined >>
  
  This method returns true if the method in question can be inlined in
  the associated metaclass.
  
  If it cannot be inlined, it spits out a warning and returns false.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_INLINED

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Meta.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_META';
  
  package Class::MOP::Method::Meta;
  BEGIN {
    $Class::MOP::Method::Meta::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Meta::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed';
  
  use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
  
  use base 'Class::MOP::Method';
  
  sub _is_caller_mop_internal {
      my $self = shift;
      my ($caller) = @_;
      return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/;
  }
  
  sub _generate_meta_method {
      my $method_self = shift;
      my $metaclass   = shift;
      sub {
          # this will be compiled out if the env var wasn't set
          if (DEBUG_NO_META) {
              confess "'meta' method called by MOP internals"
                  # it's okay to call meta methods on metaclasses, since we
                  # explicitly ask for them
                  if !$_[0]->isa('Class::MOP::Object')
                  && !$_[0]->isa('Class::MOP::Mixin')
                  # it's okay if the test itself calls ->meta, we only care about
                  # if the mop internals call ->meta
                  && $method_self->_is_caller_mop_internal(scalar caller);
          }
          # we must re-initialize so that it
          # works as expected in subclasses,
          # since metaclass instances are
          # singletons, this is not really a
          # big deal anyway.
          $metaclass->initialize(blessed($_[0]) || $_[0])
      };
  }
  
  sub wrap {
      my ($class, @args) = @_;
  
      unshift @args, 'body' if @args % 2 == 1;
      my %params = @args;
      confess "Overriding the body of meta methods is not allowed"
          if $params{body};
  
      my $metaclass_class = $params{associated_metaclass}->meta;
      $params{body} = $class->_generate_meta_method($metaclass_class);
      return $class->SUPER::wrap(%params);
  }
  
  sub _make_compatible_with {
      my $self = shift;
      my ($other) = @_;
  
      # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta
      # objects are subclasses of CMOP::Method, but when we get to moose, they'll
      # need to be compatible with Moose::Meta::Method, which isn't possible. the
      # right solution here is to make ::Meta into a role that gets applied to
      # whatever the method_metaclass happens to be and get rid of
      # _meta_method_metaclass entirely, but that's not going to happen until
      # we ditch cmop and get roles into the bootstrapping, so. i'm not
      # maintaining the previous behavior of turning them into instances of the
      # new method_metaclass because that's equally broken, and at least this way
      # any issues will at least be detectable and potentially fixable. -doy
      return $self unless $other->_is_compatible_with($self->_real_ref_name);
  
      return $self->SUPER::_make_compatible_with(@_);
  }
  
  1;
  
  # ABSTRACT: Method Meta Object for C<meta> methods
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Meta - Method Meta Object for C<meta> methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a L<Class::MOP::Method> subclass which represents C<meta>
  methods installed into classes by Class::MOP.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
  
  This is the constructor. It accepts a L<Class::MOP::Method> object and
  a hash of options. The options accepted are identical to the ones
  accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
  (it will be generated automatically).
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_META

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Method/Wrapped.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_WRAPPED';
  
  package Class::MOP::Method::Wrapped;
  BEGIN {
    $Class::MOP::Method::Wrapped::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Method::Wrapped::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed';
  
  use base 'Class::MOP::Method';
  
  # NOTE:
  # this ugly beast is the result of trying
  # to micro optimize this as much as possible
  # while not completely loosing maintainability.
  # At this point it's "fast enough", after all
  # you can't get something for nothing :)
  my $_build_wrapped_method = sub {
      my $modifier_table = shift;
      my ($before, $after, $around) = (
          $modifier_table->{before},
          $modifier_table->{after},
          $modifier_table->{around},
      );
      if (@$before && @$after) {
          $modifier_table->{cache} = sub {
              for my $c (@$before) { $c->(@_) };
              my @rval;
              ((defined wantarray) ?
                  ((wantarray) ?
                      (@rval = $around->{cache}->(@_))
                      :
                      ($rval[0] = $around->{cache}->(@_)))
                  :
                  $around->{cache}->(@_));
              for my $c (@$after) { $c->(@_) };
              return unless defined wantarray;
              return wantarray ? @rval : $rval[0];
          }
      }
      elsif (@$before && !@$after) {
          $modifier_table->{cache} = sub {
              for my $c (@$before) { $c->(@_) };
              return $around->{cache}->(@_);
          }
      }
      elsif (@$after && !@$before) {
          $modifier_table->{cache} = sub {
              my @rval;
              ((defined wantarray) ?
                  ((wantarray) ?
                      (@rval = $around->{cache}->(@_))
                      :
                      ($rval[0] = $around->{cache}->(@_)))
                  :
                  $around->{cache}->(@_));
              for my $c (@$after) { $c->(@_) };
              return unless defined wantarray;
              return wantarray ? @rval : $rval[0];
          }
      }
      else {
          $modifier_table->{cache} = $around->{cache};
      }
  };
  
  sub wrap {
      my ( $class, $code, %params ) = @_;
  
      (blessed($code) && $code->isa('Class::MOP::Method'))
          || confess "Can only wrap blessed CODE";
  
      my $modifier_table = {
          cache  => undef,
          orig   => $code->body,
          before => [],
          after  => [],
          around => {
              cache   => $code->body,
              methods => [],
          },
      };
      $_build_wrapped_method->($modifier_table);
      return $class->SUPER::wrap(
          sub { $modifier_table->{cache}->(@_) },
          # get these from the original
          # unless explicitly overriden
          package_name   => $params{package_name} || $code->package_name,
          name           => $params{name}         || $code->name,
          original_method => $code,
  
          modifier_table => $modifier_table,
      );
  }
  
  sub _new {
      my $class = shift;
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          # inherited from Class::MOP::Method
          'body'                 => $params->{body},
          'associated_metaclass' => $params->{associated_metaclass},
          'package_name'         => $params->{package_name},
          'name'                 => $params->{name},
          'original_method'      => $params->{original_method},
  
          # defined in this class
          'modifier_table'       => $params->{modifier_table}
      } => $class;
  }
  
  sub get_original_method {
      my $code = shift;
      $code->original_method;
  }
  
  sub add_before_modifier {
      my $code     = shift;
      my $modifier = shift;
      unshift @{$code->{'modifier_table'}->{before}} => $modifier;
      $_build_wrapped_method->($code->{'modifier_table'});
  }
  
  sub before_modifiers {
      my $code = shift;
      return @{$code->{'modifier_table'}->{before}};
  }
  
  sub add_after_modifier {
      my $code     = shift;
      my $modifier = shift;
      push @{$code->{'modifier_table'}->{after}} => $modifier;
      $_build_wrapped_method->($code->{'modifier_table'});
  }
  
  sub after_modifiers {
      my $code = shift;
      return @{$code->{'modifier_table'}->{after}};
  }
  
  {
      # NOTE:
      # this is another possible candidate for
      # optimization as well. There is an overhead
      # associated with the currying that, if
      # eliminated might make around modifiers
      # more manageable.
      my $compile_around_method = sub {{
          my $f1 = pop;
          return $f1 unless @_;
          my $f2 = pop;
          push @_, sub { $f2->( $f1, @_ ) };
          redo;
      }};
  
      sub add_around_modifier {
          my $code     = shift;
          my $modifier = shift;
          unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
          $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
              @{$code->{'modifier_table'}->{around}->{methods}},
              $code->{'modifier_table'}->{orig}
          );
          $_build_wrapped_method->($code->{'modifier_table'});
      }
  }
  
  sub around_modifiers {
      my $code = shift;
      return @{$code->{'modifier_table'}->{around}->{methods}};
  }
  
  sub _make_compatible_with {
      my $self = shift;
      my ($other) = @_;
  
      # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
      # objects are subclasses of CMOP::Method, but when we get to moose, they'll
      # need to be compatible with Moose::Meta::Method, which isn't possible. the
      # right solution here is to make ::Wrapped into a role that gets applied to
      # whatever the method_metaclass happens to be and get rid of
      # wrapped_method_metaclass entirely, but that's not going to happen until
      # we ditch cmop and get roles into the bootstrapping, so. i'm not
      # maintaining the previous behavior of turning them into instances of the
      # new method_metaclass because that's equally broken, and at least this way
      # any issues will at least be detectable and potentially fixable. -doy
      return $self unless $other->_is_compatible_with($self->_real_ref_name);
  
      return $self->SUPER::_make_compatible_with(@_);
  }
  
  1;
  
  # ABSTRACT: Method Meta Object for methods with before/after/around modifiers
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a L<Class::MOP::Method> subclass which implements before,
  after, and around method modifiers.
  
  =head1 METHODS
  
  =head2 Construction
  
  =over 4
  
  =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
  
  This is the constructor. It accepts a L<Class::MOP::Method> object and
  a hash of options.
  
  The options are:
  
  =over 8
  
  =item * name
  
  The method name (without a package name). This will be taken from the
  provided L<Class::MOP::Method> object if it is not provided.
  
  =item * package_name
  
  The package name for the method. This will be taken from the provided
  L<Class::MOP::Method> object if it is not provided.
  
  =item * associated_metaclass
  
  An optional L<Class::MOP::Class> object. This is the metaclass for the
  method's class.
  
  =back
  
  =item B<< $metamethod->get_original_method >>
  
  This returns the L<Class::MOP::Method> object that was passed to the
  constructor.
  
  =item B<< $metamethod->add_before_modifier($code) >>
  
  =item B<< $metamethod->add_after_modifier($code) >>
  
  =item B<< $metamethod->add_around_modifier($code) >>
  
  These methods all take a subroutine reference and apply it as a
  modifier to the original method.
  
  =item B<< $metamethod->before_modifiers >>
  
  =item B<< $metamethod->after_modifiers >>
  
  =item B<< $metamethod->around_modifiers >>
  
  These methods all return a list of subroutine references which are
  acting as the specified type of modifier.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_METHOD_WRAPPED

$fatpacked{"darwin-thread-multi-2level/Class/MOP/MiniTrait.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MINITRAIT';
  package Class::MOP::MiniTrait;
  BEGIN {
    $Class::MOP::MiniTrait::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::MiniTrait::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw(load_class);
  
  sub apply {
      my ( $to_class, $trait ) = @_;
  
      for ( grep { !ref } $to_class, $trait ) {
          load_class($_);
          $_ = Class::MOP::Class->initialize($_);
      }
  
      for my $meth ( grep { $_->package_name ne 'UNIVERSAL' } $trait->get_all_methods ) {
          my $meth_name = $meth->name;
  
          if ( $to_class->find_method_by_name($meth_name) ) {
              $to_class->add_around_method_modifier( $meth_name, $meth->body );
          }
          else {
              $to_class->add_method( $meth_name, $meth->clone );
          }
      }
  }
  
  # We can't load this with use, since it may be loaded and used from Class::MOP
  # (via CMOP::Class, etc). However, if for some reason this module is loaded
  # _without_ first loading Class::MOP we need to require Class::MOP so we can
  # use it and CMOP::Class.
  require Class::MOP;
  
  1;
  
  # ABSTRACT: Extremely limited trait application
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::MiniTrait - Extremely limited trait application
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This package provides a single function, C<apply>, which does a half-assed job
  of applying a trait to a class. It exists solely for use inside Class::MOP and
  L<Moose> core classes.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MINITRAIT

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Mixin.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN';
  package Class::MOP::Mixin;
  BEGIN {
    $Class::MOP::Mixin::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Mixin::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util 'blessed';
  
  sub meta {
      require Class::MOP::Class;
      Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] );
  }
  
  1;
  
  # ABSTRACT: Base class for mixin classes
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Mixin - Base class for mixin classes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class provides a single method shared by all mixins
  
  =head1 METHODS
  
  This class provides a few methods which are useful in all metaclasses.
  
  =over 4
  
  =item B<< Class::MOP::Mixin->meta >>
  
  This returns a L<Class::MOP::Class> object for the mixin class.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Mixin/AttributeCore.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_ATTRIBUTECORE';
  package Class::MOP::Mixin::AttributeCore;
  BEGIN {
    $Class::MOP::Mixin::AttributeCore::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Mixin::AttributeCore::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util 'blessed';
  
  use base 'Class::MOP::Mixin';
  
  sub has_accessor        { defined $_[0]->{'accessor'} }
  sub has_reader          { defined $_[0]->{'reader'} }
  sub has_writer          { defined $_[0]->{'writer'} }
  sub has_predicate       { defined $_[0]->{'predicate'} }
  sub has_clearer         { defined $_[0]->{'clearer'} }
  sub has_builder         { defined $_[0]->{'builder'} }
  sub has_init_arg        { defined $_[0]->{'init_arg'} }
  sub has_default         { exists  $_[0]->{'default'} }
  sub has_initializer     { defined $_[0]->{'initializer'} }
  sub has_insertion_order { defined $_[0]->{'insertion_order'} }
  
  sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
  
  sub has_read_method  { $_[0]->has_reader || $_[0]->has_accessor }
  sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
  
  sub is_default_a_coderef {
      # Uber hack because it is called from CMOP::Attribute constructor as
      # $class->is_default_a_coderef(\%options)
      my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'};
  
      return unless ref($value);
  
      return ref($value) eq 'CODE'
          || ( blessed($value) && $value->isa('Class::MOP::Method') );
  }
  
  sub default {
      my ( $self, $instance ) = @_;
      if ( defined $instance && $self->is_default_a_coderef ) {
          # if the default is a CODE ref, then we pass in the instance and
          # default can return a value based on that instance. Somewhat crude,
          # but works.
          return $self->{'default'}->($instance);
      }
      $self->{'default'};
  }
  
  1;
  
  # ABSTRACT: Core attributes shared by attribute metaclasses
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements the core attributes (aka properties) shared by all
  attributes. See the L<Class::MOP::Attribute> documentation for API details.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_ATTRIBUTECORE

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Mixin/HasAttributes.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_HASATTRIBUTES';
  package Class::MOP::Mixin::HasAttributes;
  BEGIN {
    $Class::MOP::Mixin::HasAttributes::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Mixin::HasAttributes::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed';
  
  use base 'Class::MOP::Mixin';
  
  sub add_attribute {
      my $self = shift;
  
      my $attribute
          = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
  
      ( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
          || confess
          "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
  
      $self->_attach_attribute($attribute);
  
      my $attr_name = $attribute->name;
  
      $self->remove_attribute($attr_name)
          if $self->has_attribute($attr_name);
  
      my $order = ( scalar keys %{ $self->_attribute_map } );
      $attribute->_set_insertion_order($order);
  
      $self->_attribute_map->{$attr_name} = $attribute;
  
      # This method is called to allow for installing accessors. Ideally, we'd
      # use method overriding, but then the subclass would be responsible for
      # making the attribute, which would end up with lots of code
      # duplication. Even more ideally, we'd use augment/inner, but this is
      # Class::MOP!
      $self->_post_add_attribute($attribute)
          if $self->can('_post_add_attribute');
  
      return $attribute;
  }
  
  sub has_attribute {
      my ( $self, $attribute_name ) = @_;
  
      ( defined $attribute_name )
          || confess "You must define an attribute name";
  
      exists $self->_attribute_map->{$attribute_name};
  }
  
  sub get_attribute {
      my ( $self, $attribute_name ) = @_;
  
      ( defined $attribute_name )
          || confess "You must define an attribute name";
  
      return $self->_attribute_map->{$attribute_name};
  }
  
  sub remove_attribute {
      my ( $self, $attribute_name ) = @_;
  
      ( defined $attribute_name )
          || confess "You must define an attribute name";
  
      my $removed_attribute = $self->_attribute_map->{$attribute_name};
      return unless defined $removed_attribute;
  
      delete $self->_attribute_map->{$attribute_name};
  
      return $removed_attribute;
  }
  
  sub get_attribute_list {
      my $self = shift;
      keys %{ $self->_attribute_map };
  }
  
  sub _restore_metaattributes_from {
      my $self = shift;
      my ($old_meta) = @_;
  
      for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
                         map { $old_meta->get_attribute($_) }
                             $old_meta->get_attribute_list) {
          $attr->_make_compatible_with($self->attribute_metaclass);
          $self->add_attribute($attr);
      }
  }
  
  1;
  
  # ABSTRACT: Methods for metaclasses which have attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Mixin::HasAttributes - Methods for metaclasses which have attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements methods for metaclasses which have attributes
  (L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
  API details.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_HASATTRIBUTES

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Mixin/HasMethods.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_HASMETHODS';
  package Class::MOP::Mixin::HasMethods;
  BEGIN {
    $Class::MOP::Mixin::HasMethods::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Mixin::HasMethods::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::Method::Meta;
  
  use Scalar::Util 'blessed';
  use Carp         'confess';
  use Sub::Name    'subname';
  
  use base 'Class::MOP::Mixin';
  
  sub _meta_method_class { 'Class::MOP::Method::Meta' }
  
  sub _add_meta_method {
      my $self = shift;
      my ($name) = @_;
      my $existing_method = $self->can('find_method_by_name')
                                ? $self->find_method_by_name($name)
                                : $self->get_method($name);
      return if $existing_method
             && $existing_method->isa($self->_meta_method_class);
      $self->add_method(
          $name => $self->_meta_method_class->wrap(
              name                 => $name,
              package_name         => $self->name,
              associated_metaclass => $self,
          )
      );
  }
  
  sub wrap_method_body {
      my ( $self, %args ) = @_;
  
      ( 'CODE' eq ref $args{body} )
          || confess "Your code block must be a CODE reference";
  
      $self->method_metaclass->wrap(
          package_name => $self->name,
          %args,
      );
  }
  
  sub add_method {
      my ( $self, $method_name, $method ) = @_;
      ( defined $method_name && length $method_name )
          || confess "You must define a method name";
  
      my $package_name = $self->name;
  
      my $body;
      if ( blessed($method) ) {
          $body = $method->body;
          if ( $method->package_name ne $package_name ) {
              $method = $method->clone(
                  package_name => $package_name,
                  name         => $method_name,
              );
          }
  
          $method->attach_to_class($self);
      }
      else {
          # If a raw code reference is supplied, its method object is not created.
          # The method object won't be created until required.
          $body = $method;
      }
  
      $self->_method_map->{$method_name} = $method;
  
      my ($current_package, $current_name) = Class::MOP::get_code_info($body);
  
      subname($package_name . '::' . $method_name, $body)
          unless defined $current_name && $current_name !~ /^__ANON__/;
  
      $self->add_package_symbol("&$method_name", $body);
  
      # we added the method to the method map too, so it's still valid
      $self->update_package_cache_flag;
  }
  
  sub _code_is_mine {
      my ( $self, $code ) = @_;
  
      my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
  
      return ( $code_package && $code_package eq $self->name )
          || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
  }
  
  sub has_method {
      my ( $self, $method_name ) = @_;
  
      ( defined $method_name && length $method_name )
          || confess "You must define a method name";
  
      my $method = $self->_get_maybe_raw_method($method_name)
          or return;
  
      return defined($self->_method_map->{$method_name} = $method);
  }
  
  sub get_method {
      my ( $self, $method_name ) = @_;
  
      ( defined $method_name && length $method_name )
          || confess "You must define a method name";
  
      my $method = $self->_get_maybe_raw_method($method_name)
          or return;
  
      return $method if blessed $method;
  
      return $self->_method_map->{$method_name} = $self->wrap_method_body(
          body                 => $method,
          name                 => $method_name,
          associated_metaclass => $self,
      );
  }
  
  sub _get_maybe_raw_method {
      my ( $self, $method_name ) = @_;
  
      my $map_entry = $self->_method_map->{$method_name};
      return $map_entry if defined $map_entry;
  
      my $code = $self->get_package_symbol("&$method_name");
  
      return unless $code && $self->_code_is_mine($code);
  
      return $code;
  }
  
  sub remove_method {
      my ( $self, $method_name ) = @_;
  
      ( defined $method_name && length $method_name )
          || confess "You must define a method name";
  
      my $removed_method = delete $self->_method_map->{$method_name};
  
      $self->remove_package_symbol("&$method_name");
  
      $removed_method->detach_from_class
          if blessed($removed_method);
  
      # still valid, since we just removed the method from the map
      $self->update_package_cache_flag;
  
      return $removed_method;
  }
  
  sub get_method_list {
      my $self = shift;
  
      return keys %{ $self->_full_method_map };
  }
  
  sub _get_local_methods {
      my $self = shift;
  
      return values %{ $self->_full_method_map };
  }
  
  sub _restore_metamethods_from {
      my $self = shift;
      my ($old_meta) = @_;
  
      for my $method ($old_meta->_get_local_methods) {
          $method->_make_compatible_with($self->method_metaclass);
          $self->add_method($method->name => $method);
      }
  }
  
  sub reset_package_cache_flag  { (shift)->{'_package_cache_flag'} = undef }
  sub update_package_cache_flag {
      my $self = shift;
      # NOTE:
      # we can manually update the cache number
      # since we are actually adding the method
      # to our cache as well. This avoids us
      # having to regenerate the method_map.
      # - SL
      $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
  }
  
  sub _full_method_map {
      my $self = shift;
  
      my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
  
      if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
          # forcibly reify all method map entries
          $self->get_method($_)
              for $self->list_all_package_symbols('CODE');
          $self->{_package_cache_flag_full} = $pkg_gen;
      }
  
      return $self->_method_map;
  }
  
  1;
  
  # ABSTRACT: Methods for metaclasses which have methods
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements methods for metaclasses which have methods
  (L<Class::MOP::Package> and L<Moose::Meta::Role>). See L<Class::MOP::Package>
  for API details.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MIXIN_HASMETHODS

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Module.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MODULE';
  
  package Class::MOP::Module;
  BEGIN {
    $Class::MOP::Module::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Module::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed';
  
  use base 'Class::MOP::Package';
  
  sub _new {
      my $class = shift;
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
      return bless {
          # Need to quote package to avoid a problem with PPI mis-parsing this
          # as a package statement.
  
          # from Class::MOP::Package
          'package' => $params->{package},
          namespace => \undef,
  
          # attributes
          version   => \undef,
          authority => \undef
      } => $class;
  }
  
  sub version {
      my $self = shift;
      ${$self->get_or_add_package_symbol('$VERSION')};
  }
  
  sub authority {
      my $self = shift;
      ${$self->get_or_add_package_symbol('$AUTHORITY')};
  }
  
  sub identifier {
      my $self = shift;
      join '-' => (
          $self->name,
          ($self->version   || ()),
          ($self->authority || ()),
      );
  }
  
  sub create {
      my $class = shift;
      my @args = @_;
  
      unshift @args, 'package' if @args % 2 == 1;
      my %options = @args;
  
      my $package   = delete $options{package};
      my $version   = delete $options{version};
      my $authority = delete $options{authority};
  
      my $meta = $class->SUPER::create($package => %options);
  
      $meta->_instantiate_module($version, $authority);
  
      return $meta;
  }
  
  sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' }
  sub _anon_cache_key      { confess "Modules are not cacheable" }
  
  
  sub _instantiate_module {
      my($self, $version, $authority) = @_;
      my $package_name = $self->name;
  
      $self->add_package_symbol('$VERSION' => $version)
          if defined $version;
      $self->add_package_symbol('$AUTHORITY' => $authority)
          if defined $authority;
  
      return;
  }
  
  1;
  
  # ABSTRACT: Module Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Module - Module Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  A module is essentially a L<Class::MOP::Package> with metadata, in our
  case the version and authority.
  
  =head1 INHERITANCE
  
  B<Class::MOP::Module> is a subclass of L<Class::MOP::Package>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Module->create($package, %options) >>
  
  Overrides C<create> from L<Class::MOP::Package> to provide these additional
  options:
  
  =over 4
  
  =item C<version>
  
  A version number, to be installed in the C<$VERSION> package global variable.
  
  =item C<authority>
  
  An authority, to be installed in the C<$AUTHORITY> package global variable.
  
  =back
  
  =item B<< $metamodule->version >>
  
  This is a read-only attribute which returns the C<$VERSION> of the
  package, if one exists.
  
  =item B<< $metamodule->authority >>
  
  This is a read-only attribute which returns the C<$AUTHORITY> of the
  package, if one exists.
  
  =item B<< $metamodule->identifier >>
  
  This constructs a string which combines the name, version and
  authority.
  
  =item B<< Class::MOP::Module->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_MODULE

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Object.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_OBJECT';
  
  package Class::MOP::Object;
  BEGIN {
    $Class::MOP::Object::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Object::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp qw(confess);
  use Scalar::Util 'blessed';
  
  # introspection
  
  sub meta {
      require Class::MOP::Class;
      Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  }
  
  sub _new {
      Class::MOP::class_of(shift)->new_object(@_);
  }
  
  # RANT:
  # Cmon, how many times have you written
  # the following code while debugging:
  #
  #  use Data::Dumper;
  #  warn Dumper $obj;
  #
  # It can get seriously annoying, so why
  # not just do this ...
  sub dump {
      my $self = shift;
      require Data::Dumper;
      local $Data::Dumper::Maxdepth = shift || 1;
      Data::Dumper::Dumper $self;
  }
  
  sub _real_ref_name {
      my $self = shift;
      return blessed($self);
  }
  
  sub _is_compatible_with {
      my $self = shift;
      my ($other_name) = @_;
  
      return $self->isa($other_name);
  }
  
  sub _can_be_made_compatible_with {
      my $self = shift;
      return !$self->_is_compatible_with(@_)
          && defined($self->_get_compatible_metaclass(@_));
  }
  
  sub _make_compatible_with {
      my $self = shift;
      my ($other_name) = @_;
  
      my $new_metaclass = $self->_get_compatible_metaclass($other_name);
  
      confess "Can't make $self compatible with metaclass $other_name"
          unless defined $new_metaclass;
  
      # can't use rebless_instance here, because it might not be an actual
      # subclass in the case of, e.g. moose role reconciliation
      $new_metaclass->meta->_force_rebless_instance($self)
          if blessed($self) ne $new_metaclass;
  
      return $self;
  }
  
  sub _get_compatible_metaclass {
      my $self = shift;
      my ($other_name) = @_;
  
      return $self->_get_compatible_metaclass_by_subclassing($other_name);
  }
  
  sub _get_compatible_metaclass_by_subclassing {
      my $self = shift;
      my ($other_name) = @_;
      my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
  
      if ($meta_name->isa($other_name)) {
          return $meta_name;
      }
      elsif ($other_name->isa($meta_name)) {
          return $other_name;
      }
  
      return;
  }
  
  1;
  
  # ABSTRACT: Base class for metaclasses
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Object - Base class for metaclasses
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a very minimal base class for metaclasses.
  
  =head1 METHODS
  
  This class provides a few methods which are useful in all metaclasses.
  
  =over 4
  
  =item B<< Class::MOP::???->meta >>
  
  This returns a L<Class::MOP::Class> object.
  
  =item B<< $metaobject->dump($max_depth) >>
  
  This method uses L<Data::Dumper> to dump the object. You can pass an
  optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The
  default maximum depth is 1.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_OBJECT

$fatpacked{"darwin-thread-multi-2level/Class/MOP/Package.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_PACKAGE';
  
  package Class::MOP::Package;
  BEGIN {
    $Class::MOP::Package::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Class::MOP::Package::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util 'blessed', 'reftype', 'weaken';
  use Carp         'confess';
  use Devel::GlobalDestruction 'in_global_destruction';
  use Package::Stash;
  
  use base 'Class::MOP::Object';
  
  # creation ...
  
  sub initialize {
      my ( $class, @args ) = @_;
  
      unshift @args, "package" if @args % 2;
  
      my %options = @args;
      my $package_name = delete $options{package};
  
  
      # we hand-construct the class until we can bootstrap it
      if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
          return $meta;
      } else {
          my $meta = ( ref $class || $class )->_new({
              'package'   => $package_name,
              %options,
          });
          Class::MOP::store_metaclass_by_name($package_name, $meta);
  
          Class::MOP::weaken_metaclass($package_name) if $options{weaken};
  
  
          return $meta;
      }
  }
  
  sub reinitialize {
      my ( $class, @args ) = @_;
  
      unshift @args, "package" if @args % 2;
  
      my %options = @args;
      my $package_name = delete $options{package};
  
      (defined $package_name && $package_name
        && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
          || confess "You must pass a package name or an existing Class::MOP::Package instance";
  
      $package_name = $package_name->name
          if blessed $package_name;
  
      Class::MOP::remove_metaclass_by_name($package_name);
  
      $class->initialize($package_name, %options); # call with first arg form for compat
  }
  
  sub create {
      my $class = shift;
      my @args = @_;
  
      return $class->initialize(@args);
  }
  
  ## ANON packages
  
  {
      # NOTE:
      # this should be sufficient, if you have a
      # use case where it is not, write a test and
      # I will change it.
      my $ANON_SERIAL = 0;
  
      my %ANON_PACKAGE_CACHE;
  
      # NOTE:
      # we need a sufficiently annoying prefix
      # this should suffice for now, this is
      # used in a couple of places below, so
      # need to put it up here for now.
      sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
  
      sub is_anon {
          my $self = shift;
          no warnings 'uninitialized';
          my $prefix = $self->_anon_package_prefix;
          $self->name =~ /^\Q$prefix/;
      }
  
      sub create_anon {
          my ($class, %options) = @_;
  
          my $cache_ok = delete $options{cache};
          $options{weaken} = !$cache_ok unless exists $options{weaken};
  
          my $cache_key;
          if ($cache_ok) {
              $cache_key = $class->_anon_cache_key(%options);
              undef $cache_ok if !defined($cache_key);
          }
  
          if ($cache_ok) {
              if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
                  return $ANON_PACKAGE_CACHE{$cache_key};
              }
          }
  
          my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
  
          my $meta = $class->create($package_name, %options);
  
          if ($cache_ok) {
              $ANON_PACKAGE_CACHE{$cache_key} = $meta;
              weaken($ANON_PACKAGE_CACHE{$cache_key});
          }
  
          return $meta;
      }
  
      sub _anon_cache_key { confess "Packages are not cacheable" }
  
      sub DESTROY {
          my $self = shift;
  
          return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
  
          $self->_free_anon
              if $self->is_anon;
      }
  
      sub _free_anon {
          my $self = shift;
          my $name = $self->name;
  
          # Moose does a weird thing where it replaces the metaclass for
          # class when fixing metaclass incompatibility. In that case,
          # we don't want to clean out the namespace now. We can detect
          # that because Moose will explicitly update the singleton
          # cache in Class::MOP using store_metaclass_by_name, which
          # means that the new metaclass will already exist in the cache
          # by this point.
          # The other options here are that $current_meta can be undef if
          # remove_metaclass_by_name is called explicitly (since the hash
          # entry is removed first, and then this destructor is called),
          # or that $current_meta can be the same as $self, which happens
          # when the metaclass goes out of scope (since the weak reference
          # in the metaclass cache won't be freed until after this
          # destructor runs).
          my $current_meta = Class::MOP::get_metaclass_by_name($name);
          return if defined($current_meta) && $current_meta ne $self;
  
          my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
  
          no strict 'refs';
          @{$name . '::ISA'} = ();
          %{$name . '::'}    = ();
          delete ${$first_fragments . '::'}{$last_fragment . '::'};
  
          Class::MOP::remove_metaclass_by_name($name);
      }
  
  }
  
  sub _new {
      my $class = shift;
  
      return Class::MOP::Class->initialize($class)->new_object(@_)
          if $class ne __PACKAGE__;
  
      my $params = @_ == 1 ? $_[0] : {@_};
  
      return bless {
          # Need to quote package to avoid a problem with PPI mis-parsing this
          # as a package statement.
          'package' => $params->{package},
  
          # NOTE:
          # because of issues with the Perl API
          # to the typeglob in some versions, we
          # need to just always grab a new
          # reference to the hash in the accessor.
          # Ideally we could just store a ref and
          # it would Just Work, but oh well :\
  
          namespace => \undef,
  
      } => $class;
  }
  
  # Attributes
  
  # NOTE:
  # all these attribute readers will be bootstrapped
  # away in the Class::MOP bootstrap section
  
  sub _package_stash {
      $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
  }
  sub namespace {
      $_[0]->_package_stash->namespace
  }
  
  # Class attributes
  
  # ... these functions have to touch the symbol table itself,.. yuk
  
  sub add_package_symbol {
      my $self = shift;
      $self->_package_stash->add_symbol(@_);
  }
  
  sub remove_package_glob {
      my $self = shift;
      $self->_package_stash->remove_glob(@_);
  }
  
  # ... these functions deal with stuff on the namespace level
  
  sub has_package_symbol {
      my $self = shift;
      $self->_package_stash->has_symbol(@_);
  }
  
  sub get_package_symbol {
      my $self = shift;
      $self->_package_stash->get_symbol(@_);
  }
  
  sub get_or_add_package_symbol {
      my $self = shift;
      $self->_package_stash->get_or_add_symbol(@_);
  }
  
  sub remove_package_symbol {
      my $self = shift;
      $self->_package_stash->remove_symbol(@_);
  }
  
  sub list_all_package_symbols {
      my $self = shift;
      $self->_package_stash->list_all_symbols(@_);
  }
  
  sub get_all_package_symbols {
      my $self = shift;
      $self->_package_stash->get_all_symbols(@_);
  }
  
  1;
  
  # ABSTRACT: Package Meta Object
  
  
  
  =pod
  
  =head1 NAME
  
  Class::MOP::Package - Package Meta Object
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  The Package Protocol provides an abstraction of a Perl 5 package. A
  package is basically namespace, and this module provides methods for
  looking at and changing that namespace's symbol table.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Class::MOP::Package->initialize($package_name, %options) >>
  
  This method creates a new C<Class::MOP::Package> instance which
  represents specified package. If an existing metaclass object exists
  for the package, that will be returned instead. No options are valid at the
  package level.
  
  =item B<< Class::MOP::Package->reinitialize($package, %options) >>
  
  This method forcibly removes any existing metaclass for the package
  before calling C<initialize>. In contrast to C<initialize>, you may
  also pass an existing C<Class::MOP::Package> instance instead of just
  a package name as C<$package>.
  
  Do not call this unless you know what you are doing.
  
  =item B<< Class::MOP::Package->create($package, %options) >>
  
  Creates a new C<Class::MOP::Package> instance which represents the specified
  package, and also does some initialization of that package. Currently, this
  just does the same thing as C<initialize>, but is overridden in subclasses,
  such as C<Class::MOP::Class>.
  
  =item B<< Class::MOP::Package->create_anon(%options) >>
  
  Creates a new anonymous package. Valid keys for C<%options> are:
  
  =over 4
  
  =item C<weaken>
  
  If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
  cache will be weakened, so that the anonymous package will be garbage collected
  when the returned instance goes out of scope.
  
  =back
  
  =item B<< $metapackage->is_anon >>
  
  Returns true if the package is an anonymous package.
  
  =item B<< $metapackage->name >>
  
  This is returns the package's name, as passed to the constructor.
  
  =item B<< $metapackage->namespace >>
  
  This returns a hash reference to the package's symbol table. The keys
  are symbol names and the values are typeglob references.
  
  =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
  
  This method accepts a variable name and an optional initial value. The
  C<$variable_name> must contain a leading sigil.
  
  This method creates the variable in the package's symbol table, and
  sets it to the initial value if one was provided.
  
  =item B<< $metapackage->get_package_symbol($variable_name) >>
  
  Given a variable name, this method returns the variable as a reference
  or undef if it does not exist. The C<$variable_name> must contain a
  leading sigil.
  
  =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
  
  Given a variable name, this method returns the variable as a reference.
  If it does not exist, a default value will be generated if possible. The
  C<$variable_name> must contain a leading sigil.
  
  =item B<< $metapackage->has_package_symbol($variable_name) >>
  
  Returns true if there is a package variable defined for
  C<$variable_name>. The C<$variable_name> must contain a leading sigil.
  
  =item B<< $metapackage->remove_package_symbol($variable_name) >>
  
  This will remove the package variable specified C<$variable_name>. The
  C<$variable_name> must contain a leading sigil.
  
  =item B<< $metapackage->remove_package_glob($glob_name) >>
  
  Given the name of a glob, this will remove that glob from the
  package's symbol table. Glob names do not include a sigil. Removing
  the glob removes all variables and subroutines with the specified
  name.
  
  =item B<< $metapackage->list_all_package_symbols($type_filter) >>
  
  This will list all the glob names associated with the current
  package. These names do not have leading sigils.
  
  You can provide an optional type filter, which should be one of
  'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
  
  =item B<< $metapackage->get_all_package_symbols($type_filter) >>
  
  This works much like C<list_all_package_symbols>, but it returns a
  hash reference. The keys are glob names and the values are references
  to the value for that name.
  
  =item B<< Class::MOP::Package->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_CLASS_MOP_PACKAGE

$fatpacked{"darwin-thread-multi-2level/DBD/DBM.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_DBM';
  #######################################################################
  #
  #  DBD::DBM - a DBI driver for DBM files
  #
  #  Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
  #  Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand
  #
  #  All rights reserved.
  #
  #  You may freely distribute and/or modify this  module under the terms
  #  of either the GNU  General Public License (GPL) or the Artistic License,
  #  as specified in the Perl README file.
  #
  #  USERS - see the pod at the bottom of this file
  #
  #  DBD AUTHORS - see the comments in the code
  #
  #######################################################################
  require 5.005_03;
  use strict;
  
  #################
  package DBD::DBM;
  #################
  use base qw( DBD::File );
  use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed);
  $VERSION     = '0.04';
  $ATTRIBUTION = 'DBD::DBM by Jeff Zucker';
  
  # no need to have driver() unless you need private methods
  #
  sub driver ($;$)
  {
      my ( $class, $attr ) = @_;
      return $drh if ($drh);
  
      # do the real work in DBD::File
      #
      $attr->{Attribution} = 'DBD::DBM by Jeff Zucker';
      my $this = $class->SUPER::driver($attr);
  
      # install private methods
      #
      # this requires that dbm_ (or foo_) be a registered prefix
      # but you can write private methods before official registration
      # by hacking the $dbd_prefix_registry in a private copy of DBI.pm
      #
      if ( $DBI::VERSION >= 1.37 and !$methods_already_installed++ )
      {
          DBD::DBM::db->install_method('dbm_versions');
          DBD::DBM::st->install_method('dbm_schema');
      }
  
      $this;
  }
  
  sub CLONE
  {
      undef $drh;
  }
  
  #####################
  package DBD::DBM::dr;
  #####################
  $DBD::DBM::dr::imp_data_size = 0;
  @DBD::DBM::dr::ISA           = qw(DBD::File::dr);
  
  # you can get by without connect() if you don't have to check private
  # attributes, DBD::File will gather the connection string arguments for you
  #
  sub connect ($$;$$$)
  {
      my ( $drh, $dbname, $user, $auth, $attr ) = @_;
  
      # create a 'blank' dbh
      #    my $this = DBI::_new_dbh($drh, {
      #	Name => $dbname,
      #    });
      my $this = $drh->SUPER::connect( $dbname, $user, $auth, $attr );
  
      # parse the connection string for name=value pairs
      if ($this)
      {
          # define valid private attributes
          #
          # attempts to set non-valid attrs in connect() or
          # with $dbh->{attr} will throw errors
          #
          # the attrs here *must* start with dbm_ or foo_
          #
          # see the STORE methods below for how to check these attrs
          #
          $this->{dbm_valid_attrs} = {
                                       dbm_tables         => 1,    # per-table information
                                       dbm_type           => 1,    # the global DBM type e.g. SDBM_File
                                       dbm_mldbm          => 1,    # the global MLDBM serializer
                                       dbm_cols           => 1,    # the global column names
                                       dbm_version        => 1,    # verbose DBD::DBM version
                                       dbm_ext            => 1,    # file extension
                                       dbm_lockfile       => 1,    # lockfile extension
                                       dbm_store_metadata => 1,    # column names, etc.
                                       dbm_berkeley_flags => 1,    # for BerkeleyDB
                                     };
  
          my ( $var, $val );
          $this->{f_dir} = $DBD::File::haveFileSpec ? File::Spec->curdir() : '.';
          while ( length($dbname) )
          {
              if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s )
              {
                  $var = $1;
              }
              else
              {
                  $var    = $dbname;
                  $dbname = '';
              }
              if ( $var =~ /^(.+?)=(.*)/s )
              {
                  $var = $1;
                  ( $val = $2 ) =~ s/\\(.)/$1/g;
  
                  # in the connect string the attr names
                  # can either have dbm_ (or foo_) prepended or not
                  # this will add the prefix if it's missing
                  #
                  $var = 'dbm_' . $var unless ( $var =~ /^dbm_/ or $var eq 'f_dir' );
                  # XXX should pass back to DBI via $attr for connect() to STORE
                  $this->{$var} = $val;
              }
          }
          $this->{f_version}   = $DBD::File::VERSION;
          $this->{dbm_version} = $DBD::DBM::VERSION;
      }
      $this->STORE( 'Active', 1 );
      return $this;
  }
  
  # you could put some :dr private methods here
  
  # you may need to over-ride some DBD::File::dr methods here
  # but you can probably get away with just letting it do the work
  # in most cases
  
  #####################
  package DBD::DBM::db;
  #####################
  $DBD::DBM::db::imp_data_size = 0;
  @DBD::DBM::db::ISA           = qw(DBD::File::db);
  
  # the ::db::STORE method is what gets called when you set
  # a lower-cased database handle attribute such as $dbh->{somekey}=$someval;
  #
  # STORE should check to make sure that "somekey" is a valid attribute name
  # but only if it is really one of our attributes (starts with dbm_ or foo_)
  # You can also check for valid values for the attributes if needed
  # and/or perform other operations
  #
  sub STORE ($$$)
  {
      my ( $dbh, $attrib, $value ) = @_;
  
      # use DBD::File's STORE unless its one of our own attributes
      #
      return $dbh->SUPER::STORE( $attrib, $value ) unless ( $attrib =~ /^dbm_/ );
  
      # throw an error if it has our prefix but isn't a valid attr name
      #
      if (
          $attrib ne 'dbm_valid_attrs'    # gotta start somewhere :-)
          and !$dbh->{dbm_valid_attrs}->{$attrib}
         )
      {
          return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'!" );
      }
      else
      {
  
          # check here if you need to validate values
          # or conceivably do other things as well
          #
          $dbh->{$attrib} = $value;
          return 1;
      }
  }
  
  # and FETCH is done similar to STORE
  #
  sub FETCH ($$)
  {
      my ( $dbh, $attrib ) = @_;
  
      return $dbh->SUPER::FETCH($attrib) unless $attrib =~ /^dbm_/;
  
      # throw an error if it has our prefix but isn't a valid attr name
      #
      if (
          $attrib ne 'dbm_valid_attrs'    # gotta start somewhere :-)
          and !$dbh->{dbm_valid_attrs}->{$attrib}
         )
      {
          return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" );
      }
      else
      {
  
          # check here if you need to validate values
          # or conceivably do other things as well
          #
          return $dbh->{$attrib};
      }
  }
  
  # this is an example of a private method
  # these used to be done with $dbh->func(...)
  # see above in the driver() sub for how to install the method
  #
  sub dbm_versions
  {
      my $dbh = shift;
      my $table = shift || '';
      my $dtype =
           $dbh->{dbm_tables}->{$table}->{type}
        || $dbh->{dbm_type}
        || 'SDBM_File';
      my $mldbm =
           $dbh->{dbm_tables}->{$table}->{mldbm}
        || $dbh->{dbm_mldbm}
        || '';
      $dtype .= ' + MLDBM + ' . $mldbm if ($mldbm);
  
      my %version = ( DBI => $DBI::VERSION );
      $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if ($DBI::PurePerl);
      $version{OS}              = "$^O ($Config::Config{osvers})";
      $version{Perl}            = "$] ($Config::Config{archname})";
      my $str = sprintf( "%-16s %s\n%-16s %s\n%-16s %s\n",
                         'DBD::DBM', $dbh->{Driver}->{Version} . " using $dtype",
                         '  DBD::File', $dbh->{f_version},
                         '  DBI::SQL::Nano',
                         $dbh->{sql_nano_version} );
      $str .= sprintf( "%-16s %s\n", '  SQL::Statement', $dbh->{sql_statement_version} )
        if ( $dbh->{sql_handler} eq 'SQL::Statement' );
  
      for ( sort keys %version )
      {
          $str .= sprintf( "%-16s %s\n", $_, $version{$_} );
      }
      return "$str\n";
  }
  
  # you may need to over-ride some DBD::File::db methods here
  # but you can probably get away with just letting it do the work
  # in most cases
  
  #####################
  package DBD::DBM::st;
  #####################
  $DBD::DBM::st::imp_data_size = 0;
  @DBD::DBM::st::ISA           = qw(DBD::File::st);
  
  sub dbm_schema
  {
      my ( $sth, $tname ) = @_;
      return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname;
      return $sth->set_err( $DBI::stderr, "Unknown table '$tname'!" )
        unless (     $sth->{Database}->{dbm_tables}
                 and $sth->{Database}->{dbm_tables}->{$tname} );
      return $sth->{Database}->{dbm_tables}->{$tname}->{schema};
  }
  # you could put some :st private methods here
  
  # you may need to over-ride some DBD::File::st methods here
  # but you can probably get away with just letting it do the work
  # in most cases
  
  ############################
  package DBD::DBM::Statement;
  ############################
  use base qw( DBD::File::Statement );
  use Carp qw(croak);
  use IO::File;    # for locking only
  use Fcntl;
  
  my $HAS_FLOCK = eval { flock STDOUT, 0; 1 };
  
  # you must define open_table;
  # it is done at the start of all executes;
  # it doesn't necessarily have to "open" anything;
  # you must define the $tbl and at least the col_names and col_nums;
  # anything else you put in depends on what you need in your
  # ::Table methods below; you must bless the $tbl into the
  # appropriate class as shown
  #
  # see also the comments inside open_table() showing the difference
  # between global, per-table, and default settings
  #
  sub open_table ($$$$$)
  {
      my ( $self, $data, $table, $createMode, $lockMode ) = @_;
      my $dbh = $data->{Database};
  
      my $tname = $table || $self->{tables}->[0]->{name};
      my $file;
      ( $table, $file ) = $self->get_file_name( $data, $tname );
  
      # note the use of three levels of attribute settings below
      # first it looks for a per-table setting
      # if none is found, it looks for a global setting
      # if none is found, it sets a default
      #
      # your DBD may not need this, globals and defaults may be enough
      #
      my $dbm_type =
           $dbh->{dbm_tables}->{$tname}->{type}
        || $dbh->{dbm_type}
        || 'SDBM_File';
      $dbh->{dbm_tables}->{$tname}->{type} = $dbm_type;
  
      my $serializer =
           $dbh->{dbm_tables}->{$tname}->{mldbm}
        || $dbh->{dbm_mldbm}
        || '';
      $dbh->{dbm_tables}->{$tname}->{mldbm} = $serializer if $serializer;
  
      my $ext = '' if ( $dbm_type eq 'GDBM_File' or $dbm_type eq 'DB_File' or $dbm_type eq 'BerkeleyDB' );
      # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley
      # behind the scenes and so create a single .db file.
      $ext = '.pag' if ( $dbm_type eq 'NDBM_File' or $dbm_type eq 'SDBM_File' or $dbm_type eq 'ODBM_File' );
      $ext = $dbh->{dbm_ext} if ( defined $dbh->{dbm_ext} );
      $ext = $dbh->{dbm_tables}->{$tname}->{ext} if ( defined $dbh->{dbm_tables}->{$tname}->{ext} );
      $ext = '' unless ( defined $ext );
  
      my $open_mode = O_RDONLY;
      $open_mode = O_RDWR if ($lockMode);
      $open_mode = O_RDWR | O_CREAT | O_TRUNC if ($createMode);
  
      my ($tie_type);
  
      if ($serializer)
      {
          require 'MLDBM.pm';
          $MLDBM::UseDB      = $dbm_type;
          $MLDBM::UseDB      = 'BerkeleyDB::Hash' if ( $dbm_type eq 'BerkeleyDB' );
          $MLDBM::Serializer = $serializer;
          $tie_type          = 'MLDBM';
      }
      else
      {
          require "$dbm_type.pm";
          $tie_type = $dbm_type;
      }
  
      # Second-guessing the file extension isn't great here (or in general)
      # could replace this by trying to open the file in non-create mode
      # first and dieing if that succeeds.
      # Currently this test doesn't work where NDBM is actually Berkeley (.db)
      croak "Cannot CREATE '$file$ext' because it already exists"
        if ( $createMode and ( -e "$file$ext" ) );
  
      # LOCKING
      #
      my ( $nolock, $lockext, $lock_table );
      $lockext = $dbh->{dbm_tables}->{$tname}->{lockfile};
      $lockext = $dbh->{dbm_lockfile} if !defined $lockext;
      if ( ( defined $lockext and $lockext == 0 ) or !$HAS_FLOCK )
      {
          undef $lockext;
          $nolock = 1;
      }
      else
      {
          $lockext ||= '.lck';
      }
      # open and flock the lockfile, creating it if necessary
      #
      if ( !$nolock )
      {
          $lock_table = $self->SUPER::open_table( $data, "$table$lockext", $createMode, $lockMode );
      }
  
      # TIEING
      #
      # allow users to pass in a pre-created tied object
      #
      my @tie_args;
      if ( $dbm_type eq 'BerkeleyDB' )
      {
          my $DB_CREATE = 1;     # but import constants if supplied
          my $DB_RDONLY = 16;    #
          my %flags;
          if ( my $f = $dbh->{dbm_berkeley_flags} )
          {
              $DB_CREATE = $f->{DB_CREATE} if ( $f->{DB_CREATE} );
              $DB_RDONLY = $f->{DB_RDONLY} if ( $f->{DB_RDONLY} );
              delete $f->{DB_CREATE};
              delete $f->{DB_RDONLY};
              %flags = %$f;
          }
          $flags{'-Flags'} = $DB_RDONLY;
          $flags{'-Flags'} = $DB_CREATE if ( $lockMode or $createMode );
          my $t = 'BerkeleyDB::Hash';
          $t = 'MLDBM' if ($serializer);
          @tie_args = (
                        $t,
                        -Filename => $file,
                        %flags
                      );
      }
      else
      {
          @tie_args = ( $tie_type, $file, $open_mode, 0666 );
      }
      my %h;
      if ( $self->{command} ne 'DROP' )
      {
          my $tie_class = shift @tie_args;
          eval { tie %h, $tie_class, @tie_args };
          croak "Cannot tie(%h $tie_class @tie_args): $@" if ($@);
      }
  
      # COLUMN NAMES
      #
      my $store = $dbh->{dbm_tables}->{$tname}->{store_metadata};
      $store = $dbh->{dbm_store_metadata} unless ( defined $store );
      $store = 1 unless ( defined $store );
      $dbh->{dbm_tables}->{$tname}->{store_metadata} = $store;
  
      my ( $meta_data, $schema, $col_names );
      $meta_data = $col_names = $h{"_metadata \0"} if $store;
      if ( $meta_data and $meta_data =~ m~<dbd_metadata>(.+)</dbd_metadata>~is )
      {
          $schema = $col_names = $1;
          $schema    =~ s~.*<schema>(.+)</schema>.*~$1~is;
          $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is;
      }
      $col_names ||=
           $dbh->{dbm_tables}->{$tname}->{c_cols}
        || $dbh->{dbm_tables}->{$tname}->{cols}
        || $dbh->{dbm_cols}
        || [ 'k', 'v' ];
      $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' );
      $dbh->{dbm_tables}->{$tname}->{cols}   = $col_names;
      $dbh->{dbm_tables}->{$tname}->{schema} = $schema;
  
      my $i;
      my %col_nums = map { $_ => $i++ } @$col_names;
  
      my $tbl = {
                  table_name     => $tname,
                  file           => $file,
                  ext            => $ext,
                  hash           => \%h,
                  dbm_type       => $dbm_type,
                  store_metadata => $store,
                  mldbm          => $serializer,
                  lock_fh        => $lock_table->{fh},
                  lock_ext       => $lockext,
                  nolock         => $nolock,
                  col_nums       => \%col_nums,
                  col_names      => $col_names
                };
  
      my $class = ref($self);
      $class =~ s/::Statement/::Table/;
      bless( $tbl, $class );
      $tbl;
  }
  
  ########################
  package DBD::DBM::Table;
  ########################
  use base qw( DBD::File::Table );
  
  # you must define drop
  # it is called from execute of a SQL DROP statement
  #
  sub drop ($$)
  {
      my ( $self, $data ) = @_;
      untie %{ $self->{hash} } if ( $self->{hash} );
      my $ext = $self->{ext};
      unlink $self->{file} . $ext if ( -f $self->{file} . $ext );
      unlink $self->{file} . '.dir' if ( -f $self->{file} . '.dir' and $ext eq '.pag' );
      if ( !$self->{nolock} )
      {
          $self->{lock_fh}->close if ( $self->{lock_fh} );
          unlink $self->{file} . $self->{lock_ext} if ( -f $self->{file} . $self->{lock_ext} );
      }
      return 1;
  }
  
  # you must define fetch_row, it is called on all fetches;
  # it MUST return undef when no rows are left to fetch;
  # checking for $ary[0] is specific to hashes so you'll
  # probably need some other kind of check for nothing-left.
  # as Janis might say: "undef's just another word for
  # nothing left to fetch" :-)
  #
  sub fetch_row ($$$)
  {
      my ( $self, $data, $row ) = @_;
      # fetch with %each
      #
      my @ary = each %{ $self->{hash} };
      @ary = each %{ $self->{hash} } if ( $self->{store_metadata} and $ary[0] and $ary[0] eq "_metadata \0" );
  
      my ( $key, $val ) = @ary;
      return undef unless ($key);
      my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val );
      return wantarray ? @row : \@row;
  
      # fetch without %each
      #
      # $self->{keys} = [sort keys %{$self->{hash}}] unless $self->{keys};
      # my $key = shift @{$self->{keys}};
      # $key = shift @{$self->{keys}} if $self->{store_metadata}
      #                             and $key
      #                             and $key eq "_metadata \0";
      # return undef unless defined $key;
      # my @ary;
      # $row = $self->{hash}->{$key};
      # if (ref $row eq 'ARRAY') {
      #   @ary = ( $key, @{$row} );
      # }
      # else {
      #    @ary = ($key,$row);
      # }
      # return (@ary) if wantarray;
      # return \@ary;
  }
  
  # you must define push_row
  # it is called on inserts and updates
  #
  sub push_row ($$$)
  {
      my ( $self, $data, $row_aryref ) = @_;
      my $key = shift @$row_aryref;
      if ( $self->{mldbm} )
      {
          $self->{hash}->{$key} = $row_aryref;
      }
      else
      {
          $self->{hash}->{$key} = $row_aryref->[0];
      }
      1;
  }
  
  # this is where you grab the column names from a CREATE statement
  # if you don't need to do that, it must be defined but can be empty
  #
  sub push_names ($$$)
  {
      my ( $self, $data, $row_aryref ) = @_;
      $data->{Database}->{dbm_tables}->{ $self->{table_name} }->{c_cols} = $row_aryref;
      return unless $self->{store_metadata};
      my $stmt      = $data->{f_stmt};
      my $col_names = join( ',', @{$row_aryref} );
      my $schema    = $data->{Database}->{Statement};
      $schema =~ s/^[^\(]+\((.+)\)$/$1/s;
      $schema = $stmt->schema_str() if ( $stmt->can('schema_str') );
      $self->{hash}->{"_metadata \0"} =
        "<dbd_metadata>" . "<schema>$schema</schema>" . "<col_names>$col_names</col_names>" . "</dbd_metadata>";
  }
  
  # fetch_one_row, delete_one_row, update_one_row
  # are optimized for hash-style lookup without looping;
  # if you don't need them, omit them, they're optional
  # but, in that case you may need to define
  # truncate() and seek(), see below
  #
  sub fetch_one_row ($$;$)
  {
      my ( $self, $key_only, $key ) = @_;
      return $self->{col_names}->[0] if ($key_only);
      return undef unless ( exists $self->{hash}->{$key} );
      my $val = $self->{hash}->{$key};
      $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val];
      my $row = [ $key, @$val ];
      return wantarray ? @{$row} : $row;
  }
  
  sub delete_one_row ($$$)
  {
      my ( $self, $data, $aryref ) = @_;
      delete $self->{hash}->{ $aryref->[0] };
  }
  
  sub update_one_row ($$$)
  {
      my ( $self, $data, $aryref ) = @_;
      my $key = shift @$aryref;
      return undef unless defined $key;
      my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref];
      $self->{hash}->{$key} = $self->{mldbm} ? $row : $row->[0];
  }
  
  # you may not need to explicitly DESTROY the ::Table
  # put cleanup code to run when the execute is done
  #
  sub DESTROY ($)
  {
      my $self = shift;
      untie %{ $self->{hash} } if ( $self->{hash} );
      # release the flock on the lock file
      $self->{lock_fh}->close if ( !$self->{nolock} and $self->{lock_fh} );
  }
  
  # truncate() and seek() must be defined to satisfy DBI::SQL::Nano
  # *IF* you define the *_one_row methods above, truncate() and
  # seek() can be empty or you can use them without actually
  # truncating or seeking anything but if you don't define the
  # *_one_row methods, you may need to define these
  
  # if you need to do something after a series of
  # deletes or updates, you can put it in truncate()
  # which is called at the end of executing
  #
  sub truncate ($$)
  {
      my ( $self, $data ) = @_;
      1;
  }
  
  # seek() is only needed if you use IO::File
  # though it could be used for other non-file operations
  # that you need to do before "writes" or truncate()
  #
  sub seek ($$$$)
  {
      my ( $self, $data, $pos, $whence ) = @_;
  }
  
  # Th, th, th, that's all folks!  See DBD::File and DBD::CSV for other
  # examples of creating pure perl DBDs.  I hope this helped.
  # Now it's time to go forth and create your own DBD!
  # Remember to check in with dbi-dev@perl.org before you get too far.
  # We may be able to make suggestions or point you to other related
  # projects.
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  DBD::DBM - a DBI driver for DBM & MLDBM files
  
  =head1 SYNOPSIS
  
   use DBI;
   $dbh = DBI->connect('dbi:DBM:');                # defaults to SDBM_File
   $dbh = DBI->connect('DBI:DBM(RaiseError=1):');  # defaults to SDBM_File
   $dbh = DBI->connect('dbi:DBM:type=GDBM_File');  # defaults to GDBM_File
   $dbh = DBI->connect('dbi:DBM:mldbm=Storable');  # MLDBM with SDBM_File
                                                   # and Storable
  
  or
  
   $dbh = DBI->connect('dbi:DBM:', undef, undef);
   $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_type => 'ODBM_File' });
  
  and other variations on connect() as shown in the DBI docs and with
  the dbm_ attributes shown below
  
  ... and then use standard DBI prepare, execute, fetch, placeholders, etc.,
  see L<QUICK START> for an example
  
  =head1 DESCRIPTION
  
  DBD::DBM is a database management sytem that can work right out of the box.
  If you have a standard installation of Perl and a standard installation of
  DBI, you can begin creating, accessing, and modifying database tables
  without any further installation.  You can also add some other modules to
  it for more robust capabilities if you wish.
  
  The module uses a DBM file storage layer.  DBM file storage is common on
  many platforms and files can be created with it in many languages. That
  means that, in addition to creating files with DBI/SQL, you can also use
  DBI/SQL to access and modify files created by other DBM modules and
  programs.  You can also use those programs to access files created with
  DBD::DBM.
  
  DBM files are stored in binary format optimized for quick retrieval when
  using a key field.  That optimization can be used advantageously to make
  DBD::DBM SQL operations that use key fields very fast.  There are several
  different "flavors" of DBM - different storage formats supported by
  different sorts of perl modules such as SDBM_File and MLDBM.  This module
  supports all of the flavors that perl supports and, when used with MLDBM,
  supports tables with any number of columns and insertion of Perl objects
  into tables.
  
  DBD::DBM has been tested with the following DBM types: SDBM_File,
  NDBM_File, ODBM_File, GDBM_File, DB_File, BerekeleyDB.  Each type was
  tested both with and without MLDBM.
  
  =head1 QUICK START
  
  DBD::DBM operates like all other DBD drivers - it's basic syntax and
  operation is specified by DBI.  If you're not familiar with DBI, you should
  start by reading L<DBI> and the documents it points to and then come back
  and read this file.  If you are familiar with DBI, you already know most of
  what you need to know to operate this module.  Just jump in and create a
  test script something like the one shown below.
  
  You should be aware that there are several options for the SQL engine
  underlying DBD::DBM, see L<Supported SQL syntax>.  There are also many
  options for DBM support, see especially the section on L<Adding
  multi-column support with MLDBM>.
  
  But here's a sample to get you started.
  
   use DBI;
   my $dbh = DBI->connect('dbi:DBM:');
   $dbh->{RaiseError} = 1;
   for my $sql( split /;\n+/,"
       CREATE TABLE user ( user_name TEXT, phone TEXT );
       INSERT INTO user VALUES ('Fred Bloggs','233-7777');
       INSERT INTO user VALUES ('Sanjay Patel','777-3333');
       INSERT INTO user VALUES ('Junk','xxx-xxxx');
       DELETE FROM user WHERE user_name = 'Junk';
       UPDATE user SET phone = '999-4444' WHERE user_name = 'Sanjay Patel';
       SELECT * FROM user
   "){
       my $sth = $dbh->prepare($sql);
       $sth->execute;
       $sth->dump_results if $sth->{NUM_OF_FIELDS};
   }
   $dbh->disconnect;
  
  =head1 USAGE
  
  =head2 Specifiying Files and Directories
  
  DBD::DBM will automatically supply an appropriate file extension for the
  type of DBM you are using.  For example, if you use SDBM_File, a table
  called "fruit" will be stored in two files called "fruit.pag" and
  "fruit.dir".  You should I<never> specify the file extensions in your SQL
  statements.
  
  However, I am not aware (and therefore DBD::DBM is not aware) of all
  possible extensions for various DBM types.  If your DBM type uses an
  extension other than .pag and .dir, you should set the I<dbm_ext> attribute
  to the extension. B<And> you should write me with the name of the
  implementation and extension so I can add it to DBD::DBM! Thanks in advance
  for that :-).
  
      $dbh = DBI->connect('dbi:DBM:ext=.db');  # .db extension is used
      $dbh = DBI->connect('dbi:DBM:ext=');     # no extension is used
  
  or
  
      $dbh->{dbm_ext}='.db';                      # global setting
      $dbh->{dbm_tables}->{'qux'}->{ext}='.db';   # setting for table 'qux'
  
  By default files are assumed to be in the current working directory.  To
  have the module look in a different directory, specify the I<f_dir>
  attribute in either the connect string or by setting the database handle
  attribute.
  
  For example, this will look for the file /foo/bar/fruit (or
  /foo/bar/fruit.pag for DBM types that use that extension)
  
     my $dbh = DBI->connect('dbi:DBM:f_dir=/foo/bar');
     my $ary = $dbh->selectall_arrayref(q{ SELECT * FROM fruit });
  
  And this will too:
  
     my $dbh = DBI->connect('dbi:DBM:');
     $dbh->{f_dir} = '/foo/bar';
     my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM fruit });
  
  You can also use delimited identifiers to specify paths directly in SQL
  statements.  This looks in the same place as the two examples above but
  without setting I<f_dir>:
  
     my $dbh = DBI->connect('dbi:DBM:');
     my $ary = $dbh->selectall_arrayref(q{
         SELECT x FROM "/foo/bar/fruit"
     });
  
  If you have SQL::Statement installed, you can use table aliases:
  
     my $dbh = DBI->connect('dbi:DBM:');
     my $ary = $dbh->selectall_arrayref(q{
         SELECT f.x FROM "/foo/bar/fruit" AS f
     });
  
  See the L<GOTCHAS AND WARNINGS> for using DROP on tables.
  
  =head2 Table locking and flock()
  
  Table locking is accomplished using a lockfile which has the same name as
  the table's file but with the file extension '.lck' (or a lockfile
  extension that you supply, see below).  This file is created along with the
  table during a CREATE and removed during a DROP.  Every time the table
  itself is opened, the lockfile is flocked().  For SELECT, this is an shared
  lock.  For all other operations, it is an exclusive lock.
  
  Since the locking depends on flock(), it only works on operating systems
  that support flock().  In cases where flock() is not implemented, DBD::DBM
  will not complain, it will simply behave as if the flock() had occurred
  although no actual locking will happen.  Read the documentation for flock()
  if you need to understand this.
  
  Even on those systems that do support flock(), the locking is only advisory
  - as is allways the case with flock().  This means that if some other
  program tries to access the table while DBD::DBM has the table locked, that
  other program will *succeed* at opening the table.  DBD::DBM's locking only
  applies to DBD::DBM.  An exception to this would be the situation in which
  you use a lockfile with the other program that has the same name as the
  lockfile used in DBD::DBM and that program also uses flock() on that
  lockfile.  In that case, DBD::DBM and your other program will respect each
  other's locks.
  
  If you wish to use a lockfile extension other than '.lck', simply specify
  the dbm_lockfile attribute:
  
    $dbh = DBI->connect('dbi:DBM:lockfile=.foo');
    $dbh->{dbm_lockfile} = '.foo';
    $dbh->{dbm_tables}->{qux}->{lockfile} = '.foo';
  
  If you wish to disable locking, set the dbm_lockfile equal to 0.
  
    $dbh = DBI->connect('dbi:DBM:lockfile=0');
    $dbh->{dbm_lockfile} = 0;
    $dbh->{dbm_tables}->{qux}->{lockfile} = 0;
  
  =head2 Specifying the DBM type
  
  Each "flavor" of DBM stores its files in a different format and has
  different capabilities and different limitations.  See L<AnyDBM_File> for a
  comparison of DBM types.
  
  By default, DBD::DBM uses the SDBM_File type of storage since SDBM_File
  comes with Perl itself.  But if you have other types of DBM storage
  available, you can use any of them with DBD::DBM also.
  
  You can specify the DBM type using the "dbm_type" attribute which can be
  set in the connection string or with the $dbh->{dbm_type} attribute for
  global settings or with the $dbh->{dbm_tables}->{$table_name}->{type}
  attribute for per-table settings in cases where a single script is
  accessing more than one kind of DBM file.
  
  In the connection string, just set type=TYPENAME where TYPENAME is any DBM
  type such as GDBM_File, DB_File, etc.  Do I<not> use MLDBM as your
  dbm_type, that is set differently, see below.
  
   my $dbh=DBI->connect('dbi:DBM:');               # uses the default SDBM_File
   my $dbh=DBI->connect('dbi:DBM:type=GDBM_File'); # uses the GDBM_File
  
  You can also use $dbh->{dbm_type} to set global DBM type:
  
   $dbh->{dbm_type} = 'GDBM_File';  # set the global DBM type
   print $dbh->{dbm_type};          # display the global DBM type
  
  If you are going to have several tables in your script that come from
  different DBM types, you can use the $dbh->{dbm_tables} hash to store
  different settings for the various tables.  You can even use this to
  perform joins on files that have completely different storage mechanisms.
  
   my $dbh->('dbi:DBM:type=GDBM_File');
   #
   # sets global default of GDBM_File
  
   my $dbh->{dbm_tables}->{foo}->{type} = 'DB_File';
   #
   # over-rides the global setting, but only for the table called "foo"
  
   print $dbh->{dbm_tables}->{foo}->{type};
   #
   # prints the dbm_type for the table "foo"
  
  =head2 Adding multi-column support with MLDBM
  
  Most of the DBM types only support two columns.  However a CPAN module
  called MLDBM overcomes this limitation by allowing more than two columns.
  It does this by serializing the data - basically it puts a reference to an
  array into the second column.  It can also put almost any kind of Perl
  object or even Perl coderefs into columns.
  
  If you want more than two columns, you must install MLDBM.  It's available
  for many platforms and is easy to install.
  
  MLDBM can use three different modules to serialize the column -
  Data::Dumper, Storable, and FreezeThaw.  Data::Dumper is the default,
  Storable is the fastest.  MLDBM can also make use of user-defined
  serialization methods.  All of this is available to you through DBD::DBM
  with just one attribute setting.
  
  To use MLDBM with DBD::DBM, you need to set the dbm_mldbm attribute to the
  name of the serialization module.
  
  Some examples:
  
   $dbh=DBI->connect('dbi:DBM:mldbm=Storable');  # use MLDBM with Storable
   $dbh=DBI->connect(
      'dbi:DBM:mldbm=MySerializer'           # use MLDBM with a user defined module
   );
   $dbh->{dbm_mldbm} = 'MySerializer';       # same as above
   print $dbh->{dbm_mldbm}                   # show the MLDBM serializer
   $dbh->{dbm_tables}->{foo}->{mldbm}='Data::Dumper';   # set Data::Dumper for table "foo"
   print $dbh->{dbm_tables}->{foo}->{mldbm}; # show serializer for table "foo"
  
  MLDBM works on top of other DBM modules so you can also set a DBM type
  along with setting dbm_mldbm.  The examples above would default to using
  SDBM_File with MLDBM.  If you wanted GDBM_File instead, here's how:
  
   $dbh = DBI->connect('dbi:DBM:type=GDBM_File;mldbm=Storable');
   #
   # uses GDBM_File with MLDBM and Storable
  
  SDBM_File, the default file type is quite limited, so if you are going to
  use MLDBM, you should probably use a different type, see L<AnyDBM_File>.
  
  See below for some L<GOTCHAS AND WARNINGS> about MLDBM.
  
  =head2 Support for Berkeley DB
  
  The Berkeley DB storage type is supported through two different Perl
  modules - DB_File (which supports only features in old versions of Berkeley
  DB) and BerkeleyDB (which supports all versions).  DBD::DBM supports
  specifying either "DB_File" or "BerkeleyDB" as a I<dbm_type>, with or
  without MLDBM support.
  
  The "BerkeleyDB" dbm_type is experimental and its interface is likely to
  change.  It currently defaults to BerkeleyDB::Hash and does not currently
  support ::Btree or ::Recno.
  
  With BerkeleyDB, you can specify initialization flags by setting them in
  your script like this:
  
   my $dbh = DBI->connect('dbi:DBM:type=BerkeleyDB;mldbm=Storable');
   use BerkeleyDB;
   my $env = new BerkeleyDB::Env -Home => $dir;  # and/or other Env flags
   $dbh->{dbm_berkeley_flags} = {
        'DB_CREATE'  => DB_CREATE  # pass in constants
      , 'DB_RDONLY'  => DB_RDONLY  # pass in constants
      , '-Cachesize' => 1000       # set a ::Hash flag
      , '-Env'       => $env       # pass in an environment
   };
  
  Do I<not> set the -Flags or -Filename flags, those are determined by the
  SQL (e.g. -Flags => DB_RDONLY is set automatically when you issue a SELECT
  statement).
  
  Time has not permitted me to provide support in this release of DBD::DBM
  for further Berkeley DB features such as transactions, concurrency,
  locking, etc.  I will be working on these in the future and would value
  suggestions, patches, etc.
  
  See L<DB_File> and L<BerkeleyDB> for further details.
  
  =head2 Supported SQL syntax
  
  DBD::DBM uses a subset of SQL.  The robustness of that subset depends on
  what other modules you have installed. Both options support basic SQL
  operations including CREATE TABLE, DROP TABLE, INSERT, DELETE, UPDATE, and
  SELECT.
  
  B<Option #1:> By default, this module inherits its SQL support from
  DBI::SQL::Nano that comes with DBI.  Nano is, as its name implies, a *very*
  small SQL engine.  Although limited in scope, it is faster than option #2
  for some operations.  See L<DBI::SQL::Nano> for a description of the SQL it
  supports and comparisons of it with option #2.
  
  B<Option #2:> If you install the pure Perl CPAN module SQL::Statement,
  DBD::DBM will use it instead of Nano.  This adds support for table aliases,
  for functions, for joins, and much more.  If you're going to use DBD::DBM
  for anything other than very simple tables and queries, you should install
  SQL::Statement.  You don't have to change DBD::DBM or your scripts in any
  way, simply installing SQL::Statement will give you the more robust SQL
  capabilities without breaking scripts written for DBI::SQL::Nano.  See
  L<SQL::Statement> for a description of the SQL it supports.
  
  To find out which SQL module is working in a given script, you can use the
  dbm_versions() method or, if you don't need the full output and version
  numbers, just do this:
  
   print $dbh->{sql_handler};
  
  That will print out either "SQL::Statement" or "DBI::SQL::Nano".
  
  =head2 Optimizing use of key fields
  
  Most "flavors" of DBM have only two physical columns (but can contain
  multiple logical columns as explained below).  They work similarly to a
  Perl hash with the first column serving as the key.  Like a Perl hash, DBM
  files permit you to do quick lookups by specifying the key and thus avoid
  looping through all records.  Also like a Perl hash, the keys must be
  unique.  It is impossible to create two records with the same key.  To put
  this all more simply and in SQL terms, the key column functions as the
  PRIMARY KEY.
  
  In DBD::DBM, you can take advantage of the speed of keyed lookups by using
  a WHERE clause with a single equal comparison on the key field.  For
  example, the following SQL statements are optimized for keyed lookup:
  
   CREATE TABLE user ( user_name TEXT, phone TEXT);
   INSERT INTO user VALUES ('Fred Bloggs','233-7777');
   # ... many more inserts
   SELECT phone FROM user WHERE user_name='Fred Bloggs';
  
  The "user_name" column is the key column since it is the first column. The
  SELECT statement uses the key column in a single equal comparison -
  "user_name='Fred Bloggs' - so the search will find it very quickly without
  having to loop through however many names were inserted into the table.
  
  In contrast, thes searches on the same table are not optimized:
  
   1. SELECT phone FROM user WHERE user_name < 'Fred';
   2. SELECT user_name FROM user WHERE phone = '233-7777';
  
  In #1, the operation uses a less-than (<) comparison rather than an equals
  comparison, so it will not be optimized for key searching.  In #2, the key
  field "user_name" is not specified in the WHERE clause, and therefore the
  search will need to loop through all rows to find the desired result.
  
  =head2 Specifying Column Names
  
  DBM files don't have a standard way to store column names.   DBD::DBM gets
  around this issue with a DBD::DBM specific way of storing the column names.
  B<If you are working only with DBD::DBM and not using files created by or
  accessed with other DBM programs, you can ignore this section.>
  
  DBD::DBM stores column names as a row in the file with the key I<_metadata
  \0>.  So this code
  
   my $dbh = DBI->connect('dbi:DBM:');
   $dbh->do("CREATE TABLE baz (foo CHAR(10), bar INTEGER)");
   $dbh->do("INSERT INTO baz (foo,bar) VALUES ('zippy',1)");
  
  Will create a file that has a structure something like this:
  
    _metadata \0 | foo,bar
    zippy        | 1
  
  The next time you access this table with DBD::DBM, it will treat the
  _metadata row as a header rather than as data and will pull the column
  names from there.  However, if you access the file with something other
  than DBD::DBM, the row will be treated as a regular data row.
  
  If you do not want the column names stored as a data row in the table you
  can set the I<dbm_store_metadata> attribute to 0.
  
   my $dbh = DBI->connect('dbi:DBM:store_metadata=0');
  
  or
  
   $dbh->{dbm_store_metadata} = 0;
  
  or, for per-table setting
  
   $dbh->{dbm_tables}->{qux}->{store_metadata} = 0;
  
  By default, DBD::DBM assumes that you have two columns named "k" and "v"
  (short for "key" and "value").  So if you have I<dbm_store_metadata> set to
  1 and you want to use alternate column names, you need to specify the
  column names like this:
  
   my $dbh = DBI->connect('dbi:DBM:store_metadata=0;cols=foo,bar');
  
  or
  
   $dbh->{dbm_store_metadata} = 0;
   $dbh->{dbm_cols}           = 'foo,bar';
  
  To set the column names on per-table basis, do this:
  
   $dbh->{dbm_tables}->{qux}->{store_metadata} = 0;
   $dbh->{dbm_tables}->{qux}->{cols}           = 'foo,bar';
   #
   # sets the column names only for table "qux"
  
  If you have a file that was created by another DBM program or created with
  I<dbm_store_metadata> set to zero and you want to convert it to using
  DBD::DBM's column name storage, just use one of the methods above to name
  the columns but *without* specifying I<dbm_store_metadata> as zero.  You
  only have to do that once - thereafter you can get by without setting
  either I<dbm_store_metadata> or setting I<dbm_cols> because the names will
  be stored in the file.
  
  =head2 Statement handle ($sth) attributes and methods
  
  Most statement handle attributes such as NAME, NUM_OF_FIELDS, etc. are
  available only after an execute.  The same is true of $sth->rows which is
  available after the execute but does I<not> require a fetch.
  
  =head2 The $dbh->dbm_versions() method
  
  The private method dbm_versions() presents a summary of what other modules
  are being used at any given time.  DBD::DBM can work with or without many
  other modules - it can use either SQL::Statement or DBI::SQL::Nano as its
  SQL engine, it can be run with DBI or DBI::PurePerl, it can use many kinds
  of DBM modules, and many kinds of serializers when run with MLDBM.  The
  dbm_versions() method reports on all of that and more.
  
    print $dbh->dbm_versions;               # displays global settings
    print $dbh->dbm_versions($table_name);  # displays per table settings
  
  An important thing to note about this method is that when called with no
  arguments, it displays the *global* settings.  If you over-ride these by
  setting per-table attributes, these will I<not> be shown unless you
  specify a table name as an argument to the method call.
  
  =head2 Storing Objects
  
  If you are using MLDBM, you can use DBD::DBM to take advantage of its
  serializing abilities to serialize any Perl object that MLDBM can handle.
  To store objects in columns, you should (but don't absolutely need to)
  declare it as a column of type BLOB (the type is *currently* ignored by the
  SQL engine, but heh, it's good form).
  
  You *must* use placeholders to insert or refer to the data.
  
  =head1 GOTCHAS AND WARNINGS
  
  Using the SQL DROP command will remove any file that has the name specified
  in the command with either '.pag' or '.dir' or your {dbm_ext} appended to
  it.  So this be dangerous if you aren't sure what file it refers to:
  
   $dbh->do(qq{DROP TABLE "/path/to/any/file"});
  
  Each DBM type has limitations.  SDBM_File, for example, can only store
  values of less than 1,000 characters.  *You* as the script author must
  ensure that you don't exceed those bounds.  If you try to insert a value
  that is bigger than the DBM can store, the results will be unpredictable.
  See the documentation for whatever DBM you are using for details.
  
  Different DBM implementations return records in different orders.  That
  means that you can I<not> depend on the order of records unless you use an
  ORDER BY statement.  DBI::SQL::Nano does not currently support ORDER BY
  (though it may soon) so if you need ordering, you'll have to install
  SQL::Statement.
  
  DBM data files are platform-specific.  To move them from one platform to
  another, you'll need to do something along the lines of dumping your data
  to CSV on platform #1 and then dumping from CSV to DBM on platform #2.
  DBD::AnyData and DBD::CSV can help with that.  There may also be DBM
  conversion tools for your platforms which would probably be quickest.
  
  When using MLDBM, there is a very powerful serializer - it will allow you
  to store Perl code or objects in database columns.  When these get
  de-serialized, they may be eval'ed - in other words MLDBM (or actually
  Data::Dumper when used by MLDBM) may take the values and try to execute
  them in Perl.  Obviously, this can present dangers, so if you don't know
  what's in a file, be careful before you access it with MLDBM turned on!
  
  See the entire section on L<Table locking and flock()> for gotchas and
  warnings about the use of flock().
  
  =head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS
  
  If you need help installing or using DBD::DBM, please write to the DBI
  users mailing list at dbi-users@perl.org or to the comp.lang.perl.modules
  newsgroup on usenet.  I'm afraid I can't always answer these kinds of
  questions quickly and there are many on the mailing list or in the
  newsgroup who can.
  
  If you have suggestions, ideas for improvements, or bugs to report, please
  write me directly at the email shown below.
  
  When reporting bugs, please send the output of $dbh->dbm_versions($table)
  for a table that exhibits the bug and, if possible, as small a sample as
  you can make of the code that produces the bug.  And of course, patches are
  welcome too :-).
  
  =head1 ACKNOWLEDGEMENTS
  
  Many, many thanks to Tim Bunce for prodding me to write this, and for
  copious, wise, and patient suggestions all along the way.
  
  =head1 AUTHOR AND COPYRIGHT
  
  This module is written by Jeff Zucker < jzucker AT cpan.org >, who also
  maintained it till 2010. After that, Jens Rehsack & H.Merijn Brand took
  over maintenance.
  
   Copyright (c) 2004 by Jeff Zucker, all rights reserved.
   Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand, all rights reserved.
  
  You may freely distribute and/or modify this module under the terms of
  either the GNU General Public License (GPL) or the Artistic License, as
  specified in the Perl README file.
  
  =head1 SEE ALSO
  
  L<DBI>, L<SQL::Statement>, L<DBI::SQL::Nano>, L<AnyDBM_File>, L<MLDBM>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_DBM

$fatpacked{"darwin-thread-multi-2level/DBD/ExampleP.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_EXAMPLEP';
  {
      package DBD::ExampleP;
  
      use Symbol;
  
      use DBI qw(:sql_types);
  
      @EXPORT = qw(); # Do NOT @EXPORT anything.
      $VERSION = sprintf("12.%06d", q$Revision: 10007 $ =~ /(\d+)/o);
  
  
  #   $Id: ExampleP.pm 10007 2007-09-27 20:53:04Z timbo $
  #
  #   Copyright (c) 1994,1997,1998 Tim Bunce
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
      @statnames = qw(dev ino mode nlink
  	uid gid rdev size
  	atime mtime ctime
  	blksize blocks name);
      @statnames{@statnames} = (0 .. @statnames-1);
  
      @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  	SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  	SQL_INTEGER, SQL_INTEGER, SQL_INTEGER,
  	SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR);
      @stattypes{@statnames} = @stattypes;
      @statprec = ((10) x (@statnames-1), 1024);
      @statprec{@statnames} = @statprec;
      die unless @statnames == @stattypes;
      die unless @statprec  == @stattypes;
  
      $drh = undef;	# holds driver handle once initialised
      #$gensym = "SYM000"; # used by st::execute() for filehandles
  
      sub driver{
  	return $drh if $drh;
  	my($class, $attr) = @_;
  	$class .= "::dr";
  	($drh) = DBI::_new_drh($class, {
  	    'Name' => 'ExampleP',
  	    'Version' => $VERSION,
  	    'Attribution' => 'DBD Example Perl stub by Tim Bunce',
  	    }, ['example implementors private data '.__PACKAGE__]);
  	$drh;
      }
  
      sub CLONE {
  	undef $drh;
      }
  }
  
  
  {   package DBD::ExampleP::dr; # ====== DRIVER ======
      $imp_data_size = 0;
      use strict;
  
      sub connect { # normally overridden, but a handy default
          my($drh, $dbname, $user, $auth)= @_;
          my ($outer, $dbh) = DBI::_new_dbh($drh, {
              Name => $dbname,
              examplep_private_dbh_attrib => 42, # an example, for testing
          });
          $dbh->{examplep_get_info} = {
              29 => '"',  # SQL_IDENTIFIER_QUOTE_CHAR
              41 => '.',  # SQL_CATALOG_NAME_SEPARATOR
              114 => 1,   # SQL_CATALOG_LOCATION
          };
          #$dbh->{Name} = $dbname;
          $dbh->STORE('Active', 1);
          return $outer;
      }
  
      sub data_sources {
  	return ("dbi:ExampleP:dir=.");	# possibly usefully meaningless
      }
  
  }
  
  
  {   package DBD::ExampleP::db; # ====== DATABASE ======
      $imp_data_size = 0;
      use strict;
  
      sub prepare {
  	my($dbh, $statement)= @_;
  	my @fields;
  	my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i;
  
  	if (defined $fields and defined $dir) {
  	    @fields = ($fields eq '*')
  			? keys %DBD::ExampleP::statnames
  			: split(/\s*,\s*/, $fields);
  	}
  	else {
  	    return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")")
  		unless $statement =~ m/^\s*set\s+/;
  	    # the SET syntax is just a hack so the ExampleP driver can
  	    # be used to test non-select statements.
  	    # Now we have DBI::DBM etc., ExampleP should be deprecated
  	}
  
  	my ($outer, $sth) = DBI::_new_sth($dbh, {
  	    'Statement'     => $statement,
              examplep_private_sth_attrib => 24, # an example, for testing
  	}, ['example implementors private data '.__PACKAGE__]);
  
  	my @bad = map {
  	    defined $DBD::ExampleP::statnames{$_} ? () : $_
  	} @fields;
  	return $dbh->set_err($DBI::stderr, "Unknown field names: @bad")
  		if @bad;
  
  	$outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
  
  	$sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/;
  	$outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0);
  
  	if (@fields) {
  	    $outer->STORE('NAME'     => \@fields);
  	    $outer->STORE('NULLABLE' => [ (0) x @fields ]);
  	    $outer->STORE('SCALE'    => [ (0) x @fields ]);
  	}
  
  	$outer;
      }
  
  
      sub table_info {
  	my $dbh = shift;
  	my ($catalog, $schema, $table, $type) = @_;
  
  	my @types = split(/["']*,["']/, $type || 'TABLE');
  	my %types = map { $_=>$_ } @types;
  
  	# Return a list of all subdirectories
  	my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  	my $haveFileSpec = eval { require File::Spec };
  	my $dir = $catalog || ($haveFileSpec ? File::Spec->curdir() : ".");
  	my @list;
  	if ($types{VIEW}) {	# for use by test harness
  	    push @list, [ undef, "schema",  "table",  'VIEW', undef ];
  	    push @list, [ undef, "sch-ema", "table",  'VIEW', undef ];
  	    push @list, [ undef, "schema",  "ta-ble", 'VIEW', undef ];
  	    push @list, [ undef, "sch ema", "table",  'VIEW', undef ];
  	    push @list, [ undef, "schema",  "ta ble", 'VIEW', undef ];
  	}
  	if ($types{TABLE}) {
  	    no strict 'refs';
  	    opendir($dh, $dir)
  		or return $dbh->set_err(int($!), "Failed to open directory $dir: $!");
  	    while (defined(my $item = readdir($dh))) {
                  if ($^O eq 'VMS') {
                      # if on VMS then avoid warnings from catdir if you use a file
                      # (not a dir) as the item below
                      next if $item !~ /\.dir$/oi;
                  }
                  my $file = ($haveFileSpec) ? File::Spec->catdir($dir,$item) : $item;
  		next unless -d $file;
  		my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
  		my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
  		push @list, [ $dir, $pwnam, $item, 'TABLE', undef ];
  	    }
  	    close($dh);
  	}
  	# We would like to simply do a DBI->connect() here. However,
  	# this is wrong if we are in a subclass like DBI::ProxyServer.
  	$dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','')
  	    or return $dbh->set_err($DBI::err,
  			"Failed to connect to DBI::Sponge: $DBI::errstr");
  
  	my $attr = {
  	    'rows' => \@list,
  	    'NUM_OF_FIELDS' => 5,
  	    'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME',
  		    'TABLE_TYPE', 'REMARKS'],
  	    'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(),
  		    DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ],
  	    'NULLABLE' => [1, 1, 1, 1, 1]
  	};
  	my $sdbh = $dbh->{'dbd_sponge_dbh'};
  	my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr)
  	    or return $dbh->set_err($sdbh->err(), $sdbh->errstr());
  	$sth;
      }
  
  
      sub type_info_all {
  	my ($dbh) = @_;
  	my $ti = [
  	    {	TYPE_NAME	=> 0,
  		DATA_TYPE	=> 1,
  		COLUMN_SIZE	=> 2,
  		LITERAL_PREFIX	=> 3,
  		LITERAL_SUFFIX	=> 4,
  		CREATE_PARAMS	=> 5,
  		NULLABLE	=> 6,
  		CASE_SENSITIVE	=> 7,
  		SEARCHABLE	=> 8,
  		UNSIGNED_ATTRIBUTE=> 9,
  		FIXED_PREC_SCALE=> 10,
  		AUTO_UNIQUE_VALUE => 11,
  		LOCAL_TYPE_NAME	=> 12,
  		MINIMUM_SCALE	=> 13,
  		MAXIMUM_SCALE	=> 14,
  	    },
  	    [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
  	    [ 'INTEGER', DBI::SQL_INTEGER,   10, "","",   undef, 0, 0, 1, 0, 0,0,undef,0,0 ],
  	];
  	return $ti;
      }
  
  
      sub ping {
  	(shift->FETCH('Active')) ? 2 : 0;    # the value 2 is checked for by t/80proxy.t
      }
  
  
      sub disconnect {
  	shift->STORE(Active => 0);
  	return 1;
      }
  
  
      sub get_info {
  	my ($dbh, $info_type) = @_;
  	return $dbh->{examplep_get_info}->{$info_type};
      }
  
  
      sub FETCH {
  	my ($dbh, $attrib) = @_;
  	# In reality this would interrogate the database engine to
  	# either return dynamic values that cannot be precomputed
  	# or fetch and cache attribute values too expensive to prefetch.
  	# else pass up to DBI to handle
  	return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path';
  	return $dbh->SUPER::FETCH($attrib);
      }
  
  
      sub STORE {
  	my ($dbh, $attrib, $value) = @_;
  	# would normally validate and only store known attributes
  	# else pass up to DBI to handle
  	if ($attrib eq 'AutoCommit') {
  	    # convert AutoCommit values to magic ones to let DBI
  	    # know that the driver has 'handled' the AutoCommit attribute
  	    $value = ($value) ? -901 : -900;
  	}
  	return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
  	return $dbh->SUPER::STORE($attrib, $value);
      }
  
      sub DESTROY {
  	my $dbh = shift;
  	$dbh->disconnect if $dbh->FETCH('Active');
  	undef
      }
  
  
      # This is an example to demonstrate the use of driver-specific
      # methods via $dbh->func().
      # Use it as follows:
      #   my @tables = $dbh->func($re, 'examplep_tables');
      #
      # Returns all the tables that match the regular expression $re.
      sub examplep_tables {
  	my $dbh = shift; my $re = shift;
  	grep { $_ =~ /$re/ } $dbh->tables();
      }
  
      sub parse_trace_flag {
  	my ($h, $name) = @_;
  	return 0x01000000 if $name eq 'foo';
  	return 0x02000000 if $name eq 'bar';
  	return 0x04000000 if $name eq 'baz';
  	return 0x08000000 if $name eq 'boo';
  	return 0x10000000 if $name eq 'bop';
  	return $h->SUPER::parse_trace_flag($name);
      }
  
      sub private_attribute_info {
          return { example_driver_path => undef };
      }
  }
  
  
  {   package DBD::ExampleP::st; # ====== STATEMENT ======
      $imp_data_size = 0;
      use strict; no strict 'refs'; # cause problems with filehandles
  
      my $haveFileSpec = eval { require File::Spec };
  
      sub bind_param {
  	my($sth, $param, $value, $attribs) = @_;
  	$sth->{'dbd_param'}->[$param-1] = $value;
  	return 1;
      }
  
  
      sub execute {
  	my($sth, @dir) = @_;
  	my $dir;
  
  	if (@dir) {
  	    $sth->bind_param($_, $dir[$_-1]) or return
  		foreach (1..@dir);
  	}
  
  	my $dbd_param = $sth->{'dbd_param'} || [];
  	return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected")
  	    unless @$dbd_param == $sth->{NUM_OF_PARAMS};
  
  	return 0 unless $sth->{NUM_OF_FIELDS}; # not a select
  
  	$dir = $dbd_param->[0] || $sth->{examplep_ex_dir};
  	return $sth->set_err(2, "No bind parameter supplied")
  	    unless defined $dir;
  
  	$sth->finish;
  
  	#
  	# If the users asks for directory "long_list_4532", then we fake a
  	# directory with files "file4351", "file4350", ..., "file0".
  	# This is a special case used for testing, especially DBD::Proxy.
  	#
  	if ($dir =~ /^long_list_(\d+)$/) {
  	    $sth->{dbd_dir} = [ $1 ];	# array ref indicates special mode
  	    $sth->{dbd_datahandle} = undef;
  	}
  	else {
  	    $sth->{dbd_dir} = $dir;
  	    my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
  	    opendir($sym, $dir)
                  or return $sth->set_err(2, "opendir($dir): $!");
  	    $sth->{dbd_datahandle} = $sym;
  	}
  	$sth->STORE(Active => 1);
  	return 1;
      }
  
  
      sub fetch {
  	my $sth = shift;
  	my $dir = $sth->{dbd_dir};
  	my %s;
  
  	if (ref $dir) {		# special fake-data test mode
  	    my $num = $dir->[0]--;
  	    unless ($num > 0) {
  		$sth->finish();
  		return;
  	    }
  	    my $time = time;
  	    @s{@DBD::ExampleP::statnames} =
  		( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024,
  	          $time, $time, $time, 512, 2, "file$num")
  	}
  	else {			# normal mode
              my $dh  = $sth->{dbd_datahandle}
                  or return $sth->set_err($DBI::stderr, "fetch without successful execute");
  	    my $f = readdir($dh);
  	    unless ($f) {
  		$sth->finish;
  		return;
  	    }
  	    # untaint $f so that we can use this for DBI taint tests
  	    ($f) = ($f =~ m/^(.*)$/);
  	    my $file = $haveFileSpec
  		? File::Spec->catfile($dir, $f) : "$dir/$f";
  	    # put in all the data fields
  	    @s{ @DBD::ExampleP::statnames } = (lstat($file), $f);
  	}
  
  	# return just what fields the query asks for
  	my @new = @s{ @{$sth->{NAME}} };
  
  	return $sth->_set_fbav(\@new);
      }
      *fetchrow_arrayref = \&fetch;
  
  
      sub finish {
  	my $sth = shift;
  	closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle};
  	$sth->{dbd_datahandle} = undef;
  	$sth->{dbd_dir} = undef;
  	$sth->SUPER::finish();
  	return 1;
      }
  
  
      sub FETCH {
  	my ($sth, $attrib) = @_;
  	# In reality this would interrogate the database engine to
  	# either return dynamic values that cannot be precomputed
  	# or fetch and cache attribute values too expensive to prefetch.
  	if ($attrib eq 'TYPE'){
  	    return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ];
  	}
  	elsif ($attrib eq 'PRECISION'){
  	    return [ @DBD::ExampleP::statprec{  @{ $sth->FETCH(q{NAME_lc}) } } ];
  	}
  	elsif ($attrib eq 'ParamValues') {
  	    my $dbd_param = $sth->{dbd_param} || [];
  	    my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param;
  	    return \%pv;
  	}
  	# else pass up to DBI to handle
  	return $sth->SUPER::FETCH($attrib);
      }
  
  
      sub STORE {
  	my ($sth, $attrib, $value) = @_;
  	# would normally validate and only store known attributes
  	# else pass up to DBI to handle
  	return $sth->{$attrib} = $value
  	    if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION';
  	return $sth->SUPER::STORE($attrib, $value);
      }
  
      *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
  }
  
  1;
  # vim: sw=4:ts=8
DARWIN-THREAD-MULTI-2LEVEL_DBD_EXAMPLEP

$fatpacked{"darwin-thread-multi-2level/DBD/File.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_FILE';
  # -*- perl -*-
  #
  #   DBD::File - A base class for implementing DBI drivers that
  #               act on plain files
  #
  #  This module is currently maintained by
  #
  #      H.Merijn Brand & Jens Rehsack
  #
  #  The original author is Jochen Wiedmann.
  #
  #  Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack
  #  Copyright (C) 2004 by Jeff Zucker
  #  Copyright (C) 1998 by Jochen Wiedmann
  #
  #  All rights reserved.
  #
  #  You may distribute this module under the terms of either the GNU
  #  General Public License or the Artistic License, as specified in
  #  the Perl README file.
  
  require 5.005;
  
  use strict;
  
  use DBI ();
  require DBI::SQL::Nano;
  require File::Spec;
  
  package DBD::File;
  
  use strict;
  
  use Carp;
  use vars qw( @ISA $VERSION $drh $valid_attrs );
  
  $VERSION = "0.38";
  
  $drh = undef;		# holds driver handle(s) once initialised
  
  sub driver ($;$)
  {
      my ($class, $attr) = @_;
  
      # Drivers typically use a singleton object for the $drh
      # We use a hash here to have one singleton per subclass.
      # (Otherwise DBD::CSV and DBD::DBM, for example, would
      # share the same driver object which would cause problems.)
      # An alternative would be not not cache the $drh here at all
      # and require that subclasses do that. Subclasses should do
      # their own caching, so caching here just provides extra safety.
      $drh->{$class} and return $drh->{$class};
  
      DBI->setup_driver ("DBD::File"); # only needed once but harmless to repeat
      $attr ||= {};
      {	no strict "refs";
  	unless ($attr->{Attribution}) {
  	    $class eq "DBD::File" and
  		$attr->{Attribution} = "$class by Jeff Zucker";
  	    $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} ||
  		"oops the author of $class forgot to define this";
  	    }
  	$attr->{Version} ||= ${$class . "::VERSION"};
  	$attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://;
  	}
  
      $drh->{$class} = DBI::_new_drh ($class . "::dr", $attr);
      $drh->{$class}->STORE (ShowErrorStatement => 1);
      return $drh->{$class};
      } # driver
  
  sub CLONE
  {
      undef $drh;
      } # CLONE
  
  sub file2table
  {
      my ($data, $dir, $file, $file_is_tab, $quoted) = @_;
  
      $file eq "." || $file eq ".."	and return;
  
      my ($ext, $req) = ("", 0);
      if ($data->{f_ext}) {
  	($ext, my $opt) = split m/\//, $data->{f_ext};
  	if ($ext && $opt) {
  	    $opt =~ m/r/i and $req = 1;
  	    }
  	}
  
      (my $tbl = $file) =~ s/$ext$//i;
      $file_is_tab and $file = "$tbl$ext";
  
      # Fully Qualified File Name
      my $fqfn;
      unless ($quoted) { # table names are case insensitive in SQL
  	opendir my $dh, $dir or croak "Can't open '$dir': $!";
  	my @f = grep { lc $_ eq lc $file } readdir $dh;
  	@f == 1 and $file = $f[0];
  	closedir $dh or croak "Can't close '$dir': $!";
  	}
      $fqfn = File::Spec->catfile ($dir, $file);
  
      $file = $fqfn;
      if ($ext) {
  	if ($req) {
  	    # File extension required
  	    $file =~ s/$ext$//i			or  return;
  	    }
  	else {
  	    # File extension optional, skip if file with extension exists
  	    grep m/$ext$/i, glob "$fqfn.*"	and return;
  	    $file =~ s/$ext$//i;
  	    }
  	}
  
      $data->{f_map}{$tbl} = $fqfn;
      return $tbl;
      } # file2table
  
  # ====== DRIVER ================================================================
  
  package DBD::File::dr;
  
  use strict;
  
  $DBD::File::dr::imp_data_size = 0;
  
  sub connect ($$;$$$)
  {
      my ($drh, $dbname, $user, $auth, $attr)= @_;
  
      # create a 'blank' dbh
      my $this = DBI::_new_dbh ($drh, {
  	Name		=> $dbname,
  	USER		=> $user,
  	CURRENT_USER	=> $user,
  	});
  
      if ($this) {
  	my ($var, $val);
  	$this->{f_dir} = File::Spec->curdir ();
  	$this->{f_ext} = "";
  	$this->{f_map} = {};
  	while (length $dbname) {
  	    if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
  		$var    = $1;
  		}
  	    else {
  		$var    = $dbname;
  		$dbname = "";
  		}
  	    if ($var =~ m/^(.+?)=(.*)/s) {
  		$var = $1;
  		($val = $2) =~ s/\\(.)/$1/g;
  		$this->{$var} = $val;
  		}
  	    }
          $this->{f_valid_attrs} = {
  	    f_version	=> 1, # DBD::File version
  	    f_dir	=> 1, # base directory
  	    f_ext	=> 1, # file extension
  	    f_schema	=> 1, # schema name
  	    f_tables	=> 1, # base directory
  	    f_lock	=> 1, # Table locking mode
  	    f_encoding	=> 1, # Encoding of the file
  	    };
          $this->{sql_valid_attrs} = {
  	    sql_handler           => 1, # Nano or S:S
  	    sql_nano_version      => 1, # Nano version
  	    sql_statement_version => 1, # S:S version
  	    };
  	}
      $this->STORE (Active => 1);
      return set_versions ($this);
      } # connect
  
  sub set_versions
  {
      my $this = shift;
      $this->{f_version} = $DBD::File::VERSION;
      for (qw( nano_version statement_version )) {
  	# strip development release version part
  	($this->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_} || "") =~ s/_[0-9]+$//;
  	}
      $this->{sql_handler} = $this->{sql_statement_version}
  	? "SQL::Statement"
  	: "DBI::SQL::Nano";
      return $this;
      } # set_versions
  
  sub data_sources ($;$)
  {
      my ($drh, $attr) = @_;
      my $dir = $attr && exists $attr->{f_dir}
  	? $attr->{f_dir}
  	: File::Spec->curdir ();
      my ($dirh) = Symbol::gensym ();
      unless (opendir ($dirh, $dir)) {
  	$drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
  	return;
  	}
  
      my ($file, @dsns, %names, $driver);
      if ($drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i) {
  	$driver = $1;
  	}
      else {
  	$driver = "File";
  	}
  
      while (defined ($file = readdir ($dirh))) {
  	if ($^O eq "VMS") {
  	    # if on VMS then avoid warnings from catdir if you use a file
  	    # (not a dir) as the file below
  	    $file !~ m/\.dir$/oi and next;
  	    }
  	my $d = File::Spec->catdir ($dir, $file);
  	# allow current dir ... it can be a data_source too
  	$file ne File::Spec->updir () && -d $d and
  	    push @dsns, "DBI:$driver:f_dir=$d";
  	}
      return @dsns;
      } # data_sources
  
  sub disconnect_all
  {
      } # disconnect_all
  
  sub DESTROY
  {
      undef;
      } # DESTROY
  
  # ====== DATABASE ==============================================================
  
  package DBD::File::db;
  
  use strict;
  use Carp;
  
  $DBD::File::db::imp_data_size = 0;
  
  sub ping
  {
      ($_[0]->FETCH ("Active")) ? 1 : 0;
      } # ping
  
  sub prepare ($$;@)
  {
      my ($dbh, $statement, @attribs) = @_;
  
      # create a 'blank' sth
      my $sth = DBI::_new_sth ($dbh, {Statement => $statement});
  
      if ($sth) {
  	my $class = $sth->FETCH ("ImplementorClass");
  	$class =~ s/::st$/::Statement/;
  	my $stmt;
  
  	# if using SQL::Statement version > 1
  	# cache the parser object if the DBD supports parser caching
  	# SQL::Nano and older SQL::Statements don't support this
  
  	if ( $dbh->{sql_handler} eq "SQL::Statement" and
  	     $dbh->{sql_statement_version} > 1) {
  	    my $parser = $dbh->{csv_sql_parser_object};
  	    $parser ||= eval { $dbh->func ("csv_cache_sql_parser_object") };
  	    if ($@) {
  		$stmt = eval { $class->new ($statement) };
  		}
  	    else {
  		$stmt = eval { $class->new ($statement, $parser) };
  		}
  	    }
  	else {
  	    $stmt = eval { $class->new ($statement) };
  	    }
  	if ($@) {
  	    $dbh->set_err ($DBI::stderr, $@);
  	    undef $sth;
  	    }
  	else {
  	    $sth->STORE ("f_stmt", $stmt);
  	    $sth->STORE ("f_params", []);
  	    $sth->STORE ("NUM_OF_PARAMS", scalar ($stmt->params ()));
  	    }
  	}
      return $sth;
      } # prepare
  
  sub csv_cache_sql_parser_object
  {
      my $dbh    = shift;
      my $parser = {
  	dialect    => "CSV",
  	RaiseError => $dbh->FETCH ("RaiseError"),
  	PrintError => $dbh->FETCH ("PrintError"),
  	};
      my $sql_flags = $dbh->FETCH ("sql_flags") || {};
      %$parser = (%$parser, %$sql_flags);
      $parser = SQL::Parser->new ($parser->{dialect}, $parser);
      $dbh->{csv_sql_parser_object} = $parser;
      return $parser;
      } # csv_cache_sql_parser_object
  
  sub disconnect ($)
  {
      $_[0]->STORE (Active => 0);
      return 1;
      } # disconnect
  
  sub FETCH ($$)
  {
      my ($dbh, $attrib) = @_;
      $attrib eq "AutoCommit" and
  	return 1;
  
      if ($attrib eq (lc $attrib)) {
  	# Driver private attributes are lower cased
  
  	# Error-check for valid attributes
  	# not implemented yet, see STORE
  	#
  	return $dbh->{$attrib};
  	}
      # else pass up to DBI to handle
      return $dbh->SUPER::FETCH ($attrib);
      } # FETCH
  
  sub STORE ($$$)
  {
      my ($dbh, $attrib, $value) = @_;
  
      if ($attrib eq "AutoCommit") {
  	$value and return 1;    # is already set
  	croak "Can't disable AutoCommit";
  	}
  
      if ($attrib eq lc $attrib) {
  	# Driver private attributes are lower cased
  
  	# I'm not implementing this yet because other drivers may be
  	# setting f_ and sql_ attrs I don't know about
  	# I'll investigate and publicize warnings to DBD authors
  	# then implement this
  
  	# return to implementor if not f_ or sql_
  	# not implemented yet
  	# my $class = $dbh->FETCH ("ImplementorClass");
  	#
  	# !$dbh->{f_valid_attrs}{$attrib} && !$dbh->{sql_valid_attrs}{$attrib} and
  	#    return $dbh->set_err ($DBI::stderr, "Invalid attribute '$attrib'");
  	#  $dbh->{$attrib} = $value;
  
  	if ($attrib eq "f_dir") {
  	    -d $value or
  		return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
  	    }
  	if ($attrib eq "f_ext") {
  	    $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
  		carp "'$value' doesn't look like a valid file extension attribute\n";
  	    }
  	$dbh->{$attrib} = $value;
  	return 1;
  	}
      return $dbh->SUPER::STORE ($attrib, $value);
      } # STORE
  
  sub DESTROY ($)
  {
      my $dbh = shift;
      $dbh->SUPER::FETCH ("Active") and $dbh->disconnect ;
      undef $dbh->{csv_sql_parser_object};
      } # DESTROY
  
  sub type_info_all ($)
  {
      [ { TYPE_NAME          => 0,
  	DATA_TYPE          => 1,
  	PRECISION          => 2,
  	LITERAL_PREFIX     => 3,
  	LITERAL_SUFFIX     => 4,
  	CREATE_PARAMS      => 5,
  	NULLABLE           => 6,
  	CASE_SENSITIVE     => 7,
  	SEARCHABLE         => 8,
  	UNSIGNED_ATTRIBUTE => 9,
  	MONEY              => 10,
  	AUTO_INCREMENT     => 11,
  	LOCAL_TYPE_NAME    => 12,
  	MINIMUM_SCALE      => 13,
  	MAXIMUM_SCALE      => 14,
  	},
        [ "VARCHAR",	DBI::SQL_VARCHAR (),
  	undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
  	],
        [ "CHAR",		DBI::SQL_CHAR (),
  	undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
  	],
        [ "INTEGER",	DBI::SQL_INTEGER (),
  	undef, "",  "",  undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
  	],
        [ "REAL",		DBI::SQL_REAL (),
  	undef, "",  "",  undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
  	],
        [ "BLOB",		DBI::SQL_LONGVARBINARY (),
  	undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
  	],
        [ "BLOB",		DBI::SQL_LONGVARBINARY (),
  	undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
  	],
        [ "TEXT",		DBI::SQL_LONGVARCHAR (),
  	undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
  	]];
      } # type_info_all
  
  {   my $names = [
  	qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )];
  
      sub table_info ($)
      {
  	my $dbh  = shift;
  	my $dir  = $dbh->{f_dir};
  	my $dirh = Symbol::gensym ();
  
  	unless (opendir $dirh, $dir) {
  	    $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
  	    return;
  	    }
  
  	my ($file, @tables, %names);
  	my $schema = exists $dbh->{f_schema}
  	    ? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
  		? $dbh->{f_schema} : undef
  	    : eval { getpwuid ((stat $dir)[4]) };
  	while (defined ($file = readdir ($dirh))) {
  	    my $tbl = DBD::File::file2table ($dbh, $dir, $file, 0, 0) or next;
  	    push @tables, [ undef, $schema, $tbl, "TABLE", undef ];
  	    }
  	unless (closedir $dirh) {
  	    $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
  	    return;
  	    }
  
  	my $dbh2 = $dbh->{csv_sponge_driver};
  	unless ($dbh2) {
  	    $dbh2 = $dbh->{csv_sponge_driver} = DBI->connect ("DBI:Sponge:");
  	    unless ($dbh2) {
  		$dbh->set_err ($DBI::stderr, $DBI::errstr);
  		return;
  		}
  	    }
  
  	# Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
  	@tables or return;
  
  	my $sth = $dbh2->prepare ("TABLE_INFO", {
  				    rows  => \@tables,
  				    NAMES => $names,
  				    });
  	$sth or $dbh->set_err ($DBI::stderr, $dbh2->errstr);
  	return $sth;
  	} # table_info
      }
  
  sub list_tables ($)
  {
      my $dbh = shift;
      my ($sth, @tables);
      $sth = $dbh->table_info () or return;
      while (my $ref = $sth->fetchrow_arrayref ()) {
  	push @tables, $ref->[2];
  	}
      return @tables;
      } # list_tables
  
  sub quote ($$;$)
  {
      my ($self, $str, $type) = @_;
      defined $str or return "NULL";
      defined $type && (
  	    $type == DBI::SQL_NUMERIC  ()
  	 || $type == DBI::SQL_DECIMAL  ()
  	 || $type == DBI::SQL_INTEGER  ()
  	 || $type == DBI::SQL_SMALLINT ()
  	 || $type == DBI::SQL_FLOAT    ()
  	 || $type == DBI::SQL_REAL     ()
  	 || $type == DBI::SQL_DOUBLE   ()
  	 || $type == DBI::SQL_TINYINT  ())
  	and return $str;
  
      $str =~ s/\\/\\\\/sg;
      $str =~ s/\0/\\0/sg;
      $str =~ s/\'/\\\'/sg;
      $str =~ s/\n/\\n/sg;
      $str =~ s/\r/\\r/sg;
      return "'$str'";
      } # quote
  
  sub commit ($)
  {
      my $dbh = shift;
      $dbh->FETCH ("Warn") and
  	carp "Commit ineffective while AutoCommit is on", -1;
      return 1;
      } # commit
  
  sub rollback ($)
  {
      my $dbh = shift;
      $dbh->FETCH ("Warn") and
  	carp "Rollback ineffective while AutoCommit is on", -1;
      return 0;
      } # rollback
  
  # ====== STATEMENT =============================================================
  
  package DBD::File::st;
  
  use strict;
  
  $DBD::File::st::imp_data_size = 0;
  
  sub bind_param ($$$;$)
  {
      my ($sth, $pNum, $val, $attr) = @_;
      if ($attr && defined $val) {
  	my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr;
  	if (   $attr == DBI::SQL_BIGINT   ()
  	    || $attr == DBI::SQL_INTEGER  ()
  	    || $attr == DBI::SQL_SMALLINT ()
  	    || $attr == DBI::SQL_TINYINT  ()
  	       ) {
  	    $val += 0;
  	    }
  	elsif ($attr == DBI::SQL_DECIMAL ()
  	    || $attr == DBI::SQL_DOUBLE  ()
  	    || $attr == DBI::SQL_FLOAT   ()
  	    || $attr == DBI::SQL_NUMERIC ()
  	    || $attr == DBI::SQL_REAL    ()
  	       ) {
  	    $val += 0.;
  	    }
  	else {
  	    $val = "$val";
  	    }
  	}
      $sth->{f_params}[$pNum - 1] = $val;
      return 1;
      } # bind_param
  
  sub execute
  {
      my $sth = shift;
      my $params = @_ ? ($sth->{f_params} = [ @_ ]) : $sth->{f_params};
  
      $sth->finish;
      my $stmt = $sth->{f_stmt};
      unless ($sth->{f_params_checked}++) {
  	# bug in SQL::Statement 1.20 and below causes breakage
  	# on all but the first call
  	unless ((my $req_prm = $stmt->params ()) == (my $nparm = @$params)) {
  	    my $msg = "You passed $nparm parameters where $req_prm required";
  	    $sth->set_err ($DBI::stderr, $msg);
  	    return;
  	    }
  	}
      my @err;
      my $result = eval {
  	local $SIG{__WARN__} = sub { push @err, @_ };
  	$stmt->execute ($sth, $params);
  	};
      if ($@ || @err) {
  	$sth->set_err ($DBI::stderr, $@ || $err[0]);
  	return undef;
  	}
  
      if ($stmt->{NUM_OF_FIELDS}) {    # is a SELECT statement
  	$sth->STORE (Active => 1);
  	$sth->FETCH ("NUM_OF_FIELDS") or
  	    $sth->STORE ("NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS});
  	}
      return $result;
      } # execute
  
  sub finish
  {
      my $sth = shift;
      $sth->SUPER::STORE (Active => 0);
      delete $sth->{f_stmt}{data};
      return 1;
      } # finish
  
  sub fetch ($)
  {
      my $sth  = shift;
      my $data = $sth->{f_stmt}{data};
      if (!$data || ref $data ne "ARRAY") {
  	$sth->set_err ($DBI::stderr,
  	    "Attempt to fetch row without a preceeding execute () call or from a non-SELECT statement"
  	    );
  	return;
  	}
      my $dav = shift @$data;
      unless ($dav) {
  	$sth->finish;
  	return;
  	}
      if ($sth->FETCH ("ChopBlanks")) {
  	$_ && $_ =~ s/\s+$// for @$dav;
  	}
      return $sth->_set_fbav ($dav);
      } # fetch
  *fetchrow_arrayref = \&fetch;
  
  my %unsupported_attrib = map { $_ => 1 } qw( TYPE PRECISION );
  
  sub FETCH ($$)
  {
      my ($sth, $attrib) = @_;
      exists $unsupported_attrib{$attrib}
  	and return undef;    # Workaround for a bug in DBI 0.93
      $attrib eq "NAME" and
  	return $sth->FETCH ("f_stmt")->{NAME};
      if ($attrib eq "NULLABLE") {
  	my ($meta) = $sth->FETCH ("f_stmt")->{NAME};    # Intentional !
  	$meta or return undef;
  	return [ (1) x @$meta ];
  	}
      if ($attrib eq lc $attrib) {
  	# Private driver attributes are lower cased
  	return $sth->{$attrib};
  	}
      # else pass up to DBI to handle
      return $sth->SUPER::FETCH ($attrib);
      } # FETCH
  
  sub STORE ($$$)
  {
      my ($sth, $attrib, $value) = @_;
      exists $unsupported_attrib{$attrib}
  	and return;    # Workaround for a bug in DBI 0.93
      if ($attrib eq lc $attrib) {
  	# Private driver attributes are lower cased
  	$sth->{$attrib} = $value;
  	return 1;
  	}
      return $sth->SUPER::STORE ($attrib, $value);
      } # STORE
  
  sub DESTROY ($)
  {
      my $sth = shift;
      $sth->SUPER::FETCH ("Active") and $sth->finish;
      undef $sth->{f_stmt};
      undef $sth->{f_params};
      } # DESTROY
  
  sub rows ($)
  {
      return $_[0]->{f_stmt}{NUM_OF_ROWS};
      } # rows
  
  package DBD::File::Statement;
  
  use strict;
  use Carp;
  
  # We may have a working flock () built-in but that doesn't mean that locking
  # will work on NFS (flock () may hang hard)
  my $locking = eval { flock STDOUT, 0; 1 };
  
  # Jochen's old check for flock ()
  #
  # my $locking = $^O ne "MacOS"  &&
  #              ($^O ne "MSWin32" || !Win32::IsWin95 ())  &&
  #               $^O ne "VMS";
  
  @DBD::File::Statement::ISA = qw( DBI::SQL::Nano::Statement );
  
  my $open_table_re = sprintf "(?:%s|%s|%s)",
  	quotemeta (File::Spec->curdir  ()),
  	quotemeta (File::Spec->updir   ()),
  	quotemeta (File::Spec->rootdir ());
  
  sub get_file_name ($$$)
  {
      my ($self, $data, $table) = @_;
      my $quoted = 0;
      $table =~ s/^\"// and $quoted = 1;    # handle quoted identifiers
      $table =~ s/\"$//;
      my $file = $table;
      if (    $file !~ m/^$open_table_re/o
  	and $file !~ m{^[/\\]}      # root
  	and $file !~ m{^[a-z]\:}    # drive letter
  	) {
  	exists $data->{Database}{f_map}{$table} or
  	    DBD::File::file2table ($data->{Database},
  		$data->{Database}{f_dir}, $file, 1, $quoted);
  	$file = $data->{Database}{f_map}{$table} || undef;
  	}
      return ($table, $file);
      } # get_file_name
  
  sub open_table ($$$$$)
  {
      my ($self, $data, $table, $createMode, $lockMode) = @_;
      my $file;
      ($table, $file) = $self->get_file_name ($data, $table);
      defined $file && $file ne "" or croak "No filename given";
      require IO::File;
      my $fh;
      my $safe_drop = $self->{ignore_missing_table} ? 1 : 0;
      if ($createMode) {
  	-f $file and
  	    croak "Cannot create table $table: Already exists";
  	$fh = IO::File->new ($file, "a+") or
  	    croak "Cannot open $file for writing: $!";
  	$fh->seek (0, 0) or
  	    croak "Error while seeking back: $!";
  	}
      else {
  	unless ($fh = IO::File->new ($file, ($lockMode ? "r+" : "r"))) {
  	    $safe_drop or croak "Cannot open $file: $!";
  	    }
  	}
      if ($fh) {
  	if (my $enc = $data->{Database}{f_encoding}) {
  	    binmode $fh, ":encoding($enc)" or
                  croak "Failed to set encoding layer '$enc' on $file: $!";
  	    }
  	else {
  	    binmode $fh or croak "Failed to set binary mode on $file: $!";
  	    }
  	}
      if ($locking and $fh) {
  	my $lm = defined $data->{Database}{f_lock}
  		      && $data->{Database}{f_lock} =~ m/^[012]$/
  		       ? $data->{Database}{f_lock}
  		       : $lockMode ? 2 : 1;
  	if ($lm == 2) {
  	    flock $fh, 2 or croak "Cannot obtain exclusive lock on $file: $!";
  	    }
  	elsif ($lm == 1) {
  	    flock $fh, 1 or croak "Cannot obtain shared lock on $file: $!";
  	    }
  	# $lm = 0 is forced no locking at all
  	}
      my $columns = {};
      my $array   = [];
      my $pos     = $fh ? $fh->tell () : undef;
      my $tbl     = {
  	file          => $file,
  	fh            => $fh,
  	col_nums      => $columns,
  	col_names     => $array,
  	first_row_pos => $pos,
  	};
      my $class = ref $self;
      $class =~ s/::Statement/::Table/;
      bless $tbl, $class;
      return $tbl;
      } # open_table
  
  package DBD::File::Table;
  
  use strict;
  use Carp;
  
  @DBD::File::Table::ISA = qw(DBI::SQL::Nano::Table);
  
  sub drop ($)
  {
      my $self = shift;
      # We have to close the file before unlinking it: Some OS'es will
      # refuse the unlink otherwise.
      $self->{fh} and $self->{fh}->close ();
      unlink $self->{file};
      return 1;
      } # drop
  
  sub seek ($$$$)
  {
      my ($self, $data, $pos, $whence) = @_;
      if ($whence == 0 && $pos == 0) {
  	$pos = $self->{first_row_pos};
  	}
      elsif ($whence != 2 || $pos != 0) {
  	croak "Illegal seek position: pos = $pos, whence = $whence";
  	}
  
      $self->{fh}->seek ($pos, $whence) or
  	croak "Error while seeking in " . $self->{file} . ": $!";
      } # seek
  
  sub truncate ($$)
  {
      my ($self, $data) = @_;
      $self->{fh}->truncate ($self->{fh}->tell ()) or
  	croak "Error while truncating " . $self->{file} . ": $!";
      return 1;
      } # truncate
  
  1;
  
  __END__
  
  =head1 NAME
  
  DBD::File - Base class for writing DBI drivers
  
  =head1 SYNOPSIS
  
   This module is a base class for writing other DBDs.
   It is not intended to function as a DBD itself.
   If you want to access flatfiles, use DBD::AnyData, or DBD::CSV,
   (both of which are subclasses of DBD::File).
  
  =head1 DESCRIPTION
  
  The DBD::File module is not a true DBI driver, but an abstract
  base class for deriving concrete DBI drivers from it. The implication is,
  that these drivers work with plain files, for example CSV files or
  INI files. The module is based on the SQL::Statement module, a simple
  SQL engine.
  
  See L<DBI> for details on DBI, L<SQL::Statement> for details on
  SQL::Statement and L<DBD::CSV> or L<DBD::IniFile> for example
  drivers.
  
  =head2 Metadata
  
  The following attributes are handled by DBI itself and not by DBD::File,
  thus they all work like expected:
  
      Active
      ActiveKids
      CachedKids
      CompatMode             (Not used)
      InactiveDestroy
      Kids
      PrintError
      RaiseError
      Warn                   (Not used)
  
  The following DBI attributes are handled by DBD::File:
  
  =over 4
  
  =item AutoCommit
  
  Always on
  
  =item ChopBlanks
  
  Works
  
  =item NUM_OF_FIELDS
  
  Valid after C<< $sth->execute >>
  
  =item NUM_OF_PARAMS
  
  Valid after C<< $sth->prepare >>
  
  =item NAME
  
  Valid after C<< $sth->execute >>; undef for Non-Select statements.
  
  =item NULLABLE
  
  Not really working, always returns an array ref of one's, as DBD::CSV
  doesn't verify input data. Valid after C<< $sth->execute >>; undef for
  Non-Select statements.
  
  =back
  
  These attributes and methods are not supported:
  
      bind_param_inout
      CursorName
      LongReadLen
      LongTruncOk
  
  Additional to the DBI attributes, you can use the following dbh
  attribute:
  
  =over 4
  
  =item f_dir
  
  This attribute is used for setting the directory where CSV files are
  opened. Usually you set it in the dbh, it defaults to the current
  directory ("."). However, it is overwritable in the statement handles.
  
  =item f_ext
  
  This attribute is used for setting the file extension where (CSV) files are
  opened. There are several possibilities.
  
      DBI:CSV:f_dir=data;f_ext=.csv
  
  In this case, DBD::File will open only C<table.csv> if both C<table.csv> and
  C<table> exist in the datadir. The table will still be named C<table>. If
  your datadir has files with extensions, and you do not pass this attribute,
  your table is named C<table.csv>, which is probably not what you wanted. The
  extension is always case-insensitive. The table names are not.
  
      DBI:CSV:f_dir=data;f_ext=.csv/r
  
  In this case the extension is required, and all filenames that do not match
  are ignored.
  
  =item f_schema
  
  This will set the schema name. Default is the owner of the folder in which
  the table file resides.  C<undef> is allowed.
  
      my $dbh = DBI->connect ("dbi:CSV:", "", "", {
          f_schema => undef,
          f_dir    => "data",
          f_ext    => ".csv/r",
          }) or die $DBI::errstr;
  
  The effect is that when you get table names from DBI, you can force all
  tables into the same (or no) schema:
  
      my @tables $dbh->tables ();
  
      # no f_schema
      "merijn".foo
      "merijn".bar
  
      # f_schema => "dbi"
      "dbi".foo
      "dbi".bar
  
      # f_schema => undef
      foo
      bar
  
  Defining f_schema to the empty string is equal to setting it to C<undef>,
  this to enable the DSN to be C<dbi:CSV:f_schema=;f_dir=.>.
  
  =item f_lock
  
  With this attribute, you can force locking mode (if locking is supported
  at all) for opening tables. By default, tables are opened with a shared
  lock for reading, and with an exclusive lock for writing. The supported
  modes are:
  
  =over 2
  
  =item 0
  
  Force no locking at all.
  
  =item 1
  
  Only shared locks will be used.
  
  =item 2
  
  Only exclusive locks will be used.
  
  =back
  
  But see L</"NOWN BUGS"> below.
  
  =item f_encoding
  
  With this attribute, you can set the encoding in which the file is opened.
  This is implemented using C<binmode $fh, ":encoding(<f_encoding>)">.
  
  =back
  
  =head2 Driver private methods
  
  =over 4
  
  =item data_sources
  
  The C<data_sources> method returns a list of subdirectories of the current
  directory in the form "DBI:CSV:f_dir=$dirname".
  
  If you want to read the subdirectories of another directory, use
  
      my ($drh) = DBI->install_driver ("CSV");
      my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data" );
  
  =item list_tables
  
  This method returns a list of file names inside $dbh->{f_dir}.
  Example:
  
      my ($dbh) = DBI->connect ("DBI:CSV:f_dir=/usr/local/csv_data");
      my (@list) = $dbh->func ("list_tables");
  
  Note that the list includes all files contained in the directory, even
  those that have non-valid table names, from the view of SQL.
  
  =back
  
  =head1 KNOWN BUGS
  
  =over 8
  
  =item *
  
  The module is using flock () internally. However, this function is not
  available on all platforms. Using flock () is disabled on MacOS and
  Windows 95: There's no locking at all (perhaps not so important on
  MacOS and Windows 95, as there's a single user anyways).
  
  =back
  
  =head1 AUTHOR
  
  This module is currently maintained by
  
  H.Merijn Brand < h.m.brand at xs4all.nl > and
  Jens Rehsack  < rehsack at googlemail.com >
  
  The original author is Jochen Wiedmann.
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2009 by H.Merijn Brand & Jens Rehsack
  Copyright (C) 2004 by Jeff Zucker
  Copyright (C) 1998 by Jochen Wiedmann
  
  All rights reserved.
  
  You may freely distribute and/or modify this module under the terms of
  either the GNU General Public License (GPL) or the Artistic License, as
  specified in the Perl README file.
  
  =head1 SEE ALSO
  
  L<DBI>, L<Text::CSV>, L<Text::CSV_XS>, L<SQL::Statement>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_FILE

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER';
  {
      package DBD::Gofer;
  
      use strict;
  
      require DBI;
      require DBI::Gofer::Request;
      require DBI::Gofer::Response;
      require Carp;
  
      our $VERSION = sprintf("0.%06d", q$Revision: 13773 $ =~ /(\d+)/o);
  
  #   $Id: Gofer.pm 13773 2010-01-28 10:39:50Z hmbrand $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  
  
      # attributes we'll allow local STORE
      our %xxh_local_store_attrib = map { $_=>1 } qw(
          Active
          CachedKids
          Callbacks
          DbTypeSubclass
          ErrCount Executed
          FetchHashKeyName
          HandleError HandleSetErr
          InactiveDestroy
          PrintError PrintWarn
          Profile
          RaiseError
          RootClass
          ShowErrorStatement
          Taint TaintIn TaintOut
          TraceLevel
          Warn
          dbi_quote_identifier_cache
          dbi_connect_closure
          dbi_go_execute_unique
      );
      our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw(
          Username
          dbi_connect_method
      );
  
      our $drh = undef;    # holds driver handle once initialized
      our $methods_already_installed;
  
      sub driver{
          return $drh if $drh;
  
          DBI->setup_driver('DBD::Gofer');
  
          unless ($methods_already_installed++) {
              my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR
              DBD::Gofer::db->install_method('go_dbh_method', $opts);
              DBD::Gofer::st->install_method('go_sth_method', $opts);
              DBD::Gofer::st->install_method('go_clone_sth',  $opts);
              DBD::Gofer::db->install_method('go_cache',      $opts);
              DBD::Gofer::st->install_method('go_cache',      $opts);
          }
  
          my($class, $attr) = @_;
          $class .= "::dr";
          ($drh) = DBI::_new_drh($class, {
              'Name' => 'Gofer',
              'Version' => $VERSION,
              'Attribution' => 'DBD Gofer by Tim Bunce',
          });
  
          $drh;
      }
  
  
      sub CLONE {
          undef $drh;
      }
  
  
      sub go_cache {
          my $h = shift;
          $h->{go_cache} = shift if @_;
          # return handle's override go_cache, if it has one
          return $h->{go_cache} if defined $h->{go_cache};
          # or else the transports default go_cache
          return $h->{go_transport}->{go_cache};
      }
  
  
      sub set_err_from_response { # set error/warn/info and propagate warnings
          my $h = shift;
          my $response = shift;
          if (my $warnings = $response->warnings) {
              warn $_ for @$warnings;
          }
          return $h->set_err($response->err_errstr_state);
      }
  
  
      sub install_methods_proxy {
          my ($installed_methods) = @_;
          while ( my ($full_method, $attr) = each %$installed_methods ) {
              # need to install both a DBI dispatch stub and a proxy stub
              # (the dispatch stub may be already here due to local driver use)
  
              DBI->_install_method($full_method, "", $attr||{})
                  unless defined &{$full_method};
  
              # now install proxy stubs on the driver side
              $full_method =~ m/^DBI::(\w\w)::(\w+)$/
                  or die "Invalid method name '$full_method' for install_method";
              my ($type, $method) = ($1, $2);
              my $driver_method = "DBD::Gofer::${type}::${method}";
              next if defined &{$driver_method};
              my $sub;
              if ($type eq 'db') {
                  $sub = sub { return shift->go_dbh_method(undef, $method, @_) };
              }
              else {
                  $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; };
              }
              no strict 'refs';
              *$driver_method = $sub;
          }
      }
  }
  
  
  {   package DBD::Gofer::dr; # ====== DRIVER ======
  
      $imp_data_size = 0;
      use strict;
  
      sub connect_cached {
          my ($drh, $dsn, $user, $auth, $attr)= @_;
          $attr ||= {};
          return $drh->SUPER::connect_cached($dsn, $user, $auth, {
              (%$attr),
              go_connect_method => $attr->{go_connect_method} || 'connect_cached',
          });
      }
  
  
      sub connect {
          my($drh, $dsn, $user, $auth, $attr)= @_;
          my $orig_dsn = $dsn;
  
          # first remove dsn= and everything after it
          my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1)
              or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'");
  
          if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection
              # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t
              return DBI->connect($remote_dsn, $user, $auth, $attr);
          }
  
          my %go_attr;
          # extract any go_ attributes from the connect() attr arg
          for my $k (grep { /^go_/ } keys %$attr) {
              $go_attr{$k} = delete $attr->{$k};
          }
          # then override those with any attributes embedded in our dsn (not remote_dsn)
          for my $kv (grep /=/, split /;/, $dsn, -1) {
              my ($k, $v) = split /=/, $kv, 2;
              $go_attr{ "go_$k" } = $v;
          }
  
          if (not ref $go_attr{go_policy}) { # if not a policy object already
              my $policy_class = $go_attr{go_policy} || 'classic';
              $policy_class = "DBD::Gofer::Policy::$policy_class"
                  unless $policy_class =~ /::/;
              _load_class($policy_class)
                  or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@");
              # replace policy name in %go_attr with policy object
              $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) }
                  or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@");
          }
          # policy object is left in $go_attr{go_policy} so transport can see it
          my $go_policy = $go_attr{go_policy};
  
          if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already
              my $cache_class = $go_attr{go_cache};
              $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1';
              _load_class($cache_class)
                  or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@");
              $go_attr{go_cache} = eval { $cache_class->new() }
                  or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning
          }
  
          # delete any other attributes that don't apply to transport
          my $go_connect_method = delete $go_attr{go_connect_method};
  
          my $transport_class = delete $go_attr{go_transport}
              or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'");
          $transport_class = "DBD::Gofer::Transport::$transport_class"
              unless $transport_class =~ /::/;
          _load_class($transport_class)
              or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@");
          my $go_transport = eval { $transport_class->new(\%go_attr) }
              or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@");
  
          my $request_class = "DBI::Gofer::Request";
          my $go_request = eval {
              my $go_attr = { %$attr };
              # XXX user/pass of fwd server vs db server ? also impact of autoproxy
              if ($user) {
                  $go_attr->{Username} = $user;
                  $go_attr->{Password} = $auth;
              }
              # delete any attributes we can't serialize (or don't want to)
              delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)};
              # delete any attributes that should only apply to the client-side
              delete @{$go_attr}{qw(RootClass DbTypeSubclass)};
  
              $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect';
              $request_class->new({
                  dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ],
              })
          } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@");
  
          my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
              'Name' => $dsn,
              'USER' => $user,
              go_transport => $go_transport,
              go_request => $go_request,
              go_policy => $go_policy,
          });
  
          # mark as inactive temporarily for STORE. Active not set until connected() called.
          $dbh->STORE(Active => 0);
  
          # should we ping to check the connection
          # and fetch dbh attributes
          my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh);
          if (not $skip_connect_check) {
              if (not $dbh->go_dbh_method(undef, 'ping')) {
                  return undef if $dbh->err; # error already recorded, typically
                  return $dbh->set_err($DBI::stderr, "ping failed");
              }
          }
  
          return $dbh;
      }
  
      sub _load_class { # return true or false+$@
          my $class = shift;
          (my $pm = $class) =~ s{::}{/}g;
          $pm .= ".pm";
          return 1 if eval { require $pm };
          delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough
          undef; # error in $@
      }
  
  }
  
  
  {   package DBD::Gofer::db; # ====== DATABASE ======
      $imp_data_size = 0;
      use strict;
      use Carp qw(carp croak);
  
      my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib;
  
      sub connected {
          shift->STORE(Active => 1);
      }
  
      sub go_dbh_method {
          my $dbh = shift;
          my $meta = shift;
          # @_ now contains ($method_name, @args)
  
          my $request = $dbh->{go_request};
          $request->init_request([ wantarray, @_ ], $dbh);
          ++$dbh->{go_request_count};
  
          my $go_policy = $dbh->{go_policy};
          my $dbh_attribute_update = $go_policy->dbh_attribute_update();
          $request->dbh_attributes( $go_policy->dbh_attribute_list() )
              if $dbh_attribute_update eq 'every'
              or $dbh->{go_request_count}==1;
  
          $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args})
              if $meta->{go_last_insert_id_args};
  
          my $transport = $dbh->{go_transport}
              or return $dbh->set_err($DBI::stderr, "Not connected (no transport)");
  
          local $transport->{go_cache} = $dbh->{go_cache}
              if defined $dbh->{go_cache};
  
          my ($response, $retransmit_sub) = $transport->transmit_request($request);
          $response ||= $transport->receive_response($request, $retransmit_sub);
          $dbh->{go_response} = $response
              or die "No response object returned by $transport";
  
          die "response '$response' returned by $transport is not a response object"
              unless UNIVERSAL::isa($response,"DBI::Gofer::Response");
  
          if (my $dbh_attributes = $response->dbh_attributes) {
  
              # XXX installed_methods piggbacks on dbh_attributes for now
              if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) {
                  DBD::Gofer::install_methods_proxy($installed_methods)
                      if $dbh->{go_request_count}==1;
              }
  
              # XXX we don't STORE here, we just stuff the value into the attribute cache
              $dbh->{$_} = $dbh_attributes->{$_}
                  for keys %$dbh_attributes;
          }
  
          my $rv = $response->rv;
          if (my $resultset_list = $response->sth_resultsets) {
              # dbh method call returned one or more resultsets
              # (was probably a metadata method like table_info)
              #
              # setup an sth but don't execute/forward it
              my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 });
              # set the sth response to our dbh response
              (tied %$sth)->{go_response} = $response;
              # setup the sth with the results in our response
              $sth->more_results;
              # and return that new sth as if it came from original request
              $rv = [ $sth ];
          }
          elsif (!$rv) { # should only occur for major transport-level error
              #carp("no rv in response { @{[ %$response ]} }");
              $rv = [ ];
          }
  
          DBD::Gofer::set_err_from_response($dbh, $response);
  
          return (wantarray) ? @$rv : $rv->[0];
      }
  
  
      # Methods that should be forwarded but can be cached
      for my $method (qw(
          tables table_info column_info primary_key_info foreign_key_info statistics_info
          data_sources type_info_all get_info
          parse_trace_flags parse_trace_flag
          func
      )) {
          my $policy_name = "cache_$method";
          my $super_name  = "SUPER::$method";
          my $sub = sub {
              my $dbh = shift;
              my $rv;
  
              # if we know the remote side doesn't override the DBI's default method
              # then we might as well just call the DBI's default method on the client
              # (which may, in turn, call other methods that are forwarded, like get_info)
              if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) {
                  $dbh->trace_msg("    !! $method: using local default as remote method is also default\n");
                  return $dbh->$super_name(@_);
              }
  
              my $cache;
              my $cache_key;
              if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) {
                  $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache
                  $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0,
                      join(",\t", map { # XXX basic but sufficient for now
                           !ref($_)            ? DBI::neat($_,1e6)
                          : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001")
                          : ref($_) eq 'HASH'  ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") }
                          : do { warn "unhandled argument type ($_)"; $_ }
                      } @_);
                  if ($rv = $cache->{$cache_key}) {
                      $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4);
                      my @cache_rv = @$rv;
                      # if it's an sth we have to clone it
                      $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st');
                      return (wantarray) ? @cache_rv : $cache_rv[0];
                  }
              }
  
              $rv = [ (wantarray)
                  ?       ($dbh->go_dbh_method(undef, $method, @_))
                  : scalar $dbh->go_dbh_method(undef, $method, @_)
              ];
  
              if ($cache) {
                  $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4);
                  my @cache_rv = @$rv;
                  # if it's an sth we have to clone it
                  #$cache_rv[0] = $cache_rv[0]->go_clone_sth
                  #   if UNIVERSAL::isa($cache_rv[0],'DBI::st');
                  $cache->{$cache_key} = \@cache_rv
                      unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done
              }
  
              return (wantarray) ? @$rv : $rv->[0];
          };
          no strict 'refs';
          *$method = $sub;
      }
  
  
      # Methods that can use the DBI defaults for some situations/drivers
      for my $method (qw(
          quote quote_identifier
      )) {    # XXX keep DBD::Gofer::Policy::Base in sync
          my $policy_name = "locally_$method";
          my $super_name  = "SUPER::$method";
          my $sub = sub {
              my $dbh = shift;
  
              # if we know the remote side doesn't override the DBI's default method
              # then we might as well just call the DBI's default method on the client
              # (which may, in turn, call other methods that are forwarded, like get_info)
              if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) {
                  $dbh->trace_msg("    !! $method: using local default as remote method is also default\n");
                  return $dbh->$super_name(@_);
              }
  
              # false:    use remote gofer
              # 1:        use local DBI default method
              # code ref: use the code ref
              my $locally = $dbh->{go_policy}->$policy_name($dbh, @_);
              if ($locally) {
                  return $locally->($dbh, @_) if ref $locally eq 'CODE';
                  return $dbh->$super_name(@_);
              }
              return $dbh->go_dbh_method(undef, $method, @_); # propagate context
          };
          no strict 'refs';
          *$method = $sub;
      }
  
  
      # Methods that should always fail
      for my $method (qw(
          begin_work commit rollback
      )) {
          no strict 'refs';
          *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") }
      }
  
  
      sub do {
          my ($dbh, $sql, $attr, @args) = @_;
          delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted"
          $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement
          my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} };
          return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args);
      }
  
      sub ping {
          my $dbh = shift;
          return $dbh->set_err(0, "can't ping while not connected") # warning
              unless $dbh->SUPER::FETCH('Active');
          my $skip_ping = $dbh->{go_policy}->skip_ping();
          return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_);
      }
  
      sub last_insert_id {
          my $dbh = shift;
          my $response = $dbh->{go_response} or return undef;
          return $response->last_insert_id;
      }
  
      sub FETCH {
          my ($dbh, $attrib) = @_;
  
          # FETCH is effectively already cached because the DBI checks the
          # attribute cache in the handle before calling FETCH
          # and this FETCH copies the value into the attribute cache
  
          # forward driver-private attributes (except ours)
          if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) {
              my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib);
              $dbh->{$attrib} = $value; # XXX forces caching by DBI
              return $dbh->{$attrib} = $value;
          }
  
          # else pass up to DBI to handle
          return $dbh->SUPER::FETCH($attrib);
      }
  
      sub STORE {
          my ($dbh, $attrib, $value) = @_;
          if ($attrib eq 'AutoCommit') {
              croak "Can't enable transactions when using DBD::Gofer" if !$value;
              return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900);
          }
          return $dbh->SUPER::STORE($attrib => $value)
              # we handle this attribute locally
              if $dbh_local_store_attrib{$attrib}
              # or it's a private_ (application) attribute
              or $attrib =~ /^private_/
              # or not yet connected (ie being called by DBI->connect)
              or not $dbh->FETCH('Active');
  
          return $dbh->SUPER::STORE($attrib => $value)
              if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib}
              && do { # values are the same
                  my $crnt = $dbh->FETCH($attrib);
                  local $^W;
                  (defined($value) ^ defined($crnt))
                      ? 0 # definedness differs
                      : $value eq $crnt;
              };
  
          # dbh attributes are set at connect-time - see connect()
          carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn');
          return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer");
      }
  
      sub disconnect {
          my $dbh = shift;
          $dbh->{go_transport} = undef;
          $dbh->STORE(Active => 0);
      }
  
      sub prepare {
          my ($dbh, $statement, $attr)= @_;
  
          return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected")
              unless $dbh->FETCH('Active');
  
          $attr = { %$attr } if $attr; # copy so we can edit
  
          my $policy     = delete($attr->{go_policy}) || $dbh->{go_policy};
          my $lii_args   = delete $attr->{go_last_insert_id_args};
          my $go_prepare = delete($attr->{go_prepare_method})
                        || $dbh->{go_prepare_method}
                        || $policy->prepare_method($dbh, $statement, $attr)
                        || 'prepare'; # e.g. for code not using placeholders
          my $go_cache = delete $attr->{go_cache};
          # set to undef if there are no attributes left for the actual prepare call
          $attr = undef if $attr and not %$attr;
  
          my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
              Statement => $statement,
              go_prepare_call => [ 0, $go_prepare, $statement, $attr ],
              # go_method_calls => [], # autovivs if needed
              go_request => $dbh->{go_request},
              go_transport => $dbh->{go_transport},
              go_policy => $policy,
              go_last_insert_id_args => $lii_args,
              go_cache => $go_cache,
          });
          $sth->STORE(Active => 0);
  
          my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth);
          if (not $skip_prepare_check) {
              $sth->go_sth_method() or return undef;
          }
  
          return $sth;
      }
  
      sub prepare_cached {
          my ($dbh, $sql, $attr, $if_active)= @_;
          $attr ||= {};
          return $dbh->SUPER::prepare_cached($sql, {
              %$attr,
              go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached',
          }, $if_active);
      }
  
      *go_cache = \&DBD::Gofer::go_cache;
  }
  
  
  {   package DBD::Gofer::st; # ====== STATEMENT ======
      $imp_data_size = 0;
      use strict;
  
      my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1);
  
      sub go_sth_method {
          my ($sth, $meta) = @_;
  
          if (my $ParamValues = $sth->{ParamValues}) {
              my $ParamAttr = $sth->{ParamAttr};
              # XXX the sort here is a hack to work around a DBD::Sybase bug
              # but only works properly for params 1..9
              # (reverse because of the unshift)
              my @params = reverse sort keys %$ParamValues;
              if (@params > 9 && ($sth->{Database}{go_dsn}||'') =~ /dbi:Sybase/) {
                  # if more than 9 then we need to do a proper numeric sort
                  # also warn to alert user of this issue
                  warn "Sybase param binding order hack in use";
                  @params = sort { $b <=> $a } @params;
              }
              for my $p (@params) {
                  # unshift to put binds before execute call
                  unshift @{ $sth->{go_method_calls} },
                      [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ];
              }
          }
  
          my $dbh = $sth->{Database} or die "panic";
          ++$dbh->{go_request_count};
  
          my $request = $sth->{go_request};
          $request->init_request($sth->{go_prepare_call}, $sth);
          $request->sth_method_calls(delete $sth->{go_method_calls})
              if $sth->{go_method_calls};
          $request->sth_result_attr({}); # (currently) also indicates this is an sth request
  
          $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args})
              if $meta->{go_last_insert_id_args};
  
          my $go_policy = $sth->{go_policy};
          my $dbh_attribute_update = $go_policy->dbh_attribute_update();
          $request->dbh_attributes( $go_policy->dbh_attribute_list() )
              if $dbh_attribute_update eq 'every'
              or $dbh->{go_request_count}==1;
  
          my $transport = $sth->{go_transport}
              or return $sth->set_err($DBI::stderr, "Not connected (no transport)");
  
          local $transport->{go_cache} = $sth->{go_cache}
              if defined $sth->{go_cache};
  
          my ($response, $retransmit_sub) = $transport->transmit_request($request);
          $response ||= $transport->receive_response($request, $retransmit_sub);
          $sth->{go_response} = $response
              or die "No response object returned by $transport";
          $dbh->{go_response} = $response; # mainly for last_insert_id
  
          if (my $dbh_attributes = $response->dbh_attributes) {
              # XXX we don't STORE here, we just stuff the value into the attribute cache
              $dbh->{$_} = $dbh_attributes->{$_}
                  for keys %$dbh_attributes;
              # record the values returned, so we know that we have fetched
              # values are which we have fetched (see dbh->FETCH method)
              $dbh->{go_dbh_attributes_fetched} = $dbh_attributes;
          }
  
          my $rv = $response->rv; # may be undef on error
          if ($response->sth_resultsets) {
              # setup first resultset - including sth attributes
              $sth->more_results;
          }
          else {
              $sth->STORE(Active => 0);
              $sth->{go_rows} = $rv;
          }
          # set error/warn/info (after more_results as that'll clear err)
          DBD::Gofer::set_err_from_response($sth, $response);
  
          return $rv;
      }
  
  
      sub bind_param {
          my ($sth, $param, $value, $attr) = @_;
          $sth->{ParamValues}{$param} = $value;
          $sth->{ParamAttr}{$param}   = $attr
              if defined $attr; # attr is sticky if not explicitly set
          return 1;
      }
  
  
      sub execute {
          my $sth = shift;
          $sth->bind_param($_, $_[$_-1]) for (1..@_);
          push @{ $sth->{go_method_calls} }, [ 'execute' ];
          my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args} };
          return $sth->go_sth_method($meta);
      }
  
  
      sub more_results {
          my $sth = shift;
  
          $sth->finish;
  
          my $response = $sth->{go_response} or do {
              # e.g., we haven't sent a request yet (ie prepare then more_results)
              $sth->trace_msg("    No response object present", 3);
              return;
          };
  
          my $resultset_list = $response->sth_resultsets
              or return $sth->set_err($DBI::stderr, "No sth_resultsets");
  
          my $meta = shift @$resultset_list
              or return undef; # no more result sets
          #warn "more_results: ".Data::Dumper::Dumper($meta);
  
          # pull out the special non-atributes first
          my ($rowset, $err, $errstr, $state)
              = delete @{$meta}{qw(rowset err errstr state)};
  
          # copy meta attributes into attribute cache
          my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS};
          $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS);
          # XXX need to use STORE for some?
          $sth->{$_} = $meta->{$_} for keys %$meta;
  
          if (($NUM_OF_FIELDS||0) > 0) {
              $sth->{go_rows}           = ($rowset) ? @$rowset : -1;
              $sth->{go_current_rowset} = $rowset;
              $sth->{go_current_rowset_err} = [ $err, $errstr, $state ]
                  if defined $err;
              $sth->STORE(Active => 1) if $rowset;
          }
  
          return $sth;
      }
  
  
      sub go_clone_sth {
          my ($sth1) = @_;
          # clone an (un-fetched-from) sth - effectively undoes the initial more_results
          # not 100% so just for use in caching returned sth e.g. table_info
          my $sth2 = $sth1->{Database}->prepare($sth1->{Statement}, { go_skip_prepare_check => 1 });
          $sth2->STORE($_, $sth1->{$_}) for qw(NUM_OF_FIELDS Active);
          my $sth2_inner = tied %$sth2;
          $sth2_inner->{$_} = $sth1->{$_} for qw(NUM_OF_PARAMS FetchHashKeyName);
          die "not fully implemented yet";
          return $sth2;
      }
  
  
      sub fetchrow_arrayref {
          my ($sth) = @_;
          my $resultset = $sth->{go_current_rowset} || do {
              # should only happen if fetch called after execute failed
              my $rowset_err = $sth->{go_current_rowset_err}
                  || [ 1, 'no result set (did execute fail)' ];
              return $sth->set_err( @$rowset_err );
          };
          return $sth->_set_fbav(shift @$resultset) if @$resultset;
          $sth->finish;     # no more data so finish
          return undef;
      }
      *fetch = \&fetchrow_arrayref; # alias
  
  
      sub fetchall_arrayref {
          my ($sth, $slice, $max_rows) = @_;
          my $resultset = $sth->{go_current_rowset} || do {
              # should only happen if fetch called after execute failed
              my $rowset_err = $sth->{go_current_rowset_err}
                  || [ 1, 'no result set (did execute fail)' ];
              return $sth->set_err( @$rowset_err );
          };
          my $mode = ref($slice) || 'ARRAY';
          return $sth->SUPER::fetchall_arrayref($slice, $max_rows)
              if ref($slice) or defined $max_rows;
          $sth->finish;     # no more data after this so finish
          return $resultset;
      }
  
  
      sub rows {
          return shift->{go_rows};
      }
  
  
      sub STORE {
          my ($sth, $attrib, $value) = @_;
  
          return $sth->SUPER::STORE($attrib => $value)
              if $sth_local_store_attrib{$attrib} # handle locally
              # or it's a private_ (application) attribute
              or $attrib =~ /^private_/;
  
          # otherwise warn but do it anyway
          # this will probably need refining later
          my $msg = "Altering \$sth->{$attrib} won't affect proxied handle";
          Carp::carp($msg) if $sth->FETCH('Warn');
  
          # XXX could perhaps do
          #   push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ]
          #       if not $sth->FETCH('Executed');
          # but how to handle repeat executions? How to we know when an
          # attribute is being set to affect the current resultset or the
          # next execution?
          # Could just always use go_method_calls I guess.
  
          # do the store locally anyway, just in case
          $sth->SUPER::STORE($attrib => $value);
  
          return $sth->set_err($DBI::stderr, $msg);
      }
  
      # sub bind_param_array
      # we use DBI's default, which sets $sth->{ParamArrays}{$param} = $value
      # and calls bind_param($param, undef, $attr) if $attr.
  
      sub execute_array {
          my $sth = shift;
          my $attr = shift;
          $sth->bind_param_array($_, $_[$_-1]) for (1..@_);
          push @{ $sth->{go_method_calls} }, [ 'execute_array', $attr ];
          return $sth->go_sth_method($attr);
      }
  
      *go_cache = \&DBD::Gofer::go_cache;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  DBD::Gofer - A stateless-proxy driver for communicating with a remote DBI
  
  =head1 SYNOPSIS
  
    use DBI;
  
    $original_dsn = "dbi:..."; # your original DBI Data Source Name
  
    $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$original_dsn",
                        $user, $passwd, \%attributes);
  
    ... use $dbh as if it was connected to $original_dsn ...
  
  
  The C<transport=$transport> part specifies the name of the module to use to
  transport the requests to the remote DBI. If $transport doesn't contain any
  double colons then it's prefixed with C<DBD::Gofer::Transport::>.
  
  The C<dsn=$original_dsn> part I<must be the last element> of the DSN because
  everything after C<dsn=> is assumed to be the DSN that the remote DBI should
  use.
  
  The C<...> represents attributes that influence the operation of the Gofer
  driver or transport. These are described below or in the documentation of the
  transport module being used.
  
  =head1 DESCRIPTION
  
  DBD::Gofer is a DBI database driver that forwards requests to another DBI
  driver, usually in a separate process, often on a separate machine. It tries to
  be as transparent as possible so it appears that you are using the remote
  driver directly.
  
  DBD::Gofer is very similar to DBD::Proxy. The major difference is that with
  DBD::Gofer no state is maintained on the remote end. That means every
  request contains all the information needed to create the required state. (So,
  for example, every request includes the DSN to connect to.) Each request can be
  sent to any available server. The server executes the request and returns a
  single response that includes all the data.
  
  This is very similar to the way http works as a stateless protocol for the web.
  Each request from your web browser can be handled by a different web server process.
  
  =head2 Use Cases
  
  This may seem like pointless overhead but there are situations where this is a
  very good thing. Let's consider a specific case.
  
  Imagine using DBD::Gofer with an http transport. Your application calls
  connect(), prepare("select * from table where foo=?"), bind_param(), and execute().
  At this point DBD::Gofer builds a request containing all the information
  about the method calls. It then uses the httpd transport to send that request
  to an apache web server.
  
  This 'dbi execute' web server executes the request (using DBI::Gofer::Execute
  and related modules) and builds a response that contains all the rows of data,
  if the statement returned any, along with all the attributes that describe the
  results, such as $sth->{NAME}. This response is sent back to DBD::Gofer which
  unpacks it and presents it to the application as if it had executed the
  statement itself.
  
  =head2 Advantages
  
  Okay, but you still don't see the point? Well let's consider what we've gained:
  
  =head3 Connection Pooling and Throttling
  
  The 'dbi execute' web server leverages all the functionality of web
  infrastructure in terms of load balancing, high-availability, firewalls, access
  management, proxying, caching.
  
  At its most basic level you get a configurable pool of persistent database connections.
  
  =head3 Simple Scaling
  
  Got thousands of processes all trying to connect to the database? You can use
  DBD::Gofer to connect them to your smaller pool of 'dbi execute' web servers instead.
  
  =head3 Caching
  
  Client-side caching is as simple as adding "C<cache=1>" to the DSN.
  This feature alone can be worth using DBD::Gofer for.
  
  =head3 Fewer Network Round-trips
  
  DBD::Gofer sends as few requests as possible (dependent on the policy being used).
  
  =head3 Thin Clients / Unsupported Platforms
  
  You no longer need drivers for your database on every system.  DBD::Gofer is pure perl.
  
  =head1 CONSTRAINTS
  
  There are some natural constraints imposed by the DBD::Gofer 'stateless' approach.
  But not many:
  
  =head2 You can't change database handle attributes after connect()
  
  You can't change database handle attributes after you've connected.
  Use the connect() call to specify all the attribute settings you want.
  
  This is because it's critical that when a request is complete the database
  handle is left in the same state it was when first connected.
  
  An exception is made for attributes with names starting "C<private_>":
  They can be set after connect() but the change is only applied locally.
  
  =head2 You can't change statement handle attributes after prepare()
  
  You can't change statement handle attributes after prepare.
  
  An exception is made for attributes with names starting "C<private_>":
  They can be set after prepare() but the change is only applied locally.
  
  =head2 You can't use transactions
  
  AutoCommit only. Transactions aren't supported.
  
  (In theory transactions could be supported when using a transport that
  maintains a connection, like C<stream> does. If you're interested in this
  please get in touch via dbi-dev@perl.org)
  
  =head2 You can't call driver-private sth methods
  
  But that's rarely needed anyway.
  
  =head1 GENERAL CAVEATS
  
  A few important things to keep in mind when using DBD::Gofer:
  
  =head2 Temporary tables, locks, and other per-connection persistent state
  
  You shouldn't expect any per-session state to persist between requests.
  This includes locks and temporary tables.
  
  Because the server-side may execute your requests via a different
  database connections, you can't rely on any per-connection persistent state,
  such as temporary tables, being available from one request to the next.
  
  This is an easy trap to fall into. A good way to check for this is to test your
  code with a Gofer policy package that sets the C<connect_method> policy to
  'connect' to force a new connection for each request. The C<pedantic> policy does this.
  
  =head2 Driver-private Database Handle Attributes
  
  Some driver-private dbh attributes may not be available if the driver has not
  implemented the private_attribute_info() method (added in DBI 1.54).
  
  =head2 Driver-private Statement Handle Attributes
  
  Driver-private sth attributes can be set in the prepare() call. TODO
  
  Some driver-private dbh attributes may not be available if the driver has not
  implemented the private_attribute_info() method (added in DBI 1.54).
  
  =head2 Multiple Resultsets
  
  Multiple resultsets are supported only if the driver supports the more_results() method
  (an exception is made for DBD::Sybase).
  
  =head2 Statement activity that also updates dbh attributes
  
  Some drivers may update one or more dbh attributes after performing activity on
  a child sth.  For example, DBD::mysql provides $dbh->{mysql_insertid} in addition to
  $sth->{mysql_insertid}. Currently mysql_insertid is supported via a hack but a
  more general mechanism is needed for other drivers to use.
  
  =head2 Methods that report an error always return undef
  
  With DBD::Gofer, a method that sets an error always return an undef or empty list.
  That shouldn't be a problem in practice because the DBI doesn't define any
  methods that return meaningful values while also reporting an error.
  
  =head2 Subclassing only applies to client-side
  
  The RootClass and DbTypeSubclass attributes are not passed to the Gofer server.
  
  =head1 CAVEATS FOR SPECIFIC METHODS
  
  =head2 last_insert_id
  
  To enable use of last_insert_id you need to indicate to DBD::Gofer that you'd
  like to use it.  You do that my adding a C<go_last_insert_id_args> attribute to
  the do() or prepare() method calls. For example:
  
      $dbh->do($sql, { go_last_insert_id_args => [...] });
  
  or
  
      $sth = $dbh->prepare($sql, { go_last_insert_id_args => [...] });
  
  The array reference should contains the args that you want passed to the
  last_insert_id() method.
  
  =head2 execute_for_fetch
  
  The array methods bind_param_array() and execute_array() are supported.
  When execute_array() is called the data is serialized and executed in a single
  round-trip to the Gofer server. This makes it very fast, but requires enough
  memory to store all the serialized data.
  
  The execute_for_fetch() method currently isn't optimised, it uses the DBI
  fallback behaviour of executing each tuple individually.
  (It could be implemented as a wrapper for execute_array() - patches welcome.)
  
  =head1 TRANSPORTS
  
  DBD::Gofer doesn't concern itself with transporting requests and responses to and fro.
  For that it uses special Gofer transport modules.
  
  Gofer transport modules usually come in pairs: one for the 'client' DBD::Gofer
  driver to use and one for the remote 'server' end. They have very similar names:
  
      DBD::Gofer::Transport::<foo>
      DBI::Gofer::Transport::<foo>
  
  Sometimes the transports on the DBD and DBI sides may have different names. For
  example DBD::Gofer::Transport::http is typically used with DBI::Gofer::Transport::mod_perl
  (DBD::Gofer::Transport::http and DBI::Gofer::Transport::mod_perl modules are
  part of the GoferTransport-http distribution).
  
  =head2 Bundled Transports
  
  Several transport modules are provided with DBD::Gofer:
  
  =head3 null
  
  The null transport is the simplest of them all. It doesn't actually transport the request anywhere.
  It just serializes (freezes) the request into a string, then thaws it back into
  a data structure before passing it to DBI::Gofer::Execute to execute. The same
  freeze and thaw is applied to the results.
  
  The null transport is the best way to test if your application will work with Gofer.
  Just set the DBI_AUTOPROXY environment variable to "C<dbi:Gofer:transport=null;policy=pedantic>"
  (see L</Using DBI_AUTOPROXY> below) and run your application, or ideally its test suite, as usual.
  
  It doesn't take any parameters.
  
  =head3 pipeone
  
  The pipeone transport launches a subprocess for each request. It passes in the
  request and reads the response.
  
  The fact that a new subprocess is started for each request ensures that the
  server side is truly stateless. While this does make the transport I<very> slow,
  it is useful as a way to test that your application doesn't depend on
  per-connection state, such as temporary tables, persisting between requests.
  
  It's also useful both as a proof of concept and as a base class for the stream
  driver.
  
  =head3 stream
  
  The stream driver also launches a subprocess and writes requests and reads
  responses, like the pipeone transport.  In this case, however, the subprocess
  is expected to handle more that one request. (Though it will be automatically
  restarted if it exits.)
  
  This is the first transport that is truly useful because it can launch the
  subprocess on a remote machine using C<ssh>. This means you can now use DBD::Gofer
  to easily access any databases that's accessible from any system you can login to.
  You also get all the benefits of ssh, including encryption and optional compression.
  
  See L</Using DBI_AUTOPROXY> below for an example.
  
  =head2 Other Transports
  
  Implementing a Gofer transport is I<very> simple, and more transports are very welcome.
  Just take a look at any existing transports that are similar to your needs.
  
  =head3 http
  
  See the GoferTransport-http distribution on CPAN: http://search.cpan.org/dist/GoferTransport-http/
  
  =head3 Gearman
  
  I know Ask Bjrn Hansen has implemented a transport for the C<gearman> distributed
  job system, though it's not on CPAN at the time of writing this.
  
  =head1 CONNECTING
  
  Simply prefix your existing DSN with "C<dbi:Gofer:transport=$transport;dsn=>"
  where $transport is the name of the Gofer transport you want to use (see L</TRANSPORTS>).
  The C<transport> and C<dsn> attributes must be specified and the C<dsn> attributes must be last.
  
  Other attributes can be specified in the DSN to configure DBD::Gofer and/or the
  Gofer transport module being used. The main attributes after C<transport>, are
  C<url> and C<policy>. These and other attributes are described below.
  
  =head2 Using DBI_AUTOPROXY
  
  The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment variable.
  In this case you don't include the C<dsn=> part. For example:
  
      export DBI_AUTOPROXY="dbi:Gofer:transport=null"
  
  or, for a more useful example, try:
  
      export DBI_AUTOPROXY="dbi:Gofer:transport=stream;url=ssh:user@example.com"
  
  =head2 Connection Attributes
  
  These attributes can be specified in the DSN. They can also be passed in the
  \%attr parameter of the DBI connect method by adding a "C<go_>" prefix to the name.
  
  =head3 transport
  
  Specifies the Gofer transport class to use. Required. See L</TRANSPORTS> above.
  
  If the value does not include C<::> then "C<DBD::Gofer::Transport::>" is prefixed.
  
  The transport object can be accessed via $h->{go_transport}.
  
  =head3 dsn
  
  Specifies the DSN for the remote side to connect to. Required, and must be last.
  
  =head3 url
  
  Used to tell the transport where to connect to. The exact form of the value depends on the transport used.
  
  =head3 policy
  
  Specifies the policy to use. See L</CONFIGURING BEHAVIOUR POLICY>.
  
  If the value does not include C<::> then "C<DBD::Gofer::Policy>" is prefixed.
  
  The policy object can be accessed via $h->{go_policy}.
  
  =head3 timeout
  
  Specifies a timeout, in seconds, to use when waiting for responses from the server side.
  
  =head3 retry_limit
  
  Specifies the number of times a failed request will be retried. Default is 0.
  
  =head3 retry_hook
  
  Specifies a code reference to be called to decide if a failed request should be retried.
  The code reference is called like this:
  
    $transport = $h->{go_transport};
    $retry = $transport->go_retry_hook->($request, $response, $transport);
  
  If it returns true then the request will be retried, upto the C<retry_limit>.
  If it returns a false but defined value then the request will not be retried.
  If it returns undef then the default behaviour will be used, as if C<retry_hook>
  had not been specified.
  
  The default behaviour is to retry requests where $request->is_idempotent is true,
  or the error message matches C</induced by DBI_GOFER_RANDOM/>.
      
  =head3 cache
  
  Specifies that client-side caching should be performed.  The value is the name
  of a cache class to use.
  
  Any class implementing get($key) and set($key, $value) methods can be used.
  That includes a great many powerful caching classes on CPAN, including the
  Cache and Cache::Cache distributions.
  
  You can use "C<cache=1>" is a shortcut for "C<cache=DBI::Util::CacheMemory>".
  See L<DBI::Util::CacheMemory> for a description of this simple fast default cache.
  
  The cache object can be accessed via $h->go_cache. For example:
  
      $dbh->go_cache->clear; # free up memory being used by the cache
  
  The cache keys are the frozen (serialized) requests, and the values are the
  frozen responses.
  
  The default behaviour is to only use the cache for requests where
  $request->is_idempotent is true (i.e., the dbh has the ReadOnly attribute set
  or the SQL statement is obviously a SELECT without a FOR UPDATE clause.)
  
  For even more control you can use the C<go_cache> attribute to pass in an
  instantiated cache object. Individual methods, including prepare(), can also
  specify alternative caches via the C<go_cache> attribute. For example, to
  specify no caching for a particular query, you could use
  
      $sth = $dbh->prepare( $sql, { go_cache => 0 } );
  
  This can be used to implement different caching policies for different statements.
  
  It's interesting to note that DBD::Gofer can be used to add client-side caching
  to any (gofer compatible) application, with no code changes and no need for a
  gofer server.  Just set the DBI_AUTOPROXY environment variable like this:
  
      DBI_AUTOPROXY='dbi:Gofer:transport=null;cache=1'
  
  =head1 CONFIGURING BEHAVIOUR POLICY
  
  DBD::Gofer supports a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server.
  The policies are grouped into classes (which may be subclassed) and referenced by the name of the class.
  
  The L<DBD::Gofer::Policy::Base> class is the base class for all the policy
  packages and describes all the available policies.
  
  Three policy packages are supplied with DBD::Gofer:
  
  L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it
  makes more  round-trips to the Gofer server.
  
  L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy.
  
  L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications.
  
  Generally the default C<classic> policy is fine. When first testing an existing
  application with Gofer it is a good idea to start with the C<pedantic> policy
  first and then switch to C<classic> or a custom policy, for final testing.
  
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =head1 ACKNOWLEDGEMENTS
  
  The development of DBD::Gofer and related modules was sponsored by
  Shopzilla.com (L<http://Shopzilla.com>), where I currently work.
  
  =head1 SEE ALSO
  
  L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>.
  
  L<DBI::Gofer::Transport::Base>, L<DBD::Gofer::Policy::Base>.
  
  L<DBI>
  
  =head1 Caveats for specific drivers
  
  This section aims to record issues to be aware of when using Gofer with specific drivers.
  It usually only documents issues that are not natural consequences of the limitations
  of the Gofer approach - as documented above.
  
  =head1 TODO
  
  This is just a random brain dump... (There's more in the source of the Changes file, not the pod)
  
  Document policy mechanism
  
  Add mechanism for transports to list config params and for Gofer to apply any that match (and warn if any left over?)
  
  Driver-private sth attributes - set via prepare() - change DBI spec
  
  add hooks into transport base class for checking & updating a result set cache
     ie via a standard cache interface such as:
     http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm
     http://search.cpan.org/~bradfitz/Cache-Memcached/lib/Cache/Memcached.pm
     http://search.cpan.org/~dclinton/Cache-Cache/
     http://search.cpan.org/~cleishman/Cache/
  Also caching instructions could be passed through the httpd transport layer
  in such a way that appropriate http cache headers are added to the results
  so that web caches (squid etc) could be used to implement the caching.
  (MUST require the use of GET rather than POST requests.)
  
  Rework handling of installed_methods to not piggback on dbh_attributes?
  
  Perhaps support transactions for transports where it's possible (ie null and stream)?
  Would make stream transport (ie ssh) more useful to more people.
  
  Make sth_result_attr more like dbh_attributes (using '*' etc)
  
  Add @val = FETCH_many(@names) to DBI in C and use in Gofer/Execute?
  
  Implement _new_sth in C.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Policy/Base.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_BASE';
  package DBD::Gofer::Policy::Base;
  
  #   $Id: Base.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  use Carp;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  our $AUTOLOAD;
  
  my %policy_defaults = (
      # force connect method (unless overridden by go_connect_method=>'...' attribute)
      # if false: call same method on client as on server
      connect_method => 'connect',
      # force prepare method (unless overridden by go_prepare_method=>'...' attribute)
      # if false: call same method on client as on server
      prepare_method => 'prepare',
      skip_connect_check => 0,
      skip_default_methods => 0,
      skip_prepare_check => 0,
      skip_ping => 0,
      dbh_attribute_update => 'every',
      dbh_attribute_list => ['*'],
      locally_quote => 0,
      locally_quote_identifier => 0,
      cache_parse_trace_flags => 1,
      cache_parse_trace_flag => 1,
      cache_data_sources => 1,
      cache_type_info_all => 1,
      cache_tables => 0,
      cache_table_info => 0,
      cache_column_info => 0,
      cache_primary_key_info => 0,
      cache_foreign_key_info => 0,
      cache_statistics_info => 0,
      cache_get_info => 0,
      cache_func => 0,
  );
  
  my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"};
  
  __PACKAGE__->create_policy_subs(\%policy_defaults);
  
  sub create_policy_subs {
      my ($class, $policy_defaults) = @_;
  
      while ( my ($policy_name, $policy_default) = each %$policy_defaults) { 
          my $policy_attr_name = "go_$policy_name";
          my $sub = sub {
              # $policy->foo($attr, ...)
              #carp "$policy_name($_[1],...)";
              # return the policy default value unless an attribute overrides it
              return (ref $_[1] && exists $_[1]->{$policy_attr_name})
                  ? $_[1]->{$policy_attr_name}
                  : $policy_default;
          };
          no strict 'refs';
          *{$class . '::' . $policy_name} = $sub;
      }
  }
  
  sub AUTOLOAD {
      carp "Unknown policy name $AUTOLOAD used";
      # only warn once
      no strict 'refs';
      *$AUTOLOAD = sub { undef };
      return undef;
  }
  
  sub new {
      my ($class, $args) = @_;
      my $policy = {};
      bless $policy, $class;
  }
  
  sub DESTROY { };
  
  1;
  
  =head1 NAME
  
  DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies
  
  =head1 SYNOPSIS
  
    $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...)
  
  =head1 DESCRIPTION
  
  DBD::Gofer can be configured via a 'policy' mechanism that allows you to
  fine-tune the number of round-trips to the Gofer server.  The policies are
  grouped into classes (which may be subclassed) and referenced by the name of
  the class.
  
  The L<DBD::Gofer::Policy::Base> class is the base class for all the policy
  classes and describes all the individual policy items.
  
  The Base policy is not used directly. You should use a policy class derived from it.
  
  =head1 POLICY CLASSES
  
  Three policy classes are supplied with DBD::Gofer:
      
  L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it
  makes more  round-trips to the Gofer server.
  
  L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy.
      
  L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications.
  
  Generally the default C<classic> policy is fine. When first testing an existing
  application with Gofer it is a good idea to start with the C<pedantic> policy
  first and then switch to C<classic> or a custom policy, for final testing.
  
  =head1 POLICY ITEMS
  
  These are temporary docs: See the source code for list of policies and their defaults.
  
  In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
  
  See the source code to this module for more details.
  
  =head1 POLICY CUSTOMIZATION
  
  XXX This area of DBD::Gofer is subject to change.
  
  There are three ways to customize policies:
  
  Policy classes are designed to influence the overall behaviour of DBD::Gofer
  with existing, unaltered programs, so they work in a reasonably optimal way
  without requiring code changes. You can implement new policy classes as
  subclasses of existing policies.
  
  In many cases individual policy items can be overridden on a case-by-case basis
  within your application code. You do this by passing a corresponding
  C<<go_<policy_name>>> attribute into DBI methods by your application code.
  This let's you fine-tune the behaviour for special cases.
  
  The policy items are implemented as methods. In many cases the methods are
  passed parameters relating to the DBD::Gofer code being executed. This means
  the policy can implement dynamic behaviour that varies depending on the
  particular circumstances, such as the particular statement being executed.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_BASE

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Policy/classic.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_CLASSIC';
  package DBD::Gofer::Policy::classic;
  
  #   $Id: classic.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  
  use base qw(DBD::Gofer::Policy::Base);
  
  __PACKAGE__->create_policy_subs({
  
      # always use connect_cached on server
      connect_method => 'connect_cached',
  
      # use same methods on server as is called on client
      prepare_method => '',
  
      # don't skip the connect check since that also sets dbh attributes
      # although this makes connect more expensive, that's partly offset
      # by skip_ping=>1 below, which makes connect_cached very fast.
      skip_connect_check => 0,
  
      # most code doesn't rely on sth attributes being set after prepare
      skip_prepare_check => 1,
  
      # we're happy to use local method if that's the same as the remote
      skip_default_methods => 1,
  
      # ping is not important for DBD::Gofer and most transports
      skip_ping => 1,
  
      # only update dbh attributes on first contact with server
      dbh_attribute_update => 'first',
  
      # we'd like to set locally_* but can't because drivers differ
  
      # get_info results usually don't change
      cache_get_info => 1,
  });
  
  
  1;
  
  =head1 NAME
  
  DBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer
  
  =head1 SYNOPSIS
  
    $dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...)
  
  The C<classic> policy is the default DBD::Gofer policy, so need not be included in the DSN.
  
  =head1 DESCRIPTION
  
  Temporary docs: See the source code for list of policies and their defaults.
  
  In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_CLASSIC

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Policy/pedantic.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_PEDANTIC';
  package DBD::Gofer::Policy::pedantic;
  
  #   $Id: pedantic.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  
  use base qw(DBD::Gofer::Policy::Base);
  
  # the 'pedantic' policy is the same as the Base policy
  
  1;
  
  =head1 NAME
  
  DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer
  
  =head1 SYNOPSIS
  
    $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...)
  
  =head1 DESCRIPTION
  
  The C<pedantic> policy tries to be as transparent as possible. To do this it
  makes round-trips to the server for almost every DBI method call.
  
  This is the best policy to use when first testing existing code with Gofer.
  Once it's working well you should consider moving to the C<classic> policy or defining your own policy class.
  
  Temporary docs: See the source code for list of policies and their defaults.
  
  In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_PEDANTIC

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Policy/rush.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_RUSH';
  package DBD::Gofer::Policy::rush;
  
  #   $Id: rush.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  
  use base qw(DBD::Gofer::Policy::Base);
  
  __PACKAGE__->create_policy_subs({
  
      # always use connect_cached on server
      connect_method => 'connect_cached',
  
      # use same methods on server as is called on client
      # (because code not using placeholders would bloat the sth cache)
      prepare_method => '',
  
      # Skipping the connect check is fast, but it also skips
      # fetching the remote dbh attributes!
      # Make sure that your application doesn't need access to dbh attributes.
      skip_connect_check => 1,
  
      # most code doesn't rely on sth attributes being set after prepare
      skip_prepare_check => 1,
  
      # we're happy to use local method if that's the same as the remote
      skip_default_methods => 1,
  
      # ping is almost meaningless for DBD::Gofer and most transports anyway
      skip_ping => 1,
  
      # don't update dbh attributes at all
      # XXX actually we currently need dbh_attribute_update for skip_default_methods to work
      # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update
      dbh_attribute_update => 'none', # actually means 'first' currently
      #dbh_attribute_list => undef,
  
      # we'd like to set locally_* but can't because drivers differ
  
      # in a rush assume metadata doesn't change
      cache_tables => 1,
      cache_table_info => 1,
      cache_column_info => 1,
      cache_primary_key_info => 1,
      cache_foreign_key_info => 1,
      cache_statistics_info => 1,
      cache_get_info => 1,
  });
  
  
  1;
  
  =head1 NAME
  
  DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer
  
  =head1 SYNOPSIS
  
    $dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...)
  
  =head1 DESCRIPTION
  
  The C<rush> policy tries to make as few round-trips as possible.
  It's the opposite end of the policy spectrum to the C<pedantic> policy.
  
  Temporary docs: See the source code for list of policies and their defaults.
  
  In a future version the policies and their defaults will be defined in the pod and parsed out at load-time.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_POLICY_RUSH

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Transport/Base.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_BASE';
  package DBD::Gofer::Transport::Base;
  
  #   $Id: Base.pm 12536 2009-02-24 22:37:09Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use base qw(DBI::Gofer::Transport::Base);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
  
  __PACKAGE__->mk_accessors(qw(
      trace
      go_dsn
      go_url
      go_policy
      go_timeout
      go_retry_hook
      go_retry_limit
      go_cache
      cache_hit
      cache_miss
      cache_store
  ));
  __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
      meta
  ));
  
  
  sub new {
      my ($class, $args) = @_;
      $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store));
      $args->{keep_meta_frozen} ||= 1 if $args->{go_cache};
      #warn "args @{[ %$args ]}\n";
      return $class->SUPER::new($args);
  }   
  
  
  sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 }
  
  
  sub new_response {
      my $self = shift;
      return DBI::Gofer::Response->new(@_);
  }
  
  
  sub transmit_request {
      my ($self, $request) = @_;
      my $trace = $self->trace;
      my $response;
  
      my ($go_cache, $request_cache_key);
      if ($go_cache = $self->{go_cache}) {
          $request_cache_key
              = $request->{meta}{request_cache_key}
              = $self->get_cache_key_for_request($request);
          if ($request_cache_key) {
              my $frozen_response = eval { $go_cache->get($request_cache_key) };
              if ($frozen_response) {
                  $self->_dump("cached response found for ".ref($request), $request)
                      if $trace;
                  $response = $self->thaw_response($frozen_response);
                  $self->trace_msg("transmit_request is returning a response from cache $go_cache\n")
                      if $trace;
                  ++$self->{cache_hit};
                  return $response;
              }
              warn $@ if $@;
              ++$self->{cache_miss};
              $self->trace_msg("transmit_request cache miss\n")
                  if $trace;
          }
      }
  
      my $to = $self->go_timeout;
      my $transmit_sub = sub {
          $self->trace_msg("transmit_request\n") if $trace;
          local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
  
          my $response = eval {
              local $SIG{PIPE} = sub {
                  my $extra = ($! eq "Broken pipe") ? "" : " ($!)";
                  die "Unable to send request: Broken pipe$extra\n";
              };
              alarm($to) if $to;
              $self->transmit_request_by_transport($request);
          };
          alarm(0) if $to;
  
          if ($@) {
              return $self->transport_timedout("transmit_request", $to)
                  if $@ eq "TIMEOUT\n";
              return $self->new_response({ err => 1, errstr => $@ });
          }
  
          return $response;
      };
  
      $response = $self->_transmit_request_with_retries($request, $transmit_sub);
  
      if ($response) {
          my $frozen_response = delete $response->{meta}{frozen};
          $self->_store_response_in_cache($frozen_response, $request_cache_key)
              if $request_cache_key;
      }
  
      $self->trace_msg("transmit_request is returning a response itself\n")
          if $trace && $response;
  
      return $response unless wantarray;
      return ($response, $transmit_sub);
  }
  
  
  sub _transmit_request_with_retries {
      my ($self, $request, $transmit_sub) = @_;
      my $response;
      do {
          $response = $transmit_sub->();
      } while ( $response && $self->response_needs_retransmit($request, $response) );
      return $response;
  }
  
  
  sub receive_response {
      my ($self, $request, $retransmit_sub) = @_;
      my $to = $self->go_timeout;
  
      my $receive_sub = sub {
          $self->trace_msg("receive_response\n");
          local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
  
          my $response = eval {
              alarm($to) if $to;
              $self->receive_response_by_transport($request);
          };
          alarm(0) if $to;
  
          if ($@) {
              return $self->transport_timedout("receive_response", $to)
                  if $@ eq "TIMEOUT\n";
              return $self->new_response({ err => 1, errstr => $@ });
          }
          return $response;
      };
  
      my $response;
      do {
          $response = $receive_sub->();
          if ($self->response_needs_retransmit($request, $response)) {
              $response = $self->_transmit_request_with_retries($request, $retransmit_sub);
              $response ||= $receive_sub->();
          }
      } while ( $self->response_needs_retransmit($request, $response) );
  
      if ($response) {
          my $frozen_response = delete $response->{meta}{frozen};
          my $request_cache_key = $request->{meta}{request_cache_key};
          $self->_store_response_in_cache($frozen_response, $request_cache_key)
              if $request_cache_key && $self->{go_cache};
      }
  
      return $response;
  }
  
  
  sub response_retry_preference {
      my ($self, $request, $response) = @_;
  
      # give the user a chance to express a preference (or undef for default)
      if (my $go_retry_hook = $self->go_retry_hook) {
          my $retry = $go_retry_hook->($request, $response, $self);
          $self->trace_msg(sprintf "go_retry_hook returned %s\n",
              (defined $retry) ? $retry : 'undef');
          return $retry if defined $retry;
      }
  
      # This is the main decision point.  We don't retry requests that got
      # as far as executing because the error is probably from the database
      # (not transport) so retrying is unlikely to help. But note that any
      # severe transport error occuring after execute is likely to return
      # a new response object that doesn't have the execute flag set. Beware!
      return 0 if $response->executed_flag_set;
  
      return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/;
  
      return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set
  
      return undef; # we couldn't make up our mind
  }
  
  
  sub response_needs_retransmit {
      my ($self, $request, $response) = @_;
  
      my $err = $response->err
          or return 0; # nothing went wrong
  
      my $retry = $self->response_retry_preference($request, $response);
  
      if (!$retry) {  # false or undef
          $self->trace_msg("response_needs_retransmit: response not suitable for retry\n");
          return 0;
      }
  
      # we'd like to retry but have we retried too much already?
  
      my $retry_limit = $self->go_retry_limit;
      if (!$retry_limit) {
          $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n");
          return 0;
      }
  
      my $request_meta = $request->meta;
      my $retry_count = $request_meta->{retry_count} || 0;
      if ($retry_count >= $retry_limit) {
          $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n");
          # XXX should be possible to disable altering the err
          $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count);
          return 0;
      }
  
      # will retry now, do the admin
      ++$retry_count;
      $self->trace_msg("response_needs_retransmit: retry $retry_count\n");
  
      # hook so response_retry_preference can defer some code execution
      # until we've checked retry_count and retry_limit.
      if (ref $retry eq 'CODE') {
          $retry->($retry_count, $retry_limit)
              and warn "should return false"; # protect future use
      }
  
      ++$request_meta->{retry_count};         # update count for this request object
      ++$self->meta->{request_retry_count};   # update cumulative transport stats
  
      return 1;
  }
  
  
  sub transport_timedout {
      my ($self, $method, $timeout) = @_;
      $timeout ||= $self->go_timeout;
      return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" });
  }
  
  
  # return undef if we don't want to cache this request
  # subclasses may use more specialized rules
  sub get_cache_key_for_request {
      my ($self, $request) = @_;
  
      # we only want to cache idempotent requests
      # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set
      return undef if not $request->is_idempotent;
  
      # XXX would be nice to avoid the extra freeze here
      my $key = $self->freeze_request($request, undef, 1);
  
      #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n";
  
      return $key;
  }
  
  
  sub _store_response_in_cache {
      my ($self, $frozen_response, $request_cache_key) = @_;
      my $go_cache = $self->{go_cache}
          or return;
  
      # new() ensures that enabling go_cache also enables keep_meta_frozen
      warn "No meta frozen in response" if !$frozen_response;
      warn "No request_cache_key" if !$request_cache_key;
  
      if ($frozen_response && $request_cache_key) {
          $self->trace_msg("receive_response added response to cache $go_cache\n");
          eval { $go_cache->set($request_cache_key, $frozen_response) };
          warn $@ if $@;
          ++$self->{cache_store};
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports
  
  =head1 SYNOPSIS
  
    my $remote_dsn = "..."
    DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...)
  
  or, enable by setting the DBI_AUTOPROXY environment variable:
  
    export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...'
  
  which will force I<all> DBI connections to be made via that Gofer server.
  
  =head1 DESCRIPTION
  
  This is the base class for all DBD::Gofer client transports.
  
  =head1 ATTRIBUTES
  
  Gofer transport attributes can be specified either in the attributes parameter
  of the connect() method call, or in the DSN string. When used in the DSN
  string, attribute names don't have the C<go_> prefix.
  
  =head2 go_dsn
  
  The full DBI DSN that the Gofer server should connect to on your behalf.
  
  When used in the DSN it must be the last element in the DSN string.
  
  =head2 go_timeout
  
  A time limit for sending a request and receiving a response. Some drivers may
  implement sending and receiving as separate steps, in which case (currently)
  the timeout applies to each separately.
  
  If a request needs to be resent then the timeout is restarted for each sending
  of a request and receiving of a response.
  
  =head2 go_retry_limit
  
  The maximum number of times an request may be retried. The default is 2.
  
  =head2 go_retry_hook
  
  This subroutine reference is called, if defined, for each response received where $response->err is true.
  
  The subroutine is pass three parameters: the request object, the response object, and the transport object.
  
  If it returns an undefined value then the default retry behaviour is used. See L</RETRY ON ERROR> below.
  
  If it returns a defined but false value then the request is not resent.
  
  If it returns true value then the request is resent, so long as the number of retries does not exceed C<go_retry_limit>.
  
  =head1 RETRY ON ERROR
  
  The default retry on error behaviour is:
  
   - Retry if the error was due to DBI_GOFER_RANDOM. See L<DBI::Gofer::Execute>.
  
   - Retry if $request->is_idempotent returns true. See L<DBI::Gofer::Request>.
  
  A retry won't be allowed if the number of previous retries has reached C<go_retry_limit>.
  
  =head1 TRACING
  
  Tracing of gofer requests and reponses can be enabled by setting the
  C<DBD_GOFER_TRACE> environment variable. A value of 1 gives a reasonably
  compact summary of each request and response. A value of 2 or more gives a
  detailed, and voluminous, dump.
  
  The trace is written using DBI->trace_msg() and so is written to the default
  DBI trace output, which is usually STDERR.
  
  =head1 METHODS
  
  I<This section is currently far from complete.>
  
  =head2 response_retry_preference
  
    $retry = $transport->response_retry_preference($request, $response);
  
  The response_retry_preference is called by DBD::Gofer when considering if a
  request should be retried after an error.
  
  Returns true (would like to retry), false (must not retry), undef (no preference).
  
  If a true value is returned in the form of a CODE ref then, if DBD::Gofer does
  decide to retry the request, it calls the code ref passing $retry_count, $retry_limit.
  Can be used for logging and/or to implement exponential backoff behaviour.
  Currently the called code must return using C<return;> to allow for future extensions.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =head1 SEE ALSO
  
  L<DBD::Gofer>, L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>.
  
  and some example transports:
  
  L<DBD::Gofer::Transport::stream>
  
  L<DBD::Gofer::Transport::http>
  
  L<DBI::Gofer::Transport::mod_perl>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_BASE

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Transport/null.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_NULL';
  package DBD::Gofer::Transport::null;
  
  #   $Id: null.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use base qw(DBD::Gofer::Transport::Base);
  
  use DBI::Gofer::Execute;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  
  __PACKAGE__->mk_accessors(qw(
      pending_response
      transmit_count
  )); 
  
  my $executor = DBI::Gofer::Execute->new();
  
  
  sub transmit_request_by_transport {
      my ($self, $request) = @_;
      $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests
  
      my $frozen_request = $self->freeze_request($request);
  
      # ...
      # the request is magically transported over to ... ourselves
      # ...
  
      my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) );
  
      # put response 'on the shelf' ready for receive_response()
      $self->pending_response( $response );
  
      return undef;
  }
  
  
  sub receive_response_by_transport {
      my $self = shift;
  
      my $response = $self->pending_response;
  
      my $frozen_response = $self->freeze_response($response, undef, 1);
  
      # ...
      # the response is magically transported back to ... ourselves
      # ...
  
      return $self->thaw_response($frozen_response);
  }
  
  
  1;
  __END__
  
  =head1 NAME
  
  DBD::Gofer::Transport::null - DBD::Gofer client transport for testing
  
  =head1 SYNOPSIS
  
    my $original_dsn = "..."
    DBI->connect("dbi:Gofer:transport=null;dsn=$original_dsn",...)
  
  or, enable by setting the DBI_AUTOPROXY environment variable:
  
    export DBI_AUTOPROXY="dbi:Gofer:transport=null"
  
  =head1 DESCRIPTION
  
  Connect via DBD::Gofer but execute the requests within the same process.
  
  This is a quick and simple way to test applications for compatibility with the
  (few) restrictions that DBD::Gofer imposes.
  
  It also provides a simple, portable way for the DBI test suite to be used to
  test DBD::Gofer on all platforms with no setup.
  
  Also, by measuring the difference in performance between normal connections and
  connections via C<dbi:Gofer:transport=null> the basic cost of using DBD::Gofer
  can be measured. Furthermore, the additional cost of more advanced transports can be 
  isolated by comparing their performance with the null transport.
  
  The C<t/85gofer.t> script in the DBI distribution includes a comparative benchmark.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =head1 SEE ALSO
  
  L<DBD::Gofer::Transport::Base>
  
  L<DBD::Gofer>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_NULL

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Transport/pipeone.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_PIPEONE';
  package DBD::Gofer::Transport::pipeone;
  
  #   $Id: pipeone.pm 10087 2007-10-16 12:42:37Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use Carp;
  use Fcntl;
  use IO::Select;
  use IPC::Open3 qw(open3);
  use Symbol qw(gensym);
  
  use base qw(DBD::Gofer::Transport::Base);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
  
  __PACKAGE__->mk_accessors(qw(
      connection_info
      go_perl
  )); 
  
  
  sub new {
      my ($self, $args) = @_;
      $args->{go_perl} ||= do {
          ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ];
      };
      if (not ref $args->{go_perl}) {
          # user can override the perl to be used, either with an array ref
          # containing the command name and args to use, or with a string
          # (ie via the DSN) in which case, to enable args to be passed,
          # we split on two or more consecutive spaces (otherwise the path
          # to perl couldn't contain a space itself).
          $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ];
      }
      return $self->SUPER::new($args);
  }
  
  
  # nonblock($fh) puts filehandle into nonblocking mode
  sub nonblock { 
    my $fh = shift;
    my $flags = fcntl($fh, F_GETFL, 0)
          or croak "Can't get flags for filehandle $fh: $!";
    fcntl($fh, F_SETFL, $flags | O_NONBLOCK)
          or croak "Can't make filehandle $fh nonblocking: $!";
  }
  
  
  sub start_pipe_command {
      my ($self, $cmd) = @_;
      $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY';
  
      # if it's important that the subprocess uses the same
      # (versions of) modules as us then the caller should
      # set PERL5LIB itself.
  
      # limit various forms of insanity, for now
      local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead
      local $ENV{DBI_AUTOPROXY};
      local $ENV{DBI_PROFILE};
  
      my ($wfh, $rfh, $efh) = (gensym, gensym, gensym);
      my $pid = open3($wfh, $rfh, $efh, @$cmd)
          or die "error starting @$cmd: $!\n";
      if ($self->trace) {
          $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0);
      }
      nonblock($rfh);
      nonblock($efh);
      my $ios = IO::Select->new($rfh, $efh);
  
      return {
          cmd=>$cmd,
          pid=>$pid,
          wfh=>$wfh, rfh=>$rfh, efh=>$efh,
          ios=>$ios,
      };
  }
  
  
  sub cmd_as_string {
      my $self = shift;
      # XXX meant to return a properly shell-escaped string suitable for system
      # but its only for debugging so that can wait
      my $connection_info = $self->connection_info;
      return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}};
  }
  
  
  sub transmit_request_by_transport {
      my ($self, $request) = @_;
  
      my $frozen_request = $self->freeze_request($request);
  
      my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)];
      my $info = $self->start_pipe_command($cmd);
  
      my $wfh = delete $info->{wfh};
      # send frozen request
      local $\;
      print $wfh $frozen_request
          or warn "error writing to @$cmd: $!\n";
      # indicate that there's no more
      close $wfh
          or die "error closing pipe to @$cmd: $!\n";
  
      $self->connection_info( $info );
      return;
  }
  
  
  sub read_response_from_fh {
      my ($self, $fh_actions) = @_;
      my $trace = $self->trace;
  
      my $info = $self->connection_info || die;
      my ($ios) = @{$info}{qw(ios)};
      my $errors = 0;
      my $complete;
  
      die "No handles to read response from" unless $ios->count;
  
      while ($ios->count) {
          my @readable = $ios->can_read();
          for my $fh (@readable) {
              local $_;
              my $actions = $fh_actions->{$fh} || die "panic: no action for $fh";
              my $rv = sysread($fh, $_='', 1024*31);  # to fit in 32KB slab
              unless ($rv) {              # error (undef) or end of file (0)
                  my $action;
                  unless (defined $rv) {  # was an error
                      $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4;
                      $action = $actions->{error} || $actions->{eof};
                      ++$errors;
                      # XXX an error may be a permenent condition of the handle
                      # if so we'll loop here - not good
                  }
                  else {
                      $action = $actions->{eof};
                      $self->trace_msg("eof on handle $fh\n") if $trace >= 4;
                  }
                  if ($action->($fh)) {
                      $self->trace_msg("removing $fh from handle set\n") if $trace >= 4;
                      $ios->remove($fh);
                  }
                  next;
              }
              # action returns true if the response is now complete
              # (we finish all handles
              $actions->{read}->($fh) && ++$complete;
          }
          last if $complete;
      }
      return $errors;
  }
  
  
  sub receive_response_by_transport {
      my $self = shift;
  
      my $info = $self->connection_info || die;
      my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)};
  
      my $frozen_response;
      my $stderr_msg;
  
      $self->read_response_from_fh( {
          $efh => {
              error => sub { warn "error reading response stderr: $!"; 1 },
              eof   => sub { warn "eof on stderr" if 0; 1 },
              read  => sub { $stderr_msg .= $_; 0 },
          },
          $rfh => {
              error => sub { warn "error reading response: $!"; 1 },
              eof   => sub { warn "eof on stdout" if 0; 1 },
              read  => sub { $frozen_response .= $_; 0 },
          },
      });
  
      waitpid $info->{pid}, 0
          or warn "waitpid: $!"; # XXX do something more useful?
  
      die ref($self)." command (@$cmd) failed: $stderr_msg"
          if not $frozen_response; # no output on stdout at all
  
      # XXX need to be able to detect and deal with corruption
      my $response = $self->thaw_response($frozen_response);
  
      if ($stderr_msg) {
          # add stderr messages as warnings (for PrintWarn)
          $response->add_err(0, $stderr_msg, undef, $self->trace)
              # but ignore warning from old version of blib
              unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/;
      }
  
      return $response;
  }
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  DBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing
  
  =head1 SYNOPSIS
  
    $original_dsn = "...";
    DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...)
  
  or, enable by setting the DBI_AUTOPROXY environment variable:
  
    export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone"
  
  =head1 DESCRIPTION
  
  Connect via DBD::Gofer and execute each request by starting executing a subprocess.
  
  This is, as you might imagine, spectacularly inefficient!
  
  It's only intended for testing. Specifically it demonstrates that the server
  side is completely stateless.
  
  It also provides a base class for the much more useful L<DBD::Gofer::Transport::stream>
  transport.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =head1 SEE ALSO
  
  L<DBD::Gofer::Transport::Base>
  
  L<DBD::Gofer>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_PIPEONE

$fatpacked{"darwin-thread-multi-2level/DBD/Gofer/Transport/stream.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_STREAM';
  package DBD::Gofer::Transport::stream;
  
  #   $Id: stream.pm 10905 2008-03-10 22:01:04Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use Carp;
  
  use base qw(DBD::Gofer::Transport::pipeone);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10905 $ =~ /(\d+)/o);
  
  __PACKAGE__->mk_accessors(qw(
      go_persist
  )); 
  
  my $persist_all = 5;
  my %persist;
  
  
  sub _connection_key {
      my ($self) = @_;
      return join "~", $self->go_url||"", @{ $self->go_perl || [] };
  }
  
  
  sub _connection_get {
      my ($self) = @_;
  
      my $persist = $self->go_persist; # = 0 can force non-caching
      $persist = $persist_all if not defined $persist;
      my $key = ($persist) ? $self->_connection_key : '';
      if ($persist{$key} && $self->_connection_check($persist{$key})) {
          $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1;
          return $persist{$key};
      }
  
      my $connection = $self->_make_connection;
  
      if ($key) {
          %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses
          $persist{$key} = $connection;
      }
  
      return $connection;
  }
  
  
  sub _connection_check {
      my ($self, $connection) = @_;
      $connection ||= $self->connection_info;
      my $pid = $connection->{pid};
      my $ok = (kill 0, $pid);
      $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace;
      return $ok;
  }
  
  
  sub _connection_kill {
      my ($self) = @_;
      my $connection = $self->connection_info;
      my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)};
      $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace;
      # closing the write file handle should be enough, generally
      close $wfh;
      # in future we may want to be more aggressive
      #close $rfh; close $efh; kill 15, $pid
      # but deleting from the persist cache...
      delete $persist{ $self->_connection_key };
      # ... and removing the connection_info should suffice
      $self->connection_info( undef );
      return;
  }
  
  
  sub _make_connection {
      my ($self) = @_;
  
      my $go_perl = $self->go_perl;
      my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)];
  
      #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c";
      if (my $url = $self->go_url) {
          die "Only 'ssh:user\@host' style url supported by this transport"
              unless $url =~ s/^ssh://;
          my $ssh = $url;
          my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile);
          my $setup = $setup_env.q{; exec "$@"};
          # don't use $^X on remote system by default as it's possibly wrong
          $cmd->[0] = 'perl' if "@$go_perl" eq $^X;
          # -x not only 'Disables X11 forwarding' but also makes connections *much* faster
          unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup;
      }
  
      $self->trace_msg("new connection: @$cmd\n",0) if $self->trace;
  
      # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's
      # sent as soon as it starts that we can wait for to report success - and soak up
      # and report useful warnings etc from ssh before we get it? Increases latency though.
      my $connection = $self->start_pipe_command($cmd);
      return $connection;
  }
  
  
  sub transmit_request_by_transport {
      my ($self, $request) = @_;
      my $trace = $self->trace;
  
      my $connection = $self->connection_info || do {
          my $con = $self->_connection_get;
          $self->connection_info( $con );
          $con;
      };
  
      my $encoded_request = unpack("H*", $self->freeze_request($request));
      $encoded_request .= "\015\012";
  
      my $wfh = $connection->{wfh};
      $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0)
          if $trace >= 4;
  
      # send frozen request
      local $\;
      print $wfh $encoded_request # autoflush enabled
          or do {
              # XXX should make new connection and retry
              $self->_connection_kill;
              die "Error sending request: $!";
          };
      $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4;
  
      return;
  }
  
  
  sub receive_response_by_transport {
      my $self = shift;
      my $trace = $self->trace;
  
      $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4;
      my $connection = $self->connection_info || die;
      my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)};
  
      my $errno = 0;
      my $encoded_response;
      my $stderr_msg;
  
      $self->read_response_from_fh( {
          $efh => {
              error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 },
              eof   => sub { warn "eof reading efh" if $trace >= 4; 1 },
              read  => sub { $stderr_msg .= $_; 0 },
          },
          $rfh => {
              error => sub { warn "error reading response: $!"; $errno||=$!; 1 },
              eof   => sub { warn "eof reading rfh" if $trace >= 4; 1 },
              read  => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 },
          },
      });
  
      # if we got no output on stdout at all then the command has
      # probably exited, possibly with an error to stderr.
      # Turn this situation into a reasonably useful DBI error.
      if (not $encoded_response) {
          my @msg;
          push @msg, "error while reading response: $errno" if $errno;
          if ($stderr_msg) {
              chomp $stderr_msg;
              push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s",
                  $self->cmd_as_string,
                  $pid, ((kill 0, $pid) ? "" : ", exited"),
                  $stderr_msg;
          }
          die join(", ", "No response received", @msg)."\n";
      }
  
      $self->trace_msg("Response received: $encoded_response\n",0)
          if $trace >= 4;
  
      $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0)
          if $stderr_msg && $trace;
  
      my $frozen_response = pack("H*", $encoded_response);
  
      # XXX need to be able to detect and deal with corruption
      my $response = $self->thaw_response($frozen_response);
  
      if ($stderr_msg) {
          # add stderr messages as warnings (for PrintWarn)
          $response->add_err(0, $stderr_msg, undef, $trace)
              # but ignore warning from old version of blib
              unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/;
      }   
  
      return $response;
  }
  
  sub transport_timedout {
      my $self = shift;
      $self->_connection_kill;
      return $self->SUPER::transport_timedout(@_);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  DBD::Gofer::Transport::stream - DBD::Gofer transport for stdio streaming
  
  =head1 SYNOPSIS
  
    DBI->connect('dbi:Gofer:transport=stream;url=ssh:username@host.example.com;dsn=dbi:...',...)
  
  or, enable by setting the DBI_AUTOPROXY environment variable:
  
    export DBI_AUTOPROXY='dbi:Gofer:transport=stream;url=ssh:username@host.example.com'
  
  =head1 DESCRIPTION
  
  Without the C<url=> parameter it launches a subprocess as
  
    perl -MDBI::Gofer::Transport::stream -e run_stdio_hex
  
  and feeds requests into it and reads responses from it. But that's not very useful.
  
  With a C<url=ssh:username@host.example.com> parameter it uses ssh to launch the subprocess
  on a remote system. That's much more useful!
  
  It gives you secure remote access to DBI databases on any system you can login to.
  Using ssh also gives you optional compression and many other features (see the
  ssh manual for how to configure that and many other options via ~/.ssh/config file).
  
  The actual command invoked is something like:
  
    ssh -xq ssh:username@host.example.com bash -c $setup $run
  
  where $run is the command shown above, and $command is
  
    . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile 2>/dev/null; exec "$@"
  
  which is trying (in a limited and fairly unportable way) to setup the environment
  (PATH, PERL5LIB etc) as it would be if you had logged in to that system.
  
  The "C<perl>" used in the command will default to the value of $^X when not using ssh.
  On most systems that's the full path to the perl that's currently executing.
  
  
  =head1 PERSISTENCE
  
  Currently gofer stream connections persist (remain connected) after all
  database handles have been disconnected. This makes later connections in the
  same process very fast.
  
  Currently up to 5 different gofer stream connections (based on url) can
  persist.  If more than 5 are in the cache when a new connection is made then
  the cache is cleared before adding the new connection. Simple but effective.
  
  =head1 TO DO
  
  Document go_perl attribute
  
  Automatically reconnect (within reason) if there's a transport error.
  
  Decide on default for persistent connection - on or off? limits? ttl?
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =head1 SEE ALSO
  
  L<DBD::Gofer::Transport::Base>
  
  L<DBD::Gofer>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_GOFER_TRANSPORT_STREAM

$fatpacked{"darwin-thread-multi-2level/DBD/NullP.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_NULLP';
  {
      package DBD::NullP;
  
      require DBI;
      require Carp;
  
      @EXPORT = qw(); # Do NOT @EXPORT anything.
      $VERSION = sprintf("12.%06d", q$Revision: 9215 $ =~ /(\d+)/o);
  
  #   $Id: NullP.pm 9215 2007-03-08 17:03:58Z timbo $
  #
  #   Copyright (c) 1994-2007 Tim Bunce
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
      $drh = undef;	# holds driver handle once initialised
  
      sub driver{
  	return $drh if $drh;
  	my($class, $attr) = @_;
  	$class .= "::dr";
  	($drh) = DBI::_new_drh($class, {
  	    'Name' => 'NullP',
  	    'Version' => $VERSION,
  	    'Attribution' => 'DBD Example Null Perl stub by Tim Bunce',
  	    }, [ qw'example implementors private data']);
  	$drh;
      }
  
      sub CLONE {
          undef $drh;
      }
  }
  
  
  {   package DBD::NullP::dr; # ====== DRIVER ======
      $imp_data_size = 0;
      use strict;
  
      sub connect { # normally overridden, but a handy default
          my $dbh = shift->SUPER::connect(@_)
              or return;
          $dbh->STORE(Active => 1); 
          $dbh;
      }
  
  
      sub DESTROY { undef }
  }
  
  
  {   package DBD::NullP::db; # ====== DATABASE ======
      $imp_data_size = 0;
      use strict;
      use Carp qw(croak);
  
      sub prepare {
  	my ($dbh, $statement)= @_;
  
  	my ($outer, $sth) = DBI::_new_sth($dbh, {
  	    'Statement'     => $statement,
          });
  
  	return $outer;
      }
  
      sub FETCH {
  	my ($dbh, $attrib) = @_;
  	# In reality this would interrogate the database engine to
  	# either return dynamic values that cannot be precomputed
  	# or fetch and cache attribute values too expensive to prefetch.
  	return $dbh->SUPER::FETCH($attrib);
      }
  
      sub STORE {
  	my ($dbh, $attrib, $value) = @_;
  	# would normally validate and only store known attributes
  	# else pass up to DBI to handle
  	if ($attrib eq 'AutoCommit') {
  	    Carp::croak("Can't disable AutoCommit") unless $value;
              # convert AutoCommit values to magic ones to let DBI
              # know that the driver has 'handled' the AutoCommit attribute
              $value = ($value) ? -901 : -900;
  	}
  	return $dbh->SUPER::STORE($attrib, $value);
      }
  
      sub ping { 1 }
  
      sub disconnect {
  	shift->STORE(Active => 0);
      }
  
  }
  
  
  {   package DBD::NullP::st; # ====== STATEMENT ======
      $imp_data_size = 0;
      use strict;
  
      sub bind_param {
          my ($sth, $param, $value, $attr) = @_;
          $sth->{ParamValues}{$param} = $value;
          $sth->{ParamAttr}{$param}   = $attr
              if defined $attr; # attr is sticky if not explicitly set
          return 1;
      }       
  
      sub execute {
  	my $sth = shift;
          $sth->bind_param($_, $_[$_-1]) for (1..@_);
          if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) {
              $sth->STORE(NUM_OF_FIELDS => 1); 
              $sth->{NAME} = [ "fieldname" ];
              # just for the sake of returning something, we return the params
              my $params = $sth->{ParamValues} || {};
              $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
              $sth->STORE(Active => 1); 
          }
  	1;
      }
  
      sub fetchrow_arrayref {
  	my $sth = shift;
  	my $data = $sth->{dbd_nullp_data};
          if (!$data || !@$data) {
              $sth->finish;     # no more data so finish
              return undef;
  	}
          return $sth->_set_fbav(shift @$data);
      }
      *fetch = \&fetchrow_arrayref; # alias
  
      sub FETCH {
  	my ($sth, $attrib) = @_;
  	# would normally validate and only fetch known attributes
  	# else pass up to DBI to handle
  	return $sth->SUPER::FETCH($attrib);
      }
  
      sub STORE {
  	my ($sth, $attrib, $value) = @_;
  	# would normally validate and only store known attributes
  	# else pass up to DBI to handle
  	return $sth->SUPER::STORE($attrib, $value);
      }
  
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBD_NULLP

$fatpacked{"darwin-thread-multi-2level/DBD/Proxy.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_PROXY';
  #   -*- perl -*-
  #
  #
  #   DBD::Proxy - DBI Proxy driver
  #
  #
  #   Copyright (c) 1997,1998  Jochen Wiedmann
  #
  #   The DBD::Proxy module is free software; you can redistribute it and/or
  #   modify it under the same terms as Perl itself. In particular permission
  #   is granted to Tim Bunce for distributing this as a part of the DBI.
  #
  #
  #   Author: Jochen Wiedmann
  #           Am Eisteich 9
  #           72555 Metzingen
  #           Germany
  #
  #           Email: joe@ispsoft.de
  #           Phone: +49 7123 14881
  #
  
  use strict;
  use Carp;
  
  require DBI;
  DBI->require_version(1.0201);
  
  use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released
  
  {	package DBD::Proxy::RPC::PlClient;
      	@DBD::Proxy::RPC::PlClient::ISA = qw(RPC::PlClient);
  	sub Call {
  	    my $self = shift;
  	    if ($self->{debug}) {
  		my ($rpcmeth, $obj, $method, @args) = @_;
  		local $^W; # silence undefs
  		Carp::carp("Server $rpcmeth $method(@args)");
  	    }
  	    return $self->SUPER::Call(@_);
  	}
  }
  
  
  package DBD::Proxy;
  
  use vars qw($VERSION $drh %ATTR);
  
  $VERSION = "0.2004";
  
  $drh = undef;		# holds driver handle once initialised
  
  %ATTR = (	# common to db & st, see also %ATTR in DBD::Proxy::db & ::st
      'Warn'	=> 'local',
      'Active'	=> 'local',
      'Kids'	=> 'local',
      'CachedKids' => 'local',
      'PrintError' => 'local',
      'RaiseError' => 'local',
      'HandleError' => 'local',
      'TraceLevel' => 'cached',
      'CompatMode' => 'local',
  );
  
  sub driver ($$) {
      if (!$drh) {
  	my($class, $attr) = @_;
  
  	$class .= "::dr";
  
  	$drh = DBI::_new_drh($class, {
  	    'Name' => 'Proxy',
  	    'Version' => $VERSION,
  	    'Attribution' => 'DBD::Proxy by Jochen Wiedmann',
  	});
  	$drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH)
      }
      $drh;
  }
  
  sub CLONE {
      undef $drh;
  }
  
  sub proxy_set_err {
    my ($h,$errmsg) = @_;
    my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//)
  	? ($1, $2) : (1, ' ' x 5);
    return $h->set_err($err, $errmsg, $state);
  }
  
  package DBD::Proxy::dr; # ====== DRIVER ======
  
  $DBD::Proxy::dr::imp_data_size = 0;
  
  sub connect ($$;$$) {
      my($drh, $dsn, $user, $auth, $attr)= @_;
      my($dsnOrig) = $dsn;
  
      my %attr = %$attr;
      my ($var, $val);
      while (length($dsn)) {
  	if ($dsn =~ /^dsn=(.*)/) {
  	    $attr{'dsn'} = $1;
  	    last;
  	}
  	if ($dsn =~ /^(.*?);(.*)/) {
  	    $var = $1;
  	    $dsn = $2;
  	} else {
  	    $var = $dsn;
  	    $dsn = '';
  	}
  	if ($var =~ /^(.*?)=(.*)/) {
  	    $var = $1;
  	    $val = $2;
  	    $attr{$var} = $val;
  	}
      }
  
      my $err = '';
      if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; }
      if (!defined($attr{'port'}))     { $err .= " Missing port."; }
      if (!defined($attr{'dsn'}))      { $err .= " Missing remote dsn."; }
  
      # Create a cipher object, if requested
      my $cipherRef = undef;
      if ($attr{'cipher'}) {
  	$cipherRef = eval { $attr{'cipher'}->new(pack('H*',
  							$attr{'key'})) };
  	if ($@) { $err .= " Cannot create cipher object: $@."; }
      }
      my $userCipherRef = undef;
      if ($attr{'userkey'}) {
  	my $cipher = $attr{'usercipher'} || $attr{'cipher'};
  	$userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) };
  	if ($@) { $err .= " Cannot create usercipher object: $@."; }
      }
  
      return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef
  
      my %client_opts = (
  		       'peeraddr'	=> $attr{'hostname'},
  		       'peerport'	=> $attr{'port'},
  		       'socket_proto'	=> 'tcp',
  		       'application'	=> $attr{dsn},
  		       'user'		=> $user || '',
  		       'password'	=> $auth || '',
  		       'version'	=> $DBD::Proxy::VERSION,
  		       'cipher'	        => $cipherRef,
  		       'debug'		=> $attr{debug}   || 0,
  		       'timeout'	=> $attr{timeout} || undef,
  		       'logfile'	=> $attr{logfile} || undef
  		      );
      # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after
      # stripping the prefix.
      while (my($var,$val) = each %attr) {
  	if ($var =~ s/^proxy_rpc_//) {
  	    $client_opts{$var} = $val;
  	}
      }
      # Create an RPC::PlClient object.
      my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) };
  
      return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@")
  	if $@; # Returns undef
      return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg")
  	unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef
  
      $msg = RPC::PlClient::Object->new($1, $client, $msg);
  
      my $max_proto_ver;
      my ($server_ver_str) = eval { $client->Call('Version') };
      if ( $@ ) {
        # Server denies call, assume legacy protocol.
        $max_proto_ver = 1;
      } else {
        # Parse proxy server version.
        my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/;
        $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1;
      }
      my $req_proto_ver;
      if ( exists $attr{proxy_lazy_prepare} ) {
        $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1;
        return DBD::Proxy::proxy_set_err($drh, 
                   "DBI::ProxyServer does not support synchronous statement preparation.")
  	if $max_proto_ver < $req_proto_ver;
      }
  
      # Switch to user specific encryption mode, if desired
      if ($userCipherRef) {
  	$client->{'cipher'} = $userCipherRef;
      }
  
      # create a 'blank' dbh
      my $this = DBI::_new_dbh($drh, {
  	    'Name' => $dsnOrig,
  	    'proxy_dbh' => $msg,
  	    'proxy_client' => $client,
  	    'RowCacheSize' => $attr{'RowCacheSize'} || 20,
  	    'proxy_proto_ver' => $req_proto_ver || 1
     });
  
      foreach $var (keys %attr) {
  	if ($var =~ /proxy_/) {
  	    $this->{$var} = $attr{$var};
  	}
      }
      $this->SUPER::STORE('Active' => 1);
  
      $this;
  }
  
  
  sub DESTROY { undef }
  
  
  package DBD::Proxy::db; # ====== DATABASE ======
  
  $DBD::Proxy::db::imp_data_size = 0;
  
  # XXX probably many more methods need to be added here
  # in order to trigger our AUTOLOAD to redirect them to the server.
  # (Unless the sub is declared it's bypassed by perl method lookup.)
  # See notes in ToDo about method metadata
  # The question is whether to add all the methods in %DBI::DBI_methods
  # to the corresponding classes (::db, ::st etc)
  # Also need to consider methods that, if proxied, would change the server state
  # in a way that might not be visible on the client, ie begin_work -> AutoCommit.
  
  sub commit;
  sub connected;
  sub rollback;
  sub ping;
  
  
  use vars qw(%ATTR $AUTOLOAD);
  
  # inherited: STORE / FETCH against this class.
  # local:     STORE / FETCH against parent class.
  # cached:    STORE to remote and local objects, FETCH from local.
  # remote:    STORE / FETCH against remote object only (default).
  #
  # Note: Attribute names starting with 'proxy_' always treated as 'inherited'.
  #
  %ATTR = (	# see also %ATTR in DBD::Proxy::st
      %DBD::Proxy::ATTR,
      RowCacheSize => 'inherited',
      #AutoCommit => 'cached',
      'FetchHashKeyName' => 'cached',
      Statement => 'local',
      Driver => 'local',
      dbi_connect_closure => 'local',
      Username => 'local',
  );
  
  sub AUTOLOAD {
      my $method = $AUTOLOAD;
      $method =~ s/(.*::(.*)):://;
      my $class = $1;
      my $type = $2;
      #warn "AUTOLOAD of $method (class=$class, type=$type)";
      my %expand = (
          'method' => $method,
          'class' => $class,
          'type' => $type,
          'call' => "$method(\@_)",
          # XXX was trying to be smart but was tripping up over the DBI's own
          # smartness. Disabled, but left here in case there are issues.
      #   'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')",
      );
  
      my $method_code = q{
          package ~class~;
          sub ~method~ {
              my $h = shift;
              local $@;
              my @result = wantarray
                  ? eval {        $h->{'proxy_~type~h'}->~call~ }
                  : eval { scalar $h->{'proxy_~type~h'}->~call~ };
              return DBD::Proxy::proxy_set_err($h, $@) if $@;
              return wantarray ? @result : $result[0];
          }
      };
      $method_code =~ s/\~(\w+)\~/$expand{$1}/eg;
      local $SIG{__DIE__} = 'DEFAULT';
      my $err = do { local $@; eval $method_code.2; $@ };
      die $err if $err;
      goto &$AUTOLOAD;
  }
  
  sub DESTROY {
      my $dbh = shift;
      local $@ if $@;	# protect $@
      $dbh->disconnect if $dbh->SUPER::FETCH('Active');
  }
  
  sub disconnect ($) {
      my ($dbh) = @_;
  
      # Sadly the Proxy too-often disagrees with the backend database
      # on the subject of 'Active'.  In the short term, I'd like the
      # Proxy to ease up and let me decide when it's proper to go over
      # the wire.  This ultimately applies to finish() as well.
      #return unless $dbh->SUPER::FETCH('Active');
  
      # Drop database connection at remote end
      my $rdbh = $dbh->{'proxy_dbh'};
      if ( $rdbh ) {
          local $SIG{__DIE__} = 'DEFAULT';
          local $@;
  	eval { $rdbh->disconnect() } ;
          DBD::Proxy::proxy_set_err($dbh, $@) if $@;
      }
      
      # Close TCP connect to remote
      # XXX possibly best left till DESTROY? Add a config attribute to choose?
      #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module
      $dbh->{proxy_client}->{socket} = undef; # hack
  
      $dbh->SUPER::STORE('Active' => 0);
      1;
  }
  
  
  sub STORE ($$$) {
      my($dbh, $attr, $val) = @_;
      my $type = $ATTR{$attr} || 'remote';
  
      if ($attr eq 'TraceLevel') {
  	warn("TraceLevel $val");
  	my $pc = $dbh->{proxy_client} || die;
  	$pc->{logfile} ||= 1; # XXX hack
  	$pc->{debug} = ($val && $val >= 4);
  	$pc->Debug("$pc debug enabled") if $pc->{debug};
      }
  
      if ($attr =~ /^proxy_/  ||  $type eq 'inherited') {
  	$dbh->{$attr} = $val;
  	return 1;
      }
  
      if ($type eq 'remote' ||  $type eq 'cached') {
          local $SIG{__DIE__} = 'DEFAULT';
  	local $@;
  	my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) };
  	return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef
  	$dbh->SUPER::STORE($attr => $val) if $type eq 'cached';
  	return $result;
      }
      return $dbh->SUPER::STORE($attr => $val);
  }
  
  sub FETCH ($$) {
      my($dbh, $attr) = @_;
      # we only get here for cached attribute values if the handle is in CompatMode
      # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache.
      my $type = $ATTR{$attr} || 'remote';
  
      if ($attr =~ /^proxy_/  ||  $type eq 'inherited'  || $type eq 'cached') {
  	return $dbh->{$attr};
      }
  
      return $dbh->SUPER::FETCH($attr) unless $type eq 'remote';
  
      local $SIG{__DIE__} = 'DEFAULT';
      local $@;
      my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) };
      return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
      return $result;
  }
  
  sub prepare ($$;$) {
      my($dbh, $stmt, $attr) = @_;
      my $sth = DBI::_new_sth($dbh, {
  				   'Statement' => $stmt,
  				   'proxy_attr' => $attr,
  				   'proxy_cache_only' => 0,
  				   'proxy_params' => [],
  				  }
  			   );
      my $proto_ver = $dbh->{'proxy_proto_ver'};
      if ( $proto_ver > 1 ) {
        $sth->{'proxy_attr_cache'} = {cache_filled => 0};
        my $rdbh = $dbh->{'proxy_dbh'};
        local $SIG{__DIE__} = 'DEFAULT';
        local $@;
        my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) };
        return DBD::Proxy::proxy_set_err($sth, $@) if $@;
        return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth")
  	unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/);
      
        my $client = $dbh->{'proxy_client'};
        $rsth = RPC::PlClient::Object->new($1, $client, $rsth);
        
        $sth->{'proxy_sth'} = $rsth;
        # If statement is a positioned update we do not want any readahead.
        $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i;
      # Since resources are used by prepared remote handle, mark us active.
      $sth->SUPER::STORE(Active => 1);
      }
      $sth;
  }
  
  sub quote {
      my $dbh = shift;
      my $proxy_quote = $dbh->{proxy_quote} || 'remote';
  
      return $dbh->SUPER::quote(@_)
  	if $proxy_quote eq 'local' && @_ == 1;
  
      # For the common case of only a single argument
      # (no $data_type) we could learn and cache the behaviour.
      # Or we could probe the driver with a few test cases.
      # Or we could add a way to ask the DBI::ProxyServer
      # if $dbh->can('quote') == \&DBI::_::db::quote.
      # Tim
      #
      # Sounds all *very* smart to me. I'd rather suggest to
      # implement some of the typical quote possibilities
      # and let the user set
      #    $dbh->{'proxy_quote'} = 'backslash_escaped';
      # for example.
      # Jochen
      local $SIG{__DIE__} = 'DEFAULT';
      local $@;
      my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) };
      return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
      return $result;
  }
  
  sub table_info {
      my $dbh = shift;
      my $rdbh = $dbh->{'proxy_dbh'};
      #warn "table_info(@_)";
      local $SIG{__DIE__} = 'DEFAULT';
      local $@;
      my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) };
      return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
      my ($sth, $inner) = DBI::_new_sth($dbh, {
          'Statement' => "SHOW TABLES",
  	'proxy_params' => [],
  	'proxy_data' => \@rows,
  	'proxy_attr_cache' => { 
  		'NUM_OF_PARAMS' => 0, 
  		'NUM_OF_FIELDS' => $numFields, 
  		'NAME' => $names, 
  		'TYPE' => $types,
  		'cache_filled' => 1
  		},
      	'proxy_cache_only' => 1,
      });
      $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
      $inner->{NAME} = $names;
      $inner->{TYPE} = $types;
      $sth->SUPER::STORE('Active' => 1); # already execute()'d
      $sth->{'proxy_rows'} = @rows;
      return $sth;
  }
  
  sub tables {
      my $dbh = shift;
      #warn "tables(@_)";
      return $dbh->SUPER::tables(@_);
  }
  
  
  sub type_info_all {
      my $dbh = shift;
      local $SIG{__DIE__} = 'DEFAULT';
      local $@;
      my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) };
      return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
      return $result;
  }
  
  
  package DBD::Proxy::st; # ====== STATEMENT ======
  
  $DBD::Proxy::st::imp_data_size = 0;
  
  use vars qw(%ATTR);
  
  # inherited:  STORE to current object. FETCH from current if exists, else call up
  #              to the (proxy) database object.
  # local:      STORE / FETCH against parent class.
  # cache_only: STORE noop (read-only).  FETCH from private_* if exists, else call
  #              remote and cache the result.
  # remote:     STORE / FETCH against remote object only (default).
  #
  # Note: Attribute names starting with 'proxy_' always treated as 'inherited'.
  #
  %ATTR = (	# see also %ATTR in DBD::Proxy::db
      %DBD::Proxy::ATTR,
      'Database' => 'local',
      'RowsInCache' => 'local',
      'RowCacheSize' => 'inherited',
      'NULLABLE' => 'cache_only',
      'NAME' => 'cache_only',
      'TYPE' => 'cache_only',
      'PRECISION' => 'cache_only',
      'SCALE' => 'cache_only',
      'NUM_OF_FIELDS' => 'cache_only',
      'NUM_OF_PARAMS' => 'cache_only'
  );
  
  *AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD;
  
  sub execute ($@) {
      my $sth = shift;
      my $params = @_ ? \@_ : $sth->{'proxy_params'};
  
      # new execute, so delete any cached rows from previous execute
      undef $sth->{'proxy_data'};
      undef $sth->{'proxy_rows'};
  
      my $rsth = $sth->{proxy_sth};
      my $dbh = $sth->FETCH('Database');
      my $proto_ver = $dbh->{proxy_proto_ver};
  
      my ($numRows, @outData);
  
      local $SIG{__DIE__} = 'DEFAULT';
      local $@;
      if ( $proto_ver > 1 ) {
        ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) };
        return DBD::Proxy::proxy_set_err($sth, $@) if $@;
        
        # Attributes passed back only on the first execute() of a statement.
        unless ($sth->{proxy_attr_cache}->{cache_filled}) {
  	my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); 
  	$sth->{'proxy_attr_cache'} = {
  				      'NUM_OF_FIELDS' => $numFields,
  				      'NUM_OF_PARAMS' => $numParams,
  				      'NAME'          => $names,
  				      'cache_filled'  => 1
  				     };
  	$sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
  	$sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams);
        }
  
      }
      else {
        if ($rsth) {
  	($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) };
  	return DBD::Proxy::proxy_set_err($sth, $@) if $@;
  
        }
        else {
  	my $rdbh = $dbh->{'proxy_dbh'};
  	
  	# Legacy prepare is actually prepare + first execute on the server.
          ($rsth, @outData) =
  	  eval { $rdbh->prepare($sth->{'Statement'},
  				$sth->{'proxy_attr'}, $params, $proto_ver) };
  	return DBD::Proxy::proxy_set_err($sth, $@) if $@;
  	return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth")
  	  unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/);
  	
  	my $client = $dbh->{'proxy_client'};
  	$rsth = RPC::PlClient::Object->new($1, $client, $rsth);
  
  	my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4);
  	$sth->{'proxy_sth'} = $rsth;
          $sth->{'proxy_attr_cache'} = {
  	    'NUM_OF_FIELDS' => $numFields,
  	    'NUM_OF_PARAMS' => $numParams,
  	    'NAME'          => $names
          };
  	$sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
  	$sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams);
  	$numRows = shift @outData;
        }
      }
      # Always condition active flag.
      $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT
      $sth->{'proxy_rows'} = $numRows;
      # Any remaining items are output params.
      if (@outData) {
  	foreach my $p (@$params) {
  	    if (ref($p->[0])) {
  		my $ref = shift @outData;
  		${$p->[0]} = $$ref;
  	    }
  	}
      }
  
      $sth->{'proxy_rows'} || '0E0';
  }
  
  sub fetch ($) {
      my $sth = shift;
  
      my $data = $sth->{'proxy_data'};
  
      $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'};
  
      if(!$data || !@$data) {
  	return undef unless $sth->SUPER::FETCH('Active');
  
  	my $rsth = $sth->{'proxy_sth'};
  	if (!$rsth) {
  	    die "Attempt to fetch row without execute";
  	}
  	my $num_rows = $sth->FETCH('RowCacheSize') || 20;
  	local $SIG{__DIE__} = 'DEFAULT';
  	local $@;
  	my @rows = eval { $rsth->fetch($num_rows) };
  	return DBD::Proxy::proxy_set_err($sth, $@) if $@;
  	unless (@rows == $num_rows) {
  	    undef $sth->{'proxy_data'};
  	    # server side has already called finish
  	    $sth->SUPER::STORE(Active => 0);
  	}
  	return undef unless @rows;
  	$sth->{'proxy_data'} = $data = [@rows];
      }
      my $row = shift @$data;
  
      $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data );
      $sth->{'proxy_rows'}++;
      return $sth->_set_fbav($row);
  }
  *fetchrow_arrayref = \&fetch;
  
  sub rows ($) {
      my $rows = shift->{'proxy_rows'};
      return (defined $rows) ? $rows : -1;
  }
  
  sub finish ($) {
      my($sth) = @_;
      return 1 unless $sth->SUPER::FETCH('Active');
      my $rsth = $sth->{'proxy_sth'};
      $sth->SUPER::STORE('Active' => 0);
      return 0 unless $rsth; # Something's out of sync
      my $no_finish = exists($sth->{'proxy_no_finish'})
   	? $sth->{'proxy_no_finish'}
  	: $sth->FETCH('Database')->{'proxy_no_finish'};
      unless ($no_finish) {
          local $SIG{__DIE__} = 'DEFAULT';
  	local $@;
  	my $result = eval { $rsth->finish() };
  	return DBD::Proxy::proxy_set_err($sth, $@) if $@;
  	return $result;
      }
      1;
  }
  
  sub STORE ($$$) {
      my($sth, $attr, $val) = @_;
      my $type = $ATTR{$attr} || 'remote';
  
      if ($attr =~ /^proxy_/  ||  $type eq 'inherited') {
  	$sth->{$attr} = $val;
  	return 1;
      }
  
      if ($type eq 'cache_only') {
  	return 0;
      }
  
      if ($type eq 'remote' || $type eq 'cached') {
  	my $rsth = $sth->{'proxy_sth'}  or  return undef;
          local $SIG{__DIE__} = 'DEFAULT';
  	local $@;
  	my $result = eval { $rsth->STORE($attr => $val) };
  	return DBD::Proxy::proxy_set_err($sth, $@) if ($@);
  	return $result if $type eq 'remote'; # else fall through to cache locally
      }
      return $sth->SUPER::STORE($attr => $val);
  }
  
  sub FETCH ($$) {
      my($sth, $attr) = @_;
  
      if ($attr =~ /^proxy_/) {
  	return $sth->{$attr};
      }
  
      my $type = $ATTR{$attr} || 'remote';
      if ($type eq 'inherited') {
  	if (exists($sth->{$attr})) {
  	    return $sth->{$attr};
  	}
  	return $sth->FETCH('Database')->{$attr};
      }
  
      if ($type eq 'cache_only'  &&
  	    exists($sth->{'proxy_attr_cache'}->{$attr})) {
  	return $sth->{'proxy_attr_cache'}->{$attr};
      }
  
      if ($type ne 'local') {
  	my $rsth = $sth->{'proxy_sth'}  or  return undef;
          local $SIG{__DIE__} = 'DEFAULT';
  	local $@;
  	my $result = eval { $rsth->FETCH($attr) };
  	return DBD::Proxy::proxy_set_err($sth, $@) if $@;
  	return $result;
      }
      elsif ($attr eq 'RowsInCache') {
  	my $data = $sth->{'proxy_data'};
  	$data ? @$data : 0;
      }
      else {
  	$sth->SUPER::FETCH($attr);
      }
  }
  
  sub bind_param ($$$@) {
      my $sth = shift; my $param = shift;
      $sth->{'proxy_params'}->[$param-1] = [@_];
  }
  *bind_param_inout = \&bind_param;
  
  sub DESTROY {
      my $sth = shift;
      $sth->finish if $sth->SUPER::FETCH('Active');
  }
  
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  DBD::Proxy - A proxy driver for the DBI
  
  =head1 SYNOPSIS
  
    use DBI;
  
    $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db",
                        $user, $passwd);
  
    # See the DBI module documentation for full details
  
  =head1 DESCRIPTION
  
  DBD::Proxy is a Perl module for connecting to a database via a remote
  DBI driver. See L<DBD::Gofer> for an alternative with different trade-offs.
  
  This is of course not needed for DBI drivers which already
  support connecting to a remote database, but there are engines which
  don't offer network connectivity.
  
  Another application is offering database access through a firewall, as
  the driver offers query based restrictions. For example you can
  restrict queries to exactly those that are used in a given CGI
  application.
  
  Speaking of CGI, another application is (or rather, will be) to reduce
  the database connect/disconnect overhead from CGI scripts by using
  proxying the connect_cached method. The proxy server will hold the
  database connections open in a cache. The CGI script then trades the
  database connect/disconnect overhead for the DBD::Proxy
  connect/disconnect overhead which is typically much less.
  I<Note that the connect_cached method is new and still experimental.>
  
  
  =head1 CONNECTING TO THE DATABASE
  
  Before connecting to a remote database, you must ensure, that a Proxy
  server is running on the remote machine. There's no default port, so
  you have to ask your system administrator for the port number. See
  L<DBI::ProxyServer> for details.
  
  Say, your Proxy server is running on machine "alpha", port 3334, and
  you'd like to connect to an ODBC database called "mydb" as user "joe"
  with password "hello". When using DBD::ODBC directly, you'd do a
  
    $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello");
  
  With DBD::Proxy this becomes
  
    $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb";
    $dbh = DBI->connect($dsn, "joe", "hello");
  
  You see, this is mainly the same. The DBD::Proxy module will create a
  connection to the Proxy server on "alpha" which in turn will connect
  to the ODBC database.
  
  Refer to the L<DBI> documentation on the C<connect> method for a way
  to automatically use DBD::Proxy without having to change your code.
  
  DBD::Proxy's DSN string has the format
  
    $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN";
  
  In other words, it is a collection of key/value pairs. The following
  keys are recognized:
  
  =over 4
  
  =item hostname
  
  =item port
  
  Hostname and port of the Proxy server; these keys must be present,
  no defaults. Example:
  
      hostname=alpha;port=3334
  
  =item dsn
  
  The value of this attribute will be used as a dsn name by the Proxy
  server. Thus it must have the format C<DBI:driver:...>, in particular
  it will contain colons. The I<dsn> value may contain semicolons, hence
  this key *must* be the last and it's value will be the complete
  remaining part of the dsn. Example:
  
      dsn=DBI:ODBC:mydb
  
  =item cipher
  
  =item key
  
  =item usercipher
  
  =item userkey
  
  By using these fields you can enable encryption. If you set,
  for example,
  
      cipher=$class;key=$key
  
  (note the semicolon) then DBD::Proxy will create a new cipher object
  by executing
  
      $cipherRef = $class->new(pack("H*", $key));
  
  and pass this object to the RPC::PlClient module when creating a
  client. See L<RPC::PlClient>. Example:
  
      cipher=IDEA;key=97cd2375efa329aceef2098babdc9721
  
  The usercipher/userkey attributes allow you to use two phase encryption:
  The cipher/key encryption will be used in the login and authorisation
  phase. Once the client is authorised, he will change to usercipher/userkey
  encryption. Thus the cipher/key pair is a B<host> based secret, typically
  less secure than the usercipher/userkey secret and readable by anyone.
  The usercipher/userkey secret is B<your> private secret.
  
  Of course encryption requires an appropriately configured server. See
  <DBD::ProxyServer/CONFIGURATION FILE>.
  
  =item debug
  
  Turn on debugging mode
  
  =item stderr
  
  This attribute will set the corresponding attribute of the RPC::PlClient
  object, thus logging will not use syslog(), but redirected to stderr.
  This is the default under Windows.
  
      stderr=1
  
  =item logfile
  
  Similar to the stderr attribute, but output will be redirected to the
  given file.
  
      logfile=/dev/null
  
  =item RowCacheSize
  
  The DBD::Proxy driver supports this attribute (which is DBI standard,
  as of DBI 1.02). It's used to reduce network round-trips by fetching
  multiple rows in one go. The current default value is 20, but this may
  change.
  
  
  =item proxy_no_finish
  
  This attribute can be used to reduce network traffic: If the
  application is calling $sth->finish() then the proxy tells the server
  to finish the remote statement handle. Of course this slows down things
  quite a lot, but is prefectly good for reducing memory usage with
  persistent connections.
  
  However, if you set the I<proxy_no_finish> attribute to a TRUE value,
  either in the database handle or in the statement handle, then finish()
  calls will be supressed. This is what you want, for example, in small
  and fast CGI applications.
  
  =item proxy_quote
  
  This attribute can be used to reduce network traffic: By default calls
  to $dbh->quote() are passed to the remote driver.  Of course this slows
  down things quite a lot, but is the safest default behaviour.
  
  However, if you set the I<proxy_quote> attribute to the value 'C<local>'
  either in the database handle or in the statement handle, and the call
  to quote has only one parameter, then the local default DBI quote
  method will be used (which will be faster but may be wrong).
  
  =back
  
  =head1 KNOWN ISSUES
  
  =head2 Unproxied method calls
  
  If a method isn't being proxied, try declaring a stub sub in the appropriate
  package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method).
  For example:
  
      sub DBD::Proxy::db::selectall_arrayref;
  
  That will enable selectall_arrayref to be proxied.
  
  Currently many methods aren't explicitly proxied and so you get the DBI's
  default methods executed on the client.
  
  Some of those methods, like selectall_arrayref, may then call other methods
  that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch
  which is proxied). So things may appear to work but operate more slowly than
  the could.
  
  This may all change in a later version.
  
  =head2 Complex handle attributes
  
  Sometimes handles are having complex attributes like hash refs or
  array refs and not simple strings or integers. For example, with
  DBD::CSV, you would like to write something like
  
    $dbh->{"csv_tables"}->{"passwd"} =
          { "sep_char" => ":", "eol" => "\n";
  
  The above example would advice the CSV driver to assume the file
  "passwd" to be in the format of the /etc/passwd file: Colons as
  separators and a line feed without carriage return as line
  terminator.
  
  Surprisingly this example doesn't work with the proxy driver. To understand
  the reasons, you should consider the following: The Perl compiler is
  executing the above example in two steps:
  
  =over
  
  =item 1
  
  The first step is fetching the value of the key "csv_tables" in the
  handle $dbh. The value returned is complex, a hash ref.
  
  =item 2
  
  The second step is storing some value (the right hand side of the
  assignment) as the key "passwd" in the hash ref from step 1.
  
  =back
  
  This becomes a little bit clearer, if we rewrite the above code:
  
    $tables = $dbh->{"csv_tables"};
    $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n";
  
  While the examples work fine without the proxy, the fail due to a
  subtile difference in step 1: By DBI magic, the hash ref
  $dbh->{'csv_tables'} is returned from the server to the client.
  The client creates a local copy. This local copy is the result of
  step 1. In other words, step 2 modifies a local copy of the hash ref,
  but not the server's hash ref.
  
  The workaround is storing the modified local copy back to the server:
  
    $tables = $dbh->{"csv_tables"};
    $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n";
    $dbh->{"csv_tables"} = $tables;
  
  
  =head1 AUTHOR AND COPYRIGHT
  
  This module is Copyright (c) 1997, 1998
  
      Jochen Wiedmann
      Am Eisteich 9
      72555 Metzingen
      Germany
  
      Email: joe@ispsoft.de
      Phone: +49 7123 14887
  
  The DBD::Proxy module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. In particular permission
  is granted to Tim Bunce for distributing this as a part of the DBI.
  
  
  =head1 SEE ALSO
  
  L<DBI>, L<RPC::PlClient>, L<Storable>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_PROXY

$fatpacked{"darwin-thread-multi-2level/DBD/Sponge.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBD_SPONGE';
  {
      package DBD::Sponge;
  
      require DBI;
      require Carp;
  
      our @EXPORT = qw(); # Do NOT @EXPORT anything.
      our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o);
  
  
  #   $Id: Sponge.pm 10002 2007-09-26 21:03:25Z timbo $
  #
  #   Copyright (c) 1994-2003 Tim Bunce Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
      $drh = undef;	# holds driver handle once initialised
      my $methods_already_installed;
  
      sub driver{
  	return $drh if $drh;
  
  	DBD::Sponge::db->install_method("sponge_test_installed_method")
  		unless $methods_already_installed++;
  
  	my($class, $attr) = @_;
  	$class .= "::dr";
  	($drh) = DBI::_new_drh($class, {
  	    'Name' => 'Sponge',
  	    'Version' => $VERSION,
  	    'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce",
  	    });
  	$drh;
      }
  
      sub CLONE {
          undef $drh;
      }
  }
  
  
  {   package DBD::Sponge::dr; # ====== DRIVER ======
      $imp_data_size = 0;
      # we use default (dummy) connect method
  }
  
  
  {   package DBD::Sponge::db; # ====== DATABASE ======
      $imp_data_size = 0;
      use strict;
  
      sub prepare {
  	my($dbh, $statement, $attribs) = @_;
  	my $rows = delete $attribs->{'rows'}
  	    or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare");
  	my ($outer, $sth) = DBI::_new_sth($dbh, {
  	    'Statement'   => $statement,
  	    'rows'        => $rows,
  	    (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () }
  		qw(execute_hook)
  	    ),
  	});
  	if (my $behave_like = $attribs->{behave_like}) {
  	    $outer->{$_} = $behave_like->{$_}
  		foreach (qw(RaiseError PrintError HandleError ShowErrorStatement));
  	}
  
  	if ($statement =~ /^\s*insert\b/) {	# very basic, just for testing execute_array()
  	    $sth->{is_insert} = 1;
  	    my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS}
  		or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement");
  	    $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} );
  	}
  	else {	#assume select
  
  	    # we need to set NUM_OF_FIELDS
  	    my $numFields;
  	    if ($attribs->{'NUM_OF_FIELDS'}) {
  		$numFields = $attribs->{'NUM_OF_FIELDS'};
  	    } elsif ($attribs->{'NAME'}) {
  		$numFields = @{$attribs->{NAME}};
  	    } elsif ($attribs->{'TYPE'}) {
  		$numFields = @{$attribs->{TYPE}};
  	    } elsif (my $firstrow = $rows->[0]) {
  		$numFields = scalar @$firstrow;
  	    } else {
  		return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS');
  	    }
  	    $sth->STORE('NUM_OF_FIELDS' => $numFields);
  	    $sth->{NAME} = $attribs->{NAME}
  		    || [ map { "col$_" } 1..$numFields ];
  	    $sth->{TYPE} = $attribs->{TYPE}
  		    || [ (DBI::SQL_VARCHAR()) x $numFields ];
  	    $sth->{PRECISION} = $attribs->{PRECISION}
  		    || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ];
  	    $sth->{SCALE} = $attribs->{SCALE}
  		    || [ (0) x $numFields ];
  	    $sth->{NULLABLE} = $attribs->{NULLABLE}
  		    || [ (2) x $numFields ];
  	}
  
  	$outer;
      }
  
      sub type_info_all {
  	my ($dbh) = @_;
  	my $ti = [
  	    {	TYPE_NAME	=> 0,
  		DATA_TYPE	=> 1,
  		PRECISION	=> 2,
  		LITERAL_PREFIX	=> 3,
  		LITERAL_SUFFIX	=> 4,
  		CREATE_PARAMS	=> 5,
  		NULLABLE	=> 6,
  		CASE_SENSITIVE	=> 7,
  		SEARCHABLE	=> 8,
  		UNSIGNED_ATTRIBUTE=> 9,
  		MONEY		=> 10,
  		AUTO_INCREMENT	=> 11,
  		LOCAL_TYPE_NAME	=> 12,
  		MINIMUM_SCALE	=> 13,
  		MAXIMUM_SCALE	=> 14,
  	    },
  	    [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
  	];
  	return $ti;
      }
  
      sub FETCH {
          my ($dbh, $attrib) = @_;
          # In reality this would interrogate the database engine to
          # either return dynamic values that cannot be precomputed
          # or fetch and cache attribute values too expensive to prefetch.
          return 1 if $attrib eq 'AutoCommit';
          # else pass up to DBI to handle
          return $dbh->SUPER::FETCH($attrib);
      }
  
      sub STORE {
          my ($dbh, $attrib, $value) = @_;
          # would normally validate and only store known attributes
          # else pass up to DBI to handle
          if ($attrib eq 'AutoCommit') {
              return 1 if $value; # is already set
              Carp::croak("Can't disable AutoCommit");
          }
          return $dbh->SUPER::STORE($attrib, $value);
      }
  
      sub sponge_test_installed_method {
  	my ($dbh, @args) = @_;
  	return $dbh->set_err(42, "not enough parameters") unless @args >= 2;
  	return \@args;
      }
  }
  
  
  {   package DBD::Sponge::st; # ====== STATEMENT ======
      $imp_data_size = 0;
      use strict;
  
      sub execute {
  	my $sth = shift;
  
          # hack to support ParamValues (when not using bind_param)
          $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef;
  
  	if (my $hook = $sth->{execute_hook}) {
  	    &$hook($sth, @_) or return;
  	}
  
  	if ($sth->{is_insert}) {
  	    my $row;
  	    $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ;
  	    my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS};
  	    return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected")
  		if @$row != $NUM_OF_PARAMS;
  	    { local $^W; $sth->trace_msg("inserting (@$row)\n"); }
  	    push @{ $sth->{rows} }, $row;
  	}
  	else {	# mark select sth as Active
  	    $sth->STORE(Active => 1);
  	}
  	# else do nothing for select as data is already in $sth->{rows}
  	return 1;
      }
  
      sub fetch {
  	my ($sth) = @_;
  	my $row = shift @{$sth->{'rows'}};
  	unless ($row) {
  	    $sth->STORE(Active => 0);
  	    return undef;
  	}
  	return $sth->_set_fbav($row);
      }
      *fetchrow_arrayref = \&fetch;
  
      sub FETCH {
  	my ($sth, $attrib) = @_;
  	# would normally validate and only fetch known attributes
  	# else pass up to DBI to handle
  	return $sth->SUPER::FETCH($attrib);
      }
  
      sub STORE {
  	my ($sth, $attrib, $value) = @_;
  	# would normally validate and only store known attributes
  	# else pass up to DBI to handle
  	return $sth->SUPER::STORE($attrib, $value);
      }
  }
  
  1;
  
  __END__ 
  
  =pod
  
  =head1 NAME
  
  DBD::Sponge - Create a DBI statement handle from Perl data
  
  =head1 SYNOPSIS
  
    my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
    my $sth = $sponge->prepare($statement, {
            rows => $data,
            NAME => $names,
            %attr
        }
    );
  
  =head1 DESCRIPTION
  
  DBD::Sponge is useful for making a Perl data structure accessible through a
  standard DBI statement handle. This may be useful to DBD module authors who
  need to transform data in this way.
  
  =head1 METHODS
  
  =head2 connect()
  
    my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 });
  
  Here's a sample syntax for creating a database handle for the Sponge driver.
  No username and password are needed.
  
  =head2 prepare()
  
    my $sth = $sponge->prepare($statement, {
            rows => $data,
            NAME => $names,
            %attr
        }
    );
  
  =over 4
  
  =item *
  
  The C<$statement> here is an arbitrary statement or name you want
  to provide as identity of your data. If you're using DBI::Profile
  it will appear in the profile data.
  
  Generally it's expected that you are preparing a statement handle
  as if a C<select> statement happened.
  
  =item *
  
  C<$data> is a reference to the data you are providing, given as an array of arrays.
  
  =item *
  
  C<$names> is a reference an array of column names for the C<$data> you are providing.
  The number and order should match the number and ordering of the C<$data> columns. 
  
  =item *
  
  C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement.
  
  Currently only NAME, TYPE, and PRECISION are supported.
  
  =back
  
  =head1 BUGS
  
  Using this module to prepare INSERT-like statements is not currently documented.
  
  =head1 AUTHOR AND COPYRIGHT
  
  This module is Copyright (c) 2003 Tim Bunce
  
  Documentation initially written by Mark Stosberg
  
  The DBD::Sponge module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. In particular permission
  is granted to Tim Bunce for distributing this as a part of the DBI.
  
  =head1 SEE ALSO
  
  L<DBI>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBD_SPONGE

$fatpacked{"darwin-thread-multi-2level/DBI.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI';
  # $Id: DBI.pm 13905 2010-04-15 12:49:48Z timbo $
  # vim: ts=8:sw=4:et
  #
  # Copyright (c) 1994-2010  Tim Bunce  Ireland
  #
  # See COPYRIGHT section in pod text below for usage and distribution rights.
  #
  
  require 5.008_001;
  
  BEGIN {
  $DBI::VERSION = "1.611"; # ==> ALSO update the version in the pod text below!
  }
  
  =head1 NAME
  
  DBI - Database independent interface for Perl
  
  =head1 SYNOPSIS
  
    use DBI;
  
    @driver_names = DBI->available_drivers;
    %drivers      = DBI->installed_drivers;
    @data_sources = DBI->data_sources($driver_name, \%attr);
  
    $dbh = DBI->connect($data_source, $username, $auth, \%attr);
  
    $rv  = $dbh->do($statement);
    $rv  = $dbh->do($statement, \%attr);
    $rv  = $dbh->do($statement, \%attr, @bind_values);
  
    $ary_ref  = $dbh->selectall_arrayref($statement);
    $hash_ref = $dbh->selectall_hashref($statement, $key_field);
  
    $ary_ref  = $dbh->selectcol_arrayref($statement);
    $ary_ref  = $dbh->selectcol_arrayref($statement, \%attr);
  
    @row_ary  = $dbh->selectrow_array($statement);
    $ary_ref  = $dbh->selectrow_arrayref($statement);
    $hash_ref = $dbh->selectrow_hashref($statement);
  
    $sth = $dbh->prepare($statement);
    $sth = $dbh->prepare_cached($statement);
  
    $rc = $sth->bind_param($p_num, $bind_value);
    $rc = $sth->bind_param($p_num, $bind_value, $bind_type);
    $rc = $sth->bind_param($p_num, $bind_value, \%attr);
  
    $rv = $sth->execute;
    $rv = $sth->execute(@bind_values);
    $rv = $sth->execute_array(\%attr, ...);
  
    $rc = $sth->bind_col($col_num, \$col_variable);
    $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
  
    @row_ary  = $sth->fetchrow_array;
    $ary_ref  = $sth->fetchrow_arrayref;
    $hash_ref = $sth->fetchrow_hashref;
  
    $ary_ref  = $sth->fetchall_arrayref;
    $ary_ref  = $sth->fetchall_arrayref( $slice, $max_rows );
  
    $hash_ref = $sth->fetchall_hashref( $key_field );
  
    $rv  = $sth->rows;
  
    $rc  = $dbh->begin_work;
    $rc  = $dbh->commit;
    $rc  = $dbh->rollback;
  
    $quoted_string = $dbh->quote($string);
  
    $rc  = $h->err;
    $str = $h->errstr;
    $rv  = $h->state;
  
    $rc  = $dbh->disconnect;
  
  I<The synopsis above only lists the major methods and parameters.>
  
  
  =head2 GETTING HELP
  
  If you have questions about DBI, or DBD driver modules, you can get
  help from the I<dbi-users@perl.org> mailing list.  You don't have to subscribe
  to the list in order to post, though I'd recommend it. You can get help on
  subscribing and using the list by emailing I<dbi-users-help@perl.org>.
  
  I don't recommend the DBI cpanforum (at http://www.cpanforum.com/dist/DBI)
  because relatively few people read it compared with dbi-users@perl.org.
  
  To help you make the best use of the dbi-users mailing list,
  and any other lists or forums you may use, I I<strongly>
  recommend that you read "How To Ask Questions The Smart Way"
  by Eric Raymond: L<http://www.catb.org/~esr/faqs/smart-questions.html>.
  
  If you think you've found a bug then please also read
  "How to Report Bugs Effectively" by Simon Tatham:
  L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
  
  The DBI home page at L<http://dbi.perl.org/> and the DBI FAQ
  at L<http://faq.dbi-support.com/> are always worth a visit.
  They include links to other resources.
  
  Before asking any questions, reread this document, consult the
  archives and read the DBI FAQ. The archives are listed
  at the end of this document and on the DBI home page.
  
  This document often uses terms like I<references>, I<objects>,
  I<methods>.  If you're not familiar with those terms then it would
  be a good idea to read at least the following perl manuals first:
  L<perlreftut>, L<perldsc>, L<perllol>, and L<perlboot>.
  
  Please note that Tim Bunce does not maintain the mailing lists or the
  web page (generous volunteers do that).  So please don't send mail
  directly to him; he just doesn't have the time to answer questions
  personally. The I<dbi-users> mailing list has lots of experienced
  people who should be able to help you if you need it. If you do email
  Tim he's very likely to just forward it to the mailing list.
  
  =head2 NOTES
  
  This is the DBI specification that corresponds to the DBI version 1.611
  ($Revision: 13905 $).
  
  The DBI is evolving at a steady pace, so it's good to check that
  you have the latest copy.
  
  The significant user-visible changes in each release are documented
  in the L<DBI::Changes> module so you can read them by executing
  C<perldoc DBI::Changes>.
  
  Some DBI changes require changes in the drivers, but the drivers
  can take some time to catch up. Newer versions of the DBI have
  added features that may not yet be supported by the drivers you
  use.  Talk to the authors of your drivers if you need a new feature
  that's not yet supported.
  
  Features added after DBI 1.21 (February 2002) are marked in the
  text with the version number of the DBI release they first appeared in.
  
  Extensions to the DBI API often use the C<DBIx::*> namespace.
  See L</Naming Conventions and Name Space>. DBI extension modules
  can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>.
  And all modules related to the DBI can be found at
  L<http://search.cpan.org/search?query=DBI&mode=all>.
  
  =cut
  
  # The POD text continues at the end of the file.
  
  
  package DBI;
  
  use Carp();
  use DynaLoader ();
  use Exporter ();
  
  BEGIN {
  @ISA = qw(Exporter DynaLoader);
  
  # Make some utility functions available if asked for
  @EXPORT    = ();		    # we export nothing by default
  @EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
  %EXPORT_TAGS = (
     sql_types => [ qw(
  	SQL_GUID
  	SQL_WLONGVARCHAR
  	SQL_WVARCHAR
  	SQL_WCHAR
  	SQL_BIGINT
  	SQL_BIT
  	SQL_TINYINT
  	SQL_LONGVARBINARY
  	SQL_VARBINARY
  	SQL_BINARY
  	SQL_LONGVARCHAR
  	SQL_UNKNOWN_TYPE
  	SQL_ALL_TYPES
  	SQL_CHAR
  	SQL_NUMERIC
  	SQL_DECIMAL
  	SQL_INTEGER
  	SQL_SMALLINT
  	SQL_FLOAT
  	SQL_REAL
  	SQL_DOUBLE
  	SQL_DATETIME
  	SQL_DATE
  	SQL_INTERVAL
  	SQL_TIME
  	SQL_TIMESTAMP
  	SQL_VARCHAR
  	SQL_BOOLEAN
  	SQL_UDT
  	SQL_UDT_LOCATOR
  	SQL_ROW
  	SQL_REF
  	SQL_BLOB
  	SQL_BLOB_LOCATOR
  	SQL_CLOB
  	SQL_CLOB_LOCATOR
  	SQL_ARRAY
  	SQL_ARRAY_LOCATOR
  	SQL_MULTISET
  	SQL_MULTISET_LOCATOR
  	SQL_TYPE_DATE
  	SQL_TYPE_TIME
  	SQL_TYPE_TIMESTAMP
  	SQL_TYPE_TIME_WITH_TIMEZONE
  	SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
  	SQL_INTERVAL_YEAR
  	SQL_INTERVAL_MONTH
  	SQL_INTERVAL_DAY
  	SQL_INTERVAL_HOUR
  	SQL_INTERVAL_MINUTE
  	SQL_INTERVAL_SECOND
  	SQL_INTERVAL_YEAR_TO_MONTH
  	SQL_INTERVAL_DAY_TO_HOUR
  	SQL_INTERVAL_DAY_TO_MINUTE
  	SQL_INTERVAL_DAY_TO_SECOND
  	SQL_INTERVAL_HOUR_TO_MINUTE
  	SQL_INTERVAL_HOUR_TO_SECOND
  	SQL_INTERVAL_MINUTE_TO_SECOND
  	DBIstcf_DISCARD_STRING
  	DBIstcf_STRICT
     ) ],
     sql_cursor_types => [ qw(
  	 SQL_CURSOR_FORWARD_ONLY
  	 SQL_CURSOR_KEYSET_DRIVEN
  	 SQL_CURSOR_DYNAMIC
  	 SQL_CURSOR_STATIC
  	 SQL_CURSOR_TYPE_DEFAULT
     ) ], # for ODBC cursor types
     utils     => [ qw(
  	neat neat_list $neat_maxlen dump_results looks_like_number
  	data_string_diff data_string_desc data_diff sql_type_cast
     ) ],
     profile   => [ qw(
  	dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time
     ) ], # notionally "in" DBI::Profile and normally imported from there
  );
  
  $DBI::dbi_debug = 0;
  $DBI::neat_maxlen = 1000;
  $DBI::stderr = 2_000_000_000; # a very round number below 2**31
  
  # If you get an error here like "Can't find loadable object ..."
  # then you haven't installed the DBI correctly. Read the README
  # then install it again.
  if ( $ENV{DBI_PUREPERL} ) {
      eval { bootstrap DBI } if       $ENV{DBI_PUREPERL} == 1;
      require DBI::PurePerl  if $@ or $ENV{DBI_PUREPERL} >= 2;
      $DBI::PurePerl ||= 0; # just to silence "only used once" warnings
  }
  else {
      bootstrap DBI;
  }
  
  $EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
  
  Exporter::export_ok_tags(keys %EXPORT_TAGS);
  
  }
  
  # Alias some handle methods to also be DBI class methods
  for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
    no strict;
    *$_ = \&{"DBD::_::common::$_"};
  }
  
  use strict;
  
  DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
  
  $DBI::connect_via ||= "connect";
  
  # check if user wants a persistent database connection ( Apache + mod_perl )
  if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
      $DBI::connect_via = "Apache::DBI::connect";
      DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
  }
  
  # check for weaken support, used by ChildHandles
  my $HAS_WEAKEN = eval {
      require Scalar::Util;
      # this will croak() if this Scalar::Util doesn't have a working weaken().
      Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t
      1;
  };
  
  %DBI::installed_drh = ();  # maps driver names to installed driver handles
  sub installed_drivers { %DBI::installed_drh }
  %DBI::installed_methods = (); # XXX undocumented, may change
  sub installed_methods { %DBI::installed_methods }
  
  # Setup special DBI dynamic variables. See DBI::var::FETCH for details.
  # These are dynamically associated with the last handle used.
  tie $DBI::err,    'DBI::var', '*err';    # special case: referenced via IHA list
  tie $DBI::state,  'DBI::var', '"state';  # special case: referenced via IHA list
  tie $DBI::lasth,  'DBI::var', '!lasth';  # special case: return boolean
  tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
  tie $DBI::rows,   'DBI::var', '&rows';   # call &rows   in last used pkg
  sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
  sub DBI::var::STORE    { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
  
  {   # used to catch DBI->{Attrib} mistake
      sub DBI::DBI_tie::TIEHASH { bless {} }
      sub DBI::DBI_tie::STORE   { Carp::carp("DBI->{$_[1]} is invalid syntax (you probably want \$h->{$_[1]})");}
      *DBI::DBI_tie::FETCH = \&DBI::DBI_tie::STORE;
  }
  tie %DBI::DBI => 'DBI::DBI_tie';
  
  # --- Driver Specific Prefix Registry ---
  
  my $dbd_prefix_registry = {
    ad_      => { class => 'DBD::AnyData',	},
    ado_     => { class => 'DBD::ADO',		},
    amzn_    => { class => 'DBD::Amazon',		},
    best_    => { class => 'DBD::BestWins',	},
    csv_     => { class => 'DBD::CSV',		},
    db2_     => { class => 'DBD::DB2',		},
    dbi_     => { class => 'DBI',			},
    dbm_     => { class => 'DBD::DBM',		},
    df_      => { class => 'DBD::DF',		},
    f_       => { class => 'DBD::File',		},
    file_    => { class => 'DBD::TextFile',	},
    go_      => { class => 'DBD::Gofer',  	},
    ib_      => { class => 'DBD::InterBase',	},
    ing_     => { class => 'DBD::Ingres',		},
    ix_      => { class => 'DBD::Informix',	},
    jdbc_    => { class => 'DBD::JDBC',		},
    monetdb_ => { class => 'DBD::monetdb',	},
    msql_    => { class => 'DBD::mSQL',		},
    mvsftp_  => { class => 'DBD::MVS_FTPSQL',	},
    mysql_   => { class => 'DBD::mysql',		},
    mx_      => { class => 'DBD::Multiplex',	},
    nullp_   => { class => 'DBD::NullP',		},
    odbc_    => { class => 'DBD::ODBC',		},
    ora_     => { class => 'DBD::Oracle',		},
    pg_      => { class => 'DBD::Pg',		},
    pgpp_    => { class => 'DBD::PgPP',		},
    plb_     => { class => 'DBD::Plibdata',	},
    proxy_   => { class => 'DBD::Proxy',		},
    rdb_     => { class => 'DBD::RDB',		},
    sapdb_   => { class => 'DBD::SAP_DB',		},
    solid_   => { class => 'DBD::Solid',		},
    sponge_  => { class => 'DBD::Sponge',		},
    sql_     => { class => 'SQL::Statement',	},
    sqlite_  => { class => 'DBD::SQLite',  	},
    syb_     => { class => 'DBD::Sybase',		},
    tdat_    => { class => 'DBD::Teradata',	},
    tmpl_    => { class => 'DBD::Template',	},
    tmplss_  => { class => 'DBD::TemplateSS',	},
    tuber_   => { class => 'DBD::Tuber',		},
    uni_     => { class => 'DBD::Unify',		},
    vt_      => { class => 'DBD::Vt',		},
    wmi_     => { class => 'DBD::WMI',		},
    x_       => { }, # for private use
    xbase_   => { class => 'DBD::XBase',		},
    xl_      => { class => 'DBD::Excel',		},
    yaswi_   => { class => 'DBD::Yaswi',		},
  };
  
  sub dump_dbd_registry {
      require Data::Dumper;
      local $Data::Dumper::Sortkeys=1;
      local $Data::Dumper::Indent=1;
      print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
  }
  
  # --- Dynamically create the DBI Standard Interface
  
  my $keeperr = { O=>0x0004 };
  
  %DBI::DBI_methods = ( # Define the DBI interface methods per class:
  
      common => {		# Interface methods common to all DBI handle classes
  	'DESTROY'	=> { O=>0x004|0x10000 },
  	'CLEAR'  	=> $keeperr,
  	'EXISTS' 	=> $keeperr,
  	'FETCH'		=> { O=>0x0404 },
  	'FETCH_many'	=> { O=>0x0404 },
  	'FIRSTKEY'	=> $keeperr,
  	'NEXTKEY'	=> $keeperr,
  	'STORE'		=> { O=>0x0418 | 0x4 },
  	_not_impl	=> undef,
  	can		=> { O=>0x0100 }, # special case, see dispatch
  	debug 	 	=> { U =>[1,2,'[$debug_level]'],	O=>0x0004 }, # old name for trace
  	dump_handle 	=> { U =>[1,3,'[$message [, $level]]'],	O=>0x0004 },
  	err		=> $keeperr,
  	errstr		=> $keeperr,
  	state		=> $keeperr,
  	func	   	=> { O=>0x0006	},
  	parse_trace_flag   => { U =>[2,2,'$name'],	O=>0x0404, T=>8 },
  	parse_trace_flags  => { U =>[2,2,'$flags'],	O=>0x0404, T=>8 },
  	private_data	=> { U =>[1,1],			O=>0x0004 },
  	set_err		=> { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
  	trace		=> { U =>[1,3,'[$trace_level, [$filename]]'],	O=>0x0004 },
  	trace_msg	=> { U =>[2,3,'$message_text [, $min_level ]' ],	O=>0x0004, T=>8 },
  	swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
          private_attribute_info => { },
          visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 },
      },
      dr => {		# Database Driver Interface
  	'connect'  =>	{ U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000 },
  	'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000 },
  	'disconnect_all'=>{ U =>[1,1], O=>0x0800 },
  	data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800 },
  	default_user => { U =>[3,4,'$user, $pass [, \%attr]' ] },
  	dbixs_revision  => $keeperr,
      },
      db => {		# Database Session Class Interface
  	data_sources	=> { U =>[1,2,'[\%attr]' ], O=>0x0200 },
  	take_imp_data	=> { U =>[1,1], O=>0x10000 },
  	clone   	=> { U =>[1,2,'[\%attr]'] },
  	connected   	=> { U =>[1,0], O => 0x0004 },
  	begin_work   	=> { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
  	commit     	=> { U =>[1,1], O=>0x0480|0x0800 },
  	rollback   	=> { U =>[1,1], O=>0x0480|0x0800 },
  	'do'       	=> { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
  	last_insert_id	=> { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
  	preparse    	=> {  }, # XXX
  	prepare    	=> { U =>[2,3,'$statement [, \%attr]'],                    O=>0xA200 },
  	prepare_cached	=> { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'],   O=>0xA200 },
  	selectrow_array	=> { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
  	ping       	=> { U =>[1,1], O=>0x0404 },
  	disconnect 	=> { U =>[1,1], O=>0x0400|0x0800|0x10000 },
  	quote      	=> { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
  	quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ],    O=>0x0430 },
  	rows       	=> $keeperr,
  
  	tables          => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
  	table_info      => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ],	O=>0x2200|0x8800 },
  	column_info     => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 },
  	primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],	O=>0x2200|0x8800 },
  	primary_key     => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],	O=>0x2200 },
  	foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 },
  	statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 },
  	type_info_all	=> { U =>[1,1], O=>0x2200|0x0800 },
  	type_info	=> { U =>[1,2,'$data_type'], O=>0x2200 },
  	get_info	=> { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
      },
      st => {		# Statement Class Interface
  	bind_col	=> { U =>[3,4,'$column, \\$var [, \%attr]'] },
  	bind_columns	=> { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
  	bind_param	=> { U =>[3,4,'$parameter, $var [, \%attr]'] },
  	bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
  	execute		=> { U =>[1,0,'[@args]'], O=>0x1040 },
  
  	bind_param_array  => { U =>[3,4,'$parameter, $var [, \%attr]'] },
  	bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
  	execute_array     => { U =>[2,0,'\\%attribs [, @args]'],         O=>0x1040|0x4000 },
  	execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 },
  
  	fetch    	  => undef, # alias for fetchrow_arrayref
  	fetchrow_arrayref => undef,
  	fetchrow_hashref  => undef,
  	fetchrow_array    => undef,
  	fetchrow   	  => undef, # old alias for fetchrow_array
  
  	fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
  	fetchall_hashref  => { U =>[2,2,'$key_field'] },
  
  	blob_read  =>	{ U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
  	blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
  	dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
  	more_results => { U =>[1,1] },
  	finish     => 	{ U =>[1,1] },
  	cancel     => 	{ U =>[1,1], O=>0x0800 },
  	rows       =>	$keeperr,
  
  	_get_fbav	=> undef,
  	_set_fbav	=> { T=>6 },
      },
  );
  
  while ( my ($class, $meths) = each %DBI::DBI_methods ) {
      my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
      while ( my ($method, $info) = each %$meths ) {
  	my $fullmeth = "DBI::${class}::$method";
  	if ($DBI::dbi_debug >= 15) { # quick hack to list DBI methods
  	    # and optionally filter by IMA flags
  	    my $O = $info->{O}||0;
  	    printf "0x%04x %-20s\n", $O, $fullmeth
  	        unless $ima_trace && !($O & $ima_trace);
  	}
  	DBI->_install_method($fullmeth, 'DBI.pm', $info);
      }
  }
  
  {
      package DBI::common;
      @DBI::dr::ISA = ('DBI::common');
      @DBI::db::ISA = ('DBI::common');
      @DBI::st::ISA = ('DBI::common');
  }
  
  # End of init code
  
  
  END {
      return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
      local ($!,$?);
      DBI->trace_msg(sprintf("    -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2);
      # Let drivers know why we are calling disconnect_all:
      $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1;	# avoid typo warning
      DBI->disconnect_all() if %DBI::installed_drh;
  }
  
  
  sub CLONE {
      my $olddbis = $DBI::_dbistate;
      _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
      DBI->trace_msg(sprintf "CLONE DBI for new thread %s\n",
  	$DBI::PurePerl ? "" : sprintf("(dbis %x -> %x)",$olddbis, $DBI::_dbistate));
      while ( my ($driver, $drh) = each %DBI::installed_drh) {
  	no strict 'refs';
  	next if defined &{"DBD::${driver}::CLONE"};
  	warn("$driver has no driver CLONE() function so is unsafe threaded\n");
      }
      %DBI::installed_drh = ();	# clear loaded drivers so they have a chance to reinitialize
  }
  
  sub parse_dsn {
      my ($class, $dsn) = @_;
      $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
      my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
      $driver ||= $ENV{DBI_DRIVER} || '';
      $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
      return ($scheme, $driver, $attr, $attr_hash, $dsn);
  }
  
  sub visit_handles {
      my ($class, $code, $outer_info) = @_;
      $outer_info = {} if not defined $outer_info;
      my %drh = DBI->installed_drivers;
      for my $h (values %drh) {
  	my $child_info = $code->($h, $outer_info)
  	    or next;
  	$h->visit_child_handles($code, $child_info);
      }
      return $outer_info;
  }
  
  
  # --- The DBI->connect Front Door methods
  
  sub connect_cached {
      # For library code using connect_cached() with mod_perl
      # we redirect those calls to Apache::DBI::connect() as well
      my ($class, $dsn, $user, $pass, $attr) = @_;
      my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect")
  	    ? 'Apache::DBI::connect' : 'connect_cached';
      $attr = {
          $attr ? %$attr : (), # clone, don't modify callers data
          dbi_connect_method => $dbi_connect_method,
      };
      return $class->connect($dsn, $user, $pass, $attr);
  }
  
  sub connect {
      my $class = shift;
      my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
      my $driver;
  
      if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
  	Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
          ($old_driver, $attr) = ($attr, $old_driver);
      }
  
      my $connect_meth = $attr->{dbi_connect_method};
      $connect_meth ||= $DBI::connect_via;	# fallback to default
  
      $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
  
      if ($DBI::dbi_debug) {
  	local $^W = 0;
  	pop @_ if $connect_meth ne 'connect';
  	my @args = @_; $args[2] = '****'; # hide password
  	DBI->trace_msg("    -> $class->$connect_meth(".join(", ",@args).")\n");
      }
      Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
  	if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
  
      # extract dbi:driver prefix from $dsn into $1
      $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
  			or '' =~ /()/; # ensure $1 etc are empty if match fails
      my $driver_attrib_spec = $2 || '';
  
      # Set $driver. Old style driver, if specified, overrides new dsn style.
      $driver = $old_driver || $1 || $ENV{DBI_DRIVER}
  	or Carp::croak("Can't connect to data source '$dsn' "
              ."because I can't work out what driver to use "
              ."(it doesn't seem to contain a 'dbi:driver:' prefix "
              ."and the DBI_DRIVER env var is not set)");
  
      my $proxy;
      if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
  	my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
  	$proxy = 'Proxy';
  	if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
  	    $proxy = $1;
  	    $driver_attrib_spec = join ",",
                  ($driver_attrib_spec) ? $driver_attrib_spec : (),
                  ($2                 ) ? $2                  : ();
  	}
  	$dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
  	$driver = $proxy;
  	DBI->trace_msg("       DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
      }
      # avoid recursion if proxy calls DBI->connect itself
      local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
  
      my %attributes;	# take a copy we can delete from
      if ($old_driver) {
  	%attributes = %$attr if $attr;
      }
      else {		# new-style connect so new default semantics
  	%attributes = (
  	    PrintError => 1,
  	    AutoCommit => 1,
  	    ref $attr           ? %$attr : (),
  	    # attributes in DSN take precedence over \%attr connect parameter
  	    $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
  	);
      }
      $attr = \%attributes; # now set $attr to refer to our local copy
  
      my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
  	or die "panic: $class->install_driver($driver) failed";
  
      # attributes in DSN take precedence over \%attr connect parameter
      $user = $attr->{Username} if defined $attr->{Username};
      $pass = $attr->{Password} if defined $attr->{Password};
      delete $attr->{Password}; # always delete Password as closure stores it securely
      if ( !(defined $user && defined $pass) ) {
          ($user, $pass) = $drh->default_user($user, $pass, $attr);
      }
      $attr->{Username} = $user; # force the Username to be the actual one used
  
      my $connect_closure = sub {
  	my ($old_dbh, $override_attr) = @_;
  
          #use Data::Dumper;
          #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]);
  
  	my $dbh;
  	unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
  	    $user = '' if !defined $user;
  	    $dsn = '' if !defined $dsn;
  	    # $drh->errstr isn't safe here because $dbh->DESTROY may not have
  	    # been called yet and so the dbh errstr would not have been copied
  	    # up to the drh errstr. Certainly true for connect_cached!
  	    my $errstr = $DBI::errstr;
              # Getting '(no error string)' here is a symptom of a ref loop
  	    $errstr = '(no error string)' if !defined $errstr;
  	    my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
  	    DBI->trace_msg("       $msg\n");
  	    # XXX HandleWarn
  	    unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
  		Carp::croak($msg) if $attr->{RaiseError};
  		Carp::carp ($msg) if $attr->{PrintError};
  	    }
  	    $! = 0; # for the daft people who do DBI->connect(...) || die "$!";
  	    return $dbh; # normally undef, but HandleError could change it
  	}
  
          # merge any attribute overrides but don't change $attr itself (for closure)
          my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr };
  
          # handle basic RootClass subclassing:
          my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : '');
          if ($rebless_class) {
              no strict 'refs';
              if ($apply->{RootClass}) { # explicit attribute (ie not static methd call class)
                  delete $apply->{RootClass};
                  DBI::_load_class($rebless_class, 0);
              }
              unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
                  Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
                  $rebless_class = undef;
                  $class = 'DBI';
              }
              else {
                  $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
                  DBI::_set_isa([$rebless_class], 'DBI');     # sets up both '::db' and '::st'
                  DBI::_rebless($dbh, $rebless_class);        # appends '::db'
              }
          }
  
  	if (%$apply) {
  
              if ($apply->{DbTypeSubclass}) {
                  my $DbTypeSubclass = delete $apply->{DbTypeSubclass};
                  DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass);
              }
  	    my $a;
  	    foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first
  		next unless  exists $apply->{$a};
  		$dbh->{$a} = delete $apply->{$a};
  	    }
  	    while ( my ($a, $v) = each %$apply) {
  		eval { $dbh->{$a} = $v } or $@ && warn $@;
  	    }
  	}
  
          # confirm to driver (ie if subclassed) that we've connected sucessfully
          # and finished the attribute setup. pass in the original arguments
  	$dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
  
  	DBI->trace_msg("    <- connect= $dbh\n") if $DBI::dbi_debug;
  
  	return $dbh;
      };
  
      my $dbh = &$connect_closure(undef, undef);
  
      $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
  
      return $dbh;
  }
  
  
  sub disconnect_all {
      keys %DBI::installed_drh; # reset iterator
      while ( my ($name, $drh) = each %DBI::installed_drh ) {
  	$drh->disconnect_all() if ref $drh;
      }
  }
  
  
  sub disconnect {		# a regular beginners bug
      Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
  }
  
  
  sub install_driver {		# croaks on failure
      my $class = shift;
      my($driver, $attr) = @_;
      my $drh;
  
      $driver ||= $ENV{DBI_DRIVER} || '';
  
      # allow driver to be specified as a 'dbi:driver:' string
      $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
  
      Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
  		unless ($driver and @_<=3);
  
      # already installed
      return $drh if $drh = $DBI::installed_drh{$driver};
  
      $class->trace_msg("    -> $class->install_driver($driver"
  			.") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
  	if $DBI::dbi_debug;
  
      # --- load the code
      my $driver_class = "DBD::$driver";
      eval qq{package			# hide from PAUSE
  		DBI::_firesafe;		# just in case
  	    require $driver_class;	# load the driver
      };
      if ($@) {
  	my $err = $@;
  	my $advice = "";
  	if ($err =~ /Can't find loadable object/) {
  	    $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
  		 ."\nIn which case you need to use that new perl binary."
  		 ."\nOr perhaps only the .pm file was installed but not the shared object file."
  	}
  	elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
  	    my @drv = $class->available_drivers(1);
  	    $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
  		     ."or perhaps the capitalisation of '$driver' isn't right.\n"
  		     ."Available drivers: ".join(", ", @drv).".";
  	}
  	elsif ($err =~ /Can't load .*? for module DBD::/) {
  	    $advice = "Perhaps a required shared library or dll isn't installed where expected";
  	}
  	elsif ($err =~ /Can't locate .*? in \@INC/) {
  	    $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
  	}
  	Carp::croak("install_driver($driver) failed: $err$advice\n");
      }
      if ($DBI::dbi_debug) {
  	no strict 'refs';
  	(my $driver_file = $driver_class) =~ s/::/\//g;
  	my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
  	$class->trace_msg("       install_driver: $driver_class version $dbd_ver"
  		." loaded from $INC{qq($driver_file.pm)}\n");
      }
  
      # --- do some behind-the-scenes checks and setups on the driver
      $class->setup_driver($driver_class);
  
      # --- run the driver function
      $drh = eval { $driver_class->driver($attr || {}) };
      unless ($drh && ref $drh && !$@) {
  	my $advice = "";
          $@ ||= "$driver_class->driver didn't return a handle";
  	# catch people on case in-sensitive systems using the wrong case
  	$advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
  		if $@ =~ /locate object method/;
  	Carp::croak("$driver_class initialisation failed: $@$advice");
      }
  
      $DBI::installed_drh{$driver} = $drh;
      $class->trace_msg("    <- install_driver= $drh\n") if $DBI::dbi_debug;
      $drh;
  }
  
  *driver = \&install_driver;	# currently an alias, may change
  
  
  sub setup_driver {
      my ($class, $driver_class) = @_;
      my $type;
      foreach $type (qw(dr db st)){
  	my $class = $driver_class."::$type";
  	no strict 'refs';
  	push @{"${class}::ISA"},     "DBD::_::$type"
  	    unless UNIVERSAL::isa($class, "DBD::_::$type");
  	my $mem_class = "DBD::_mem::$type";
  	push @{"${class}_mem::ISA"}, $mem_class
  	    unless UNIVERSAL::isa("${class}_mem", $mem_class)
  	    or $DBI::PurePerl;
      }
  }
  
  
  sub _rebless {
      my $dbh = shift;
      my ($outer, $inner) = DBI::_handles($dbh);
      my $class = shift(@_).'::db';
      bless $inner => $class;
      bless $outer => $class; # outer last for return
  }
  
  
  sub _set_isa {
      my ($classes, $topclass) = @_;
      my $trace = DBI->trace_msg("       _set_isa([@$classes])\n");
      foreach my $suffix ('::db','::st') {
  	my $previous = $topclass || 'DBI'; # trees are rooted here
  	foreach my $class (@$classes) {
  	    my $base_class = $previous.$suffix;
  	    my $sub_class  = $class.$suffix;
  	    my $sub_class_isa  = "${sub_class}::ISA";
  	    no strict 'refs';
  	    if (@$sub_class_isa) {
  		DBI->trace_msg("       $sub_class_isa skipped (already set to @$sub_class_isa)\n")
  		    if $trace;
  	    }
  	    else {
  		@$sub_class_isa = ($base_class) unless @$sub_class_isa;
  		DBI->trace_msg("       $sub_class_isa = $base_class\n")
  		    if $trace;
  	    }
  	    $previous = $class;
  	}
      }
  }
  
  
  sub _rebless_dbtype_subclass {
      my ($dbh, $rootclass, $DbTypeSubclass) = @_;
      # determine the db type names for class hierarchy
      my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass);
      # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
      $_ = $rootclass.'::'.$_ foreach (@hierarchy);
      # load the modules from the 'top down'
      DBI::_load_class($_, 1) foreach (reverse @hierarchy);
      # setup class hierarchy if needed, does both '::db' and '::st'
      DBI::_set_isa(\@hierarchy, $rootclass);
      # finally bless the handle into the subclass
      DBI::_rebless($dbh, $hierarchy[0]);
  }
  
  
  sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
      my ($dbh, $DbTypeSubclass) = @_;
  
      if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
  	# treat $DbTypeSubclass as a comma separated list of names
  	my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
  	$dbh->trace_msg("    DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
  	return @dbtypes;
      }
  
      # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
  
      my $driver = $dbh->{Driver}->{Name};
      if ( $driver eq 'Proxy' ) {
          # XXX Looking into the internals of DBD::Proxy is questionable!
          ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
  		or die "Can't determine driver name from proxy";
      }
  
      my @dbtypes = (ucfirst($driver));
      if ($driver eq 'ODBC' || $driver eq 'ADO') {
  	# XXX will move these out and make extensible later:
  	my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
  	my %_dbtype_name_map = (
  	     'Microsoft SQL Server'	=> 'MSSQL',
  	     'SQL Server'		=> 'Sybase',
  	     'Adaptive Server Anywhere'	=> 'ASAny',
  	     'ADABAS D'			=> 'AdabasD',
  	);
  
          my $name;
  	$name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
  		if $driver eq 'ODBC';
  	$name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
  		if $driver eq 'ADO';
  	die "Can't determine driver name! ($DBI::errstr)\n"
  		unless $name;
  
  	my $dbtype;
          if ($_dbtype_name_map{$name}) {
              $dbtype = $_dbtype_name_map{$name};
          }
  	else {
  	    if ($name =~ /($_dbtype_name_regexp)/) {
  		$dbtype = lc($1);
  	    }
  	    else { # generic mangling for other names:
  		$dbtype = lc($name);
  	    }
  	    $dbtype =~ s/\b(\w)/\U$1/g;
  	    $dbtype =~ s/\W+/_/g;
  	}
  	# add ODBC 'behind' ADO
  	push    @dbtypes, 'ODBC' if $driver eq 'ADO';
  	# add discovered dbtype in front of ADO/ODBC
  	unshift @dbtypes, $dbtype;
      }
      @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
  	if (ref $DbTypeSubclass eq 'CODE');
      $dbh->trace_msg("    DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
      return @dbtypes;
  }
  
  sub _load_class {
      my ($load_class, $missing_ok) = @_;
      DBI->trace_msg("    _load_class($load_class, $missing_ok)\n", 2);
      no strict 'refs';
      return 1 if @{"$load_class\::ISA"};	# already loaded/exists
      (my $module = $load_class) =~ s!::!/!g;
      DBI->trace_msg("    _load_class require $module\n", 2);
      eval { require "$module.pm"; };
      return 1 unless $@;
      return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
      die $@;
  }
  
  
  sub init_rootclass {	# deprecated
      return 1;
  }
  
  
  *internal = \&DBD::Switch::dr::driver;
  
  
  sub available_drivers {
      my($quiet) = @_;
      my(@drivers, $d, $f);
      local(*DBI::DIR, $@);
      my(%seen_dir, %seen_dbd);
      my $haveFileSpec = eval { require File::Spec };
      foreach $d (@INC){
  	chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
  	my $dbd_dir =
  	    ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
  	next unless -d $dbd_dir;
  	next if $seen_dir{$d};
  	$seen_dir{$d} = 1;
  	# XXX we have a problem here with case insensitive file systems
  	# XXX since we can't tell what case must be used when loading.
  	opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
  	foreach $f (readdir(DBI::DIR)){
  	    next unless $f =~ s/\.pm$//;
  	    next if $f eq 'NullP';
  	    if ($seen_dbd{$f}){
  		Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
  		    unless $quiet;
              } else {
  		push(@drivers, $f);
  	    }
  	    $seen_dbd{$f} = $d;
  	}
  	closedir(DBI::DIR);
      }
  
      # "return sort @drivers" will not DWIM in scalar context.
      return wantarray ? sort @drivers : @drivers;
  }
  
  sub installed_versions {
      my ($class, $quiet) = @_;
      my %error;
      my %version = ( DBI => $DBI::VERSION );
      $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION
  	if $DBI::PurePerl;
      for my $driver ($class->available_drivers($quiet)) {
  	next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
  	my $drh = eval {
  	    local $SIG{__WARN__} = sub {};
  	    $class->install_driver($driver);
  	};
  	($error{"DBD::$driver"}=$@),next if $@;
  	no strict 'refs';
  	my $vers = ${"DBD::$driver" . '::VERSION'};
  	$version{"DBD::$driver"} = $vers || '?';
      }
      if (wantarray) {
         return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
      }
      if (!defined wantarray) {	# void context
  	require Config;		# add more detail
  	$version{OS}   = "$^O\t($Config::Config{osvers})";
  	$version{Perl} = "$]\t($Config::Config{archname})";
  	$version{$_}   = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
  	    for keys %error;
  	printf "  %-16s: %s\n",$_,$version{$_}
  	    for reverse sort keys %version;
      }
      return \%version;
  }
  
  
  sub data_sources {
      my ($class, $driver, @other) = @_;
      my $drh = $class->install_driver($driver);
      my @ds = $drh->data_sources(@other);
      return @ds;
  }
  
  
  sub neat_list {
      my ($listref, $maxlen, $sep) = @_;
      $maxlen = 0 unless defined $maxlen;	# 0 == use internal default
      $sep = ", " unless defined $sep;
      join($sep, map { neat($_,$maxlen) } @$listref);
  }
  
  
  sub dump_results {	# also aliased as a method in DBD::_::st
      my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
      return 0 unless $sth;
      $maxlen ||= 35;
      $lsep   ||= "\n";
      $fh ||= \*STDOUT;
      my $rows = 0;
      my $ref;
      while($ref = $sth->fetch) {
  	print $fh $lsep if $rows++ and $lsep;
  	my $str = neat_list($ref,$maxlen,$fsep);
  	print $fh $str;	# done on two lines to avoid 5.003 errors
      }
      print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
      $rows;
  }
  
  
  sub data_diff {
      my ($a, $b, $logical) = @_;
  
      my $diff   = data_string_diff($a, $b);
      return "" if $logical and !$diff;
  
      my $a_desc = data_string_desc($a);
      my $b_desc = data_string_desc($b);
      return "" if !$diff and $a_desc eq $b_desc;
  
      $diff ||= "Strings contain the same sequence of characters"
      	if length($a);
      $diff .= "\n" if $diff;
      return "a: $a_desc\nb: $b_desc\n$diff";
  }
  
  
  sub data_string_diff {
      # Compares 'logical' characters, not bytes, so a latin1 string and an
      # an equivalent unicode string will compare as equal even though their
      # byte encodings are different.
      my ($a, $b) = @_;
      unless (defined $a and defined $b) {             # one undef
  	return ""
  		if !defined $a and !defined $b;
  	return "String a is undef, string b has ".length($b)." characters"
  		if !defined $a;
  	return "String b is undef, string a has ".length($a)." characters"
  		if !defined $b;
      }
  
      require utf8;
      # hack to cater for perl 5.6
      *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
  
      my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
      my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
      my $i = 0;
      while (@a_chars && @b_chars) {
  	++$i, shift(@a_chars), shift(@b_chars), next
  	    if $a_chars[0] == $b_chars[0];# compare ordinal values
  	my @desc = map {
  	    $_ > 255 ?                    # if wide character...
  	      sprintf("\\x{%04X}", $_) :  # \x{...}
  	      chr($_) =~ /[[:cntrl:]]/ ?  # else if control character ...
  	      sprintf("\\x%02X", $_) :    # \x..
  	      chr($_)                     # else as themselves
  	} ($a_chars[0], $b_chars[0]);
  	# highlight probable double-encoding?
          foreach my $c ( @desc ) {
  	    next unless $c =~ m/\\x\{08(..)}/;
  	    $c .= "='" .chr(hex($1)) ."'"
  	}
  	return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
      }
      return "String a truncated after $i characters" if @b_chars;
      return "String b truncated after $i characters" if @a_chars;
      return "";
  }
  
  
  sub data_string_desc {	# describe a data string
      my ($a) = @_;
      require bytes;
      require utf8;
  
      # hacks to cater for perl 5.6
      *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
      *utf8::valid   = sub {                        1 } unless defined &utf8::valid;
  
      # Give sufficient info to help diagnose at least these kinds of situations:
      # - valid UTF8 byte sequence but UTF8 flag not set
      #   (might be ascii so also need to check for hibit to make it worthwhile)
      # - UTF8 flag set but invalid UTF8 byte sequence
      # could do better here, but this'll do for now
      my $utf8 = sprintf "UTF8 %s%s",
  	utf8::is_utf8($a) ? "on" : "off",
  	utf8::valid($a||'') ? "" : " but INVALID encoding";
      return "$utf8, undef" unless defined $a;
      my $is_ascii = $a =~ m/^[\000-\177]*$/;
      return sprintf "%s, %s, %d characters %d bytes",
  	$utf8, $is_ascii ? "ASCII" : "non-ASCII",
  	length($a), bytes::length($a);
  }
  
  
  sub connect_test_perf {
      my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
  	Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
      # these are non standard attributes just for this special method
      my $loops ||= $attr->{dbi_loops} || 5;
      my $par   ||= $attr->{dbi_par}   || 1;	# parallelism
      my $verb  ||= $attr->{dbi_verb}  || 1;
      my $meth  ||= $attr->{dbi_meth}  || 'connect';
      print "$dsn: testing $loops sets of $par connections:\n";
      require "FileHandle.pm";	# don't let toke.c create empty FileHandle package
      local $| = 1;
      my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
      # test the connection and warm up caches etc
      $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr");
      my $t1 = dbi_time();
      my $loop;
      for $loop (1..$loops) {
  	my @cons;
  	print "Connecting... " if $verb;
  	for (1..$par) {
  	    print "$_ ";
  	    push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
  		    or Carp::croak("connect failed: $DBI::errstr\n"));
  	}
  	print "\nDisconnecting...\n" if $verb;
  	for (@cons) {
  	    $_->disconnect or warn "disconnect failed: $DBI::errstr"
  	}
      }
      my $t2 = dbi_time();
      my $td = $t2 - $t1;
      printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n",
          $par, $loops, $td, $loops*$par, $td/($loops*$par);
      return $td;
  }
  
  
  # Help people doing DBI->errstr, might even document it one day
  # XXX probably best moved to cheaper XS code if this gets documented
  sub err    { $DBI::err    }
  sub errstr { $DBI::errstr }
  
  
  # --- Private Internal Function for Creating New DBI Handles
  
  # XXX move to PurePerl?
  *DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
  *DBI::db::TIEHASH = \&DBI::st::TIEHASH;
  
  
  # These three special constructors are called by the drivers
  # The way they are called is likely to change.
  
  our $shared_profile;
  
  sub _new_drh {	# called by DBD::<drivername>::driver()
      my ($class, $initial_attr, $imp_data) = @_;
      # Provide default storage for State,Err and Errstr.
      # Note that these are shared by all child handles by default! XXX
      # State must be undef to get automatic faking in DBI::var::FETCH
      my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, 0, '');
      my $attr = {
  	# these attributes get copied down to child handles by default
  	'State'		=> \$h_state_store,  # Holder for DBI::state
  	'Err'		=> \$h_err_store,    # Holder for DBI::err
  	'Errstr'	=> \$h_errstr_store, # Holder for DBI::errstr
  	'TraceLevel' 	=> 0,
  	FetchHashKeyName=> 'NAME',
  	%$initial_attr,
      };
      my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
  
      # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
      # it kills the t/zz_*_pp.t tests (they silently exit early)
      if ($ENV{DBI_PROFILE} && !$DBI::PurePerl) {
  	# The profile object created here when the first driver is loaded
  	# is shared by all drivers so we end up with just one set of profile
  	# data and thus the 'total time in DBI' is really the true total.
  	if (!$shared_profile) {	# first time
  	    $h->{Profile} = $ENV{DBI_PROFILE};
  	    $shared_profile = $h->{Profile};
  	}
  	else {
  	    $h->{Profile} = $shared_profile;
  	}
      }
      return $h unless wantarray;
      ($h, $i);
  }
  
  sub _new_dbh {	# called by DBD::<drivername>::dr::connect()
      my ($drh, $attr, $imp_data) = @_;
      my $imp_class = $drh->{ImplementorClass}
  	or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
      substr($imp_class,-4,4) = '::db';
      my $app_class = ref $drh;
      substr($app_class,-4,4) = '::db';
      $attr->{Err}    ||= \my $err;
      $attr->{Errstr} ||= \my $errstr;
      $attr->{State}  ||= \my $state;
      _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
  }
  
  sub _new_sth {	# called by DBD::<drivername>::db::prepare)
      my ($dbh, $attr, $imp_data) = @_;
      my $imp_class = $dbh->{ImplementorClass}
  	or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
      substr($imp_class,-4,4) = '::st';
      my $app_class = ref $dbh;
      substr($app_class,-4,4) = '::st';
      _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
  }
  
  
  # end of DBI package
  
  
  
  # --------------------------------------------------------------------
  # === The internal DBI Switch pseudo 'driver' class ===
  
  {   package	# hide from PAUSE
  	DBD::Switch::dr;
      DBI->setup_driver('DBD::Switch');	# sets up @ISA
  
      $DBD::Switch::dr::imp_data_size = 0;
      $DBD::Switch::dr::imp_data_size = 0;	# avoid typo warning
      my $drh;
  
      sub driver {
  	return $drh if $drh;	# a package global
  
  	my $inner;
  	($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
  		'Name'    => 'Switch',
  		'Version' => $DBI::VERSION,
  		'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
  	    });
  	Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
  	return $drh;
      }
      sub CLONE {
  	undef $drh;
      }
  
      sub FETCH {
  	my($drh, $key) = @_;
  	return DBI->trace if $key eq 'DebugDispatch';
  	return undef if $key eq 'DebugLog';	# not worth fetching, sorry
  	return $drh->DBD::_::dr::FETCH($key);
  	undef;
      }
      sub STORE {
  	my($drh, $key, $value) = @_;
  	if ($key eq 'DebugDispatch') {
  	    DBI->trace($value);
  	} elsif ($key eq 'DebugLog') {
  	    DBI->trace(-1, $value);
  	} else {
  	    $drh->DBD::_::dr::STORE($key, $value);
  	}
      }
  }
  
  
  # --------------------------------------------------------------------
  # === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
  
  # We only define default methods for harmless functions.
  # We don't, for example, define a DBD::_::st::prepare()
  
  {   package		# hide from PAUSE
  	DBD::_::common; # ====== Common base class methods ======
      use strict;
  
      # methods common to all handle types:
  
      sub _not_impl {
  	my ($h, $method) = @_;
  	$h->trace_msg("Driver does not implement the $method method.\n");
  	return;	# empty list / undef
      }
  
      # generic TIEHASH default methods:
      sub FIRSTKEY { }
      sub NEXTKEY  { }
      sub EXISTS   { defined($_[0]->FETCH($_[1])) } # XXX undef?
      sub CLEAR    { Carp::carp "Can't CLEAR $_[0] (DBI)" }
  
      sub FETCH_many {    # XXX should move to C one day
          my $h = shift;
          # scalar is needed to workaround drivers that return an empty list
          # for some attributes
          return map { scalar $h->FETCH($_) } @_;
      }
  
      *dump_handle = \&DBI::dump_handle;
  
      sub install_method {
  	# special class method called directly by apps and/or drivers
  	# to install new methods into the DBI dispatcher
  	# DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
  	my ($class, $method, $attr) = @_;
  	Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
  	    unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
  	my ($driver, $subtype) = ($1, $2);
  	Carp::croak("invalid method name '$method'")
  	    unless $method =~ m/^([a-z]+_)\w+$/;
  	my $prefix = $1;
  	my $reg_info = $dbd_prefix_registry->{$prefix};
  	Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info;
  
  	my $full_method = "DBI::${subtype}::$method";
  	$DBI::installed_methods{$full_method} = $attr;
  
  	my (undef, $filename, $line) = caller;
  	# XXX reformat $attr as needed for _install_method
  	my %attr = %{$attr||{}}; # copy so we can edit
  	DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
      }
  
      sub parse_trace_flags {
  	my ($h, $spec) = @_;
  	my $level = 0;
  	my $flags = 0;
  	my @unknown;
  	for my $word (split /\s*[|&,]\s*/, $spec) {
  	    if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
  		$level = $word;
  	    } elsif ($word eq 'ALL') {
  		$flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
  		last;
  	    } elsif (my $flag = $h->parse_trace_flag($word)) {
  		$flags |= $flag;
  	    }
  	    else {
  		push @unknown, $word;
  	    }
  	}
  	if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
  	    Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
  		join(" ", map { DBI::neat($_) } @unknown));
  	}
  	$flags |= $level;
  	return $flags;
      }
  
      sub parse_trace_flag {
  	my ($h, $name) = @_;
  	#      0xddDDDDrL (driver, DBI, reserved, Level)
  	return 0x00000100 if $name eq 'SQL';
  	return;
      }
  
      sub private_attribute_info {
          return undef;
      }
  
      sub visit_child_handles {
  	my ($h, $code, $info) = @_;
  	$info = {} if not defined $info;
  	for my $ch (@{ $h->{ChildHandles} || []}) {
  	    next unless $ch;
  	    my $child_info = $code->($ch, $info)
  		or next;
  	    $ch->visit_child_handles($code, $child_info);
  	}
  	return $info;
      }
  }
  
  
  {   package		# hide from PAUSE
  	DBD::_::dr;	# ====== DRIVER ======
      @DBD::_::dr::ISA = qw(DBD::_::common);
      use strict;
  
      sub default_user {
  	my ($drh, $user, $pass, $attr) = @_;
  	$user = $ENV{DBI_USER} unless defined $user;
  	$pass = $ENV{DBI_PASS} unless defined $pass;
  	return ($user, $pass);
      }
  
      sub connect { # normally overridden, but a handy default
  	my ($drh, $dsn, $user, $auth) = @_;
  	my ($this) = DBI::_new_dbh($drh, {
  	    'Name' => $dsn,
  	});
  	# XXX debatable as there's no "server side" here
  	# (and now many uses would trigger warnings on DESTROY)
  	# $this->STORE(Active => 1);
          # so drivers should set it in their own connect
  	$this;
      }
  
  
      sub connect_cached {
          my $drh = shift;
  	my ($dsn, $user, $auth, $attr) = @_;
  
  	my $cache = $drh->{CachedKids} ||= {};
  	my $key = do { local $^W;
  	    join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
  	};
  	my $dbh = $cache->{$key};
          $drh->trace_msg(sprintf("    connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh)))
              if $DBI::dbi_debug >= 4;
  
          my $cb = $attr->{Callbacks}; # take care not to autovivify
  	if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
              # If the caller has provided a callback then call it
              if ($cb and $cb = $cb->{"connect_cached.reused"}) {
  		local $_ = "connect_cached.reused";
  		$cb->($dbh, $dsn, $user, $auth, $attr);
              }
  	    return $dbh;
  	}
  
  	# If the caller has provided a callback then call it
  	if ($cb and $cb = $cb->{"connect_cached.new"}) {
  	    local $_ = "connect_cached.new";
  	    $cb->($dbh, $dsn, $user, $auth, $attr);
  	}
  
  	$dbh = $drh->connect(@_);
  	$cache->{$key} = $dbh;	# replace prev entry, even if connect failed
  	return $dbh;
      }
  
  }
  
  
  {   package		# hide from PAUSE
  	DBD::_::db;	# ====== DATABASE ======
      @DBD::_::db::ISA = qw(DBD::_::common);
      use strict;
  
      sub clone {
  	my ($old_dbh, $attr) = @_;
  	my $closure = $old_dbh->{dbi_connect_closure} or return;
  	unless ($attr) {
  	    # copy attributes visible in the attribute cache
  	    keys %$old_dbh;	# reset iterator
  	    while ( my ($k, $v) = each %$old_dbh ) {
  		# ignore non-code refs, i.e., caches, handles, Err etc
  		next if ref $v && ref $v ne 'CODE'; # HandleError etc
  		$attr->{$k} = $v;
  	    }
  	    # explicitly set attributes which are unlikely to be in the
  	    # attribute cache, i.e., boolean's and some others
  	    $attr->{$_} = $old_dbh->FETCH($_) for (qw(
  		AutoCommit ChopBlanks InactiveDestroy
  		LongTruncOk PrintError PrintWarn Profile RaiseError
  		ShowErrorStatement TaintIn TaintOut
  	    ));
  	}
  	# use Data::Dumper; warn Dumper([$old_dbh, $attr]);
  	my $new_dbh = &$closure($old_dbh, $attr);
  	unless ($new_dbh) {
  	    # need to copy err/errstr from driver back into $old_dbh
  	    my $drh = $old_dbh->{Driver};
  	    return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
  	}
  	return $new_dbh;
      }
  
      sub quote_identifier {
  	my ($dbh, @id) = @_;
  	my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
  
  	my $info = $dbh->{dbi_quote_identifier_cache} ||= [
  	    $dbh->get_info(29)  || '"',	# SQL_IDENTIFIER_QUOTE_CHAR
  	    $dbh->get_info(41)  || '.',	# SQL_CATALOG_NAME_SEPARATOR
  	    $dbh->get_info(114) ||   1,	# SQL_CATALOG_LOCATION
  	];
  
  	my $quote = $info->[0];
  	foreach (@id) {			# quote the elements
  	    next unless defined;
  	    s/$quote/$quote$quote/g;	# escape embedded quotes
  	    $_ = qq{$quote$_$quote};
  	}
  
  	# strip out catalog if present for special handling
  	my $catalog = (@id >= 3) ? shift @id : undef;
  
  	# join the dots, ignoring any null/undef elements (ie schema)
  	my $quoted_id = join '.', grep { defined } @id;
  
  	if ($catalog) {			# add catalog correctly
  	    $quoted_id = ($info->[2] == 2)	# SQL_CL_END
  		    ? $quoted_id . $info->[1] . $catalog
  		    : $catalog   . $info->[1] . $quoted_id;
  	}
  	return $quoted_id;
      }
  
      sub quote {
  	my ($dbh, $str, $data_type) = @_;
  
  	return "NULL" unless defined $str;
  	unless ($data_type) {
  	    $str =~ s/'/''/g;		# ISO SQL2
  	    return "'$str'";
  	}
  
  	my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
  	my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
  
  	my $lp = $prefixes->{$data_type};
  	my $ls = $suffixes->{$data_type};
  
  	if ( ! defined $lp || ! defined $ls ) {
  	    my $ti = $dbh->type_info($data_type);
  	    $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
  	    $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
  	}
  	return $str unless $lp || $ls; # no quoting required
  
  	# XXX don't know what the standard says about escaping
  	# in the 'general case' (where $lp != "'").
  	# So we just do this and hope:
  	$str =~ s/$lp/$lp$lp/g
  		if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"');
  	return "$lp$str$ls";
      }
  
      sub rows { -1 }	# here so $DBI::rows 'works' after using $dbh
  
      sub do {
  	my($dbh, $statement, $attr, @params) = @_;
  	my $sth = $dbh->prepare($statement, $attr) or return undef;
  	$sth->execute(@params) or return undef;
  	my $rows = $sth->rows;
  	($rows == 0) ? "0E0" : $rows;
      }
  
      sub _do_selectrow {
  	my ($method, $dbh, $stmt, $attr, @bind) = @_;
  	my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr))
  	    or return;
  	$sth->execute(@bind)
  	    or return;
  	my $row = $sth->$method()
  	    and $sth->finish;
  	return $row;
      }
  
      sub selectrow_hashref {  return _do_selectrow('fetchrow_hashref',  @_); }
  
      # XXX selectrow_array/ref also have C implementations in Driver.xst
      sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); }
      sub selectrow_array {
  	my $row = _do_selectrow('fetchrow_arrayref', @_) or return;
  	return $row->[0] unless wantarray;
  	return @$row;
      }
  
      # XXX selectall_arrayref also has C implementation in Driver.xst
      # which fallsback to this if a slice is given
      sub selectall_arrayref {
  	my ($dbh, $stmt, $attr, @bind) = @_;
  	my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)
  	    or return;
  	$sth->execute(@bind) || return;
  	my $slice = $attr->{Slice}; # typically undef, else hash or array ref
  	if (!$slice and $slice=$attr->{Columns}) {
  	    if (ref $slice eq 'ARRAY') { # map col idx to perl array idx
  		$slice = [ @{$attr->{Columns}} ];	# take a copy
  		for (@$slice) { $_-- }
  	    }
  	}
  	my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
  	$sth->finish if defined $MaxRows;
  	return $rows;
      }
  
      sub selectall_hashref {
  	my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
  	my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
  	return unless $sth;
  	$sth->execute(@bind) || return;
  	return $sth->fetchall_hashref($key_field);
      }
  
      sub selectcol_arrayref {
  	my ($dbh, $stmt, $attr, @bind) = @_;
  	my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
  	return unless $sth;
  	$sth->execute(@bind) || return;
  	my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
  	my @values  = (undef) x @columns;
  	my $idx = 0;
  	for (@columns) {
  	    $sth->bind_col($_, \$values[$idx++]) || return;
  	}
  	my @col;
  	if (my $max = $attr->{MaxRows}) {
  	    push @col, @values while 0 < $max-- && $sth->fetch;
  	}
  	else {
  	    push @col, @values while $sth->fetch;
  	}
  	return \@col;
      }
  
      sub prepare_cached {
  	my ($dbh, $statement, $attr, $if_active) = @_;
  
  	# Needs support at dbh level to clear cache before complaining about
  	# active children. The XS template code does this. Drivers not using
  	# the template must handle clearing the cache themselves.
  	my $cache = $dbh->{CachedKids} ||= {};
  	my $key = do { local $^W;
  	    join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0)
  	};
  	my $sth = $cache->{$key};
  
  	if ($sth) {
  	    return $sth unless $sth->FETCH('Active');
  	    Carp::carp("prepare_cached($statement) statement handle $sth still Active")
  		unless ($if_active ||= 0);
  	    $sth->finish if $if_active <= 1;
  	    return $sth  if $if_active <= 2;
  	}
  
  	$sth = $dbh->prepare($statement, $attr);
  	$cache->{$key} = $sth if $sth;
  
  	return $sth;
      }
  
      sub ping {
  	my $dbh = shift;
  	$dbh->_not_impl('ping');
  	# "0 but true" is a special kind of true 0 that is used here so
  	# applications can check if the ping was a real ping or not
  	($dbh->FETCH('Active')) ?  "0 but true" : 0;
      }
  
      sub begin_work {
  	my $dbh = shift;
  	return $dbh->set_err($DBI::stderr, "Already in a transaction")
  		unless $dbh->FETCH('AutoCommit');
  	$dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
  	$dbh->STORE('BegunWork',  1); # trigger post commit/rollback action
  	return 1;
      }
  
      sub primary_key {
  	my ($dbh, @args) = @_;
  	my $sth = $dbh->primary_key_info(@args) or return;
  	my ($row, @col);
  	push @col, $row->[3] while ($row = $sth->fetch);
  	Carp::croak("primary_key method not called in list context")
  		unless wantarray; # leave us some elbow room
  	return @col;
      }
  
      sub tables {
  	my ($dbh, @args) = @_;
  	my $sth    = $dbh->table_info(@args[0,1,2,3,4]) or return;
  	my $tables = $sth->fetchall_arrayref or return;
  	my @tables;
  	if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
  	    @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
  	}
  	else {		# temporary old style hack (yeach)
  	    @tables = map {
  		my $name = $_->[2];
  		if ($_->[1]) {
  		    my $schema = $_->[1];
  		    # a sad hack (mostly for Informix I recall)
  		    my $quote = ($schema eq uc($schema)) ? '' : '"';
  		    $name = "$quote$schema$quote.$name"
  		}
  		$name;
  	    } @$tables;
  	}
  	return @tables;
      }
  
      sub type_info {	# this should be sufficient for all drivers
  	my ($dbh, $data_type) = @_;
  	my $idx_hash;
  	my $tia = $dbh->{dbi_type_info_row_cache};
  	if ($tia) {
  	    $idx_hash = $dbh->{dbi_type_info_idx_cache};
  	}
  	else {
  	    my $temp = $dbh->type_info_all;
  	    return unless $temp && @$temp;
  	    # we cache here because type_info_all may be expensive to call
  	    # (and we take a copy so the following shift can't corrupt
  	    # the data that may be returned by future calls to type_info_all)
  	    $tia      = $dbh->{dbi_type_info_row_cache} = [ @$temp ];
  	    $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
  	}
  
  	my $dt_idx   = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type};
  	Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)")
  	    if $dt_idx && $dt_idx != 1;
  
  	# --- simple DATA_TYPE match filter
  	my @ti;
  	my @data_type_list = (ref $data_type) ? @$data_type : ($data_type);
  	foreach $data_type (@data_type_list) {
  	    if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
  		push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
  	    }
  	    else {	# SQL_ALL_TYPES
  		push @ti, @$tia;
  	    }
  	    last if @ti;	# found at least one match
  	}
  
  	# --- format results into list of hash refs
  	my $idx_fields = keys %$idx_hash;
  	my @idx_names  = map { uc($_) } keys %$idx_hash;
  	my @idx_values = values %$idx_hash;
  	Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
  		if @ti && @{$ti[0]} != $idx_fields;
  	my @out = map {
  	    my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
  	} @ti;
  	return $out[0] unless wantarray;
  	return @out;
      }
  
      sub data_sources {
  	my ($dbh, @other) = @_;
  	my $drh = $dbh->{Driver}; # XXX proxy issues?
  	return $drh->data_sources(@other);
      }
  
  }
  
  
  {   package		# hide from PAUSE
  	DBD::_::st;	# ====== STATEMENT ======
      @DBD::_::st::ISA = qw(DBD::_::common);
      use strict;
  
      sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
  
  #
  # ********************************************************
  #
  #	BEGIN ARRAY BINDING
  #
  #	Array binding support for drivers which don't support
  #	array binding, but have sufficient interfaces to fake it.
  #	NOTE: mixing scalars and arrayrefs requires using bind_param_array
  #	for *all* params...unless we modify bind_param for the default
  #	case...
  #
  #	2002-Apr-10	D. Arnold
  
      sub bind_param_array {
  	my $sth = shift;
  	my ($p_id, $value_array, $attr) = @_;
  
  	return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
  	    if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
  
  	return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
  	    unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
  
  	return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range")
  	    if $p_id <= 0; # can't easily/reliably test for too big
  
  	# get/create arrayref to hold params
  	my $hash_of_arrays = $sth->{ParamArrays} ||= { };
  
  	# If the bind has attribs then we rely on the driver conforming to
  	# the DBI spec in that a single bind_param() call with those attribs
  	# makes them 'sticky' and apply to all later execute(@values) calls.
  	# Since we only call bind_param() if we're given attribs then
  	# applications using drivers that don't support bind_param can still
  	# use bind_param_array() so long as they don't pass any attribs.
  
  	$$hash_of_arrays{$p_id} = $value_array;
  	return $sth->bind_param($p_id, undef, $attr)
  		if $attr;
  	1;
      }
  
      sub bind_param_inout_array {
  	my $sth = shift;
  	# XXX not supported so we just call bind_param_array instead
  	# and then return an error
  	my ($p_num, $value_array, $attr) = @_;
  	$sth->bind_param_array($p_num, $value_array, $attr);
  	return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported");
      }
  
      sub bind_columns {
  	my $sth = shift;
  	my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
  	if ($fields <= 0 && !$sth->{Active}) {
  	    return $sth->set_err($DBI::stderr, "Statement has no result columns to bind"
  		    ." (perhaps you need to successfully call execute first)");
  	}
  	# Backwards compatibility for old-style call with attribute hash
  	# ref as first arg. Skip arg if undef or a hash ref.
  	my $attr;
  	$attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
  
  	my $idx = 0;
  	$sth->bind_col(++$idx, shift, $attr) or return
  	    while (@_ and $idx < $fields);
  
  	return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed")
  	    if @_ or $idx != $fields;
  
  	return 1;
      }
  
      sub execute_array {
  	my $sth = shift;
  	my ($attr, @array_of_arrays) = @_;
  	my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
  
  	# get tuple status array or hash attribute
  	my $tuple_sts = $attr->{ArrayTupleStatus};
  	return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref")
  		if $tuple_sts and ref $tuple_sts ne 'ARRAY';
  
  	# bind all supplied arrays
  	if (@array_of_arrays) {
  	    $sth->{ParamArrays} = { };	# clear out old params
  	    return $sth->set_err($DBI::stderr,
  		    @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected")
  		if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS;
  	    $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return
  		foreach (1..@array_of_arrays);
  	}
  
  	my $fetch_tuple_sub;
  
  	if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) {	# fetch on demand
  
  	    return $sth->set_err($DBI::stderr,
  		    "Can't use both ArrayTupleFetch and explicit bind values")
  		if @array_of_arrays; # previous bind_param_array calls will simply be ignored
  
  	    if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) {
  		my $fetch_sth = $fetch_tuple_sub;
  		return $sth->set_err($DBI::stderr,
  			"ArrayTupleFetch sth is not Active, need to execute() it first")
  		    unless $fetch_sth->{Active};
  		# check column count match to give more friendly message
  		my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS};
  		return $sth->set_err($DBI::stderr,
  			"$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected")
  		    if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS)
  		    && $NUM_OF_FIELDS != $NUM_OF_PARAMS;
  		$fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref };
  	    }
  	    elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) {
  		return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle");
  	    }
  
  	}
  	else {
  	    my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} };
  	    return $sth->set_err($DBI::stderr,
  		    "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected")
  		if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given;
  
  	    # get the length of a bound array
  	    my $maxlen;
  	    my %hash_of_arrays = %{$sth->{ParamArrays}};
  	    foreach (keys(%hash_of_arrays)) {
  		my $ary = $hash_of_arrays{$_};
  		next unless ref $ary eq 'ARRAY';
  		$maxlen = @$ary if !$maxlen || @$ary > $maxlen;
  	    }
  	    # if there are no arrays then execute scalars once
  	    $maxlen = 1 unless defined $maxlen;
  	    my @bind_ids = 1..keys(%hash_of_arrays);
  
  	    my $tuple_idx = 0;
  	    $fetch_tuple_sub = sub {
  		return if $tuple_idx >= $maxlen;
  		my @tuple = map {
  		    my $a = $hash_of_arrays{$_};
  		    ref($a) ? $a->[$tuple_idx] : $a
  		} @bind_ids;
  		++$tuple_idx;
  		return \@tuple;
  	    };
  	}
  	# pass thru the callers scalar or list context
  	return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts);
      }
  
      sub execute_for_fetch {
  	my ($sth, $fetch_tuple_sub, $tuple_status) = @_;
  	# start with empty status array
  	($tuple_status) ? @$tuple_status = () : $tuple_status = [];
  
          my $rc_total = 0;
  	my $err_count;
  	while ( my $tuple = &$fetch_tuple_sub() ) {
  	    if ( my $rc = $sth->execute(@$tuple) ) {
  		push @$tuple_status, $rc;
  		$rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1;
  	    }
  	    else {
  		$err_count++;
  		push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
                  # XXX drivers implementing execute_for_fetch could opt to "last;" here
                  # if they know the error code means no further executes will work.
  	    }
  	}
          my $tuples = @$tuple_status;
          return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors")
              if $err_count;
  	$tuples ||= "0E0";
  	return $tuples unless wantarray;
  	return ($tuples, $rc_total);
      }
  
  
      sub fetchall_arrayref {	# ALSO IN Driver.xst
  	my ($sth, $slice, $max_rows) = @_;
  
          # when batch fetching with $max_rows were very likely to try to
          # fetch the 'next batch' after the previous batch returned
          # <=$max_rows. So don't treat that as an error.
          return undef if $max_rows and not $sth->FETCH('Active');
  
  	my $mode = ref($slice) || 'ARRAY';
  	my @rows;
  	my $row;
  	if ($mode eq 'ARRAY') {
  	    # we copy the array here because fetch (currently) always
  	    # returns the same array ref. XXX
  	    if ($slice && @$slice) {
                  $max_rows = -1 unless defined $max_rows;
  		push @rows, [ @{$row}[ @$slice] ]
  		    while($max_rows-- and $row = $sth->fetch);
  	    }
  	    elsif (defined $max_rows) {
  		push @rows, [ @$row ]
  		    while($max_rows-- and $row = $sth->fetch);
  	    }
  	    else {
  		push @rows, [ @$row ] while($row = $sth->fetch);
  	    }
  	}
  	elsif ($mode eq 'HASH') {
  	    $max_rows = -1 unless defined $max_rows;
  	    if (keys %$slice) {
  		my @o_keys = keys %$slice;
  		my @i_keys = map { lc } keys %$slice;
                  # XXX this could be made faster by pre-binding a local hash
                  # using bind_columns and then copying it per row
  		while ($max_rows-- and $row = $sth->fetchrow_hashref('NAME_lc')) {
  		    my %hash;
  		    @hash{@o_keys} = @{$row}{@i_keys};
  		    push @rows, \%hash;
  		}
  	    }
  	    else {
  		# XXX assumes new ref each fetchhash
  		push @rows, $row
  		    while ($max_rows-- and $row = $sth->fetchrow_hashref());
  	    }
  	}
  	else { Carp::croak("fetchall_arrayref($mode) invalid") }
  	return \@rows;
      }
  
      sub fetchall_hashref {
  	my ($sth, $key_field) = @_;
  
          my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
          my $names_hash = $sth->FETCH("${hash_key_name}_hash");
          my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
          my @key_indexes;
          my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
          foreach (@key_fields) {
             my $index = $names_hash->{$_};  # perl index not column
             $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
             return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
                  unless defined $index;
             push @key_indexes, $index;
          }
          my $rows = {};
          my $NAME = $sth->FETCH($hash_key_name);
          my @row = (undef) x $num_of_fields;
          $sth->bind_columns(\(@row));
          while ($sth->fetch) {
              my $ref = $rows;
              $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
              @{$ref}{@$NAME} = @row;
          }
          return $rows;
      }
  
      *dump_results = \&DBI::dump_results;
  
      sub blob_copy_to_file {	# returns length or undef on error
  	my($self, $field, $filename_or_handleref, $blocksize) = @_;
  	my $fh = $filename_or_handleref;
  	my($len, $buf) = (0, "");
  	$blocksize ||= 512;	# not too ambitious
  	local(*FH);
  	unless(ref $fh) {
  	    open(FH, ">$fh") || return undef;
  	    $fh = \*FH;
  	}
  	while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
  	    print $fh $buf;
  	    $len += length $buf;
  	}
  	close(FH);
  	$len;
      }
  
      sub more_results {
  	shift->{syb_more_results};	# handy grandfathering
      }
  
  }
  
  unless ($DBI::PurePerl) {   # See install_driver
      { @DBD::_mem::dr::ISA = qw(DBD::_mem::common);	}
      { @DBD::_mem::db::ISA = qw(DBD::_mem::common);	}
      { @DBD::_mem::st::ISA = qw(DBD::_mem::common);	}
      # DBD::_mem::common::DESTROY is implemented in DBI.xs
  }
  
  1;
  __END__
  
  =head1 DESCRIPTION
  
  The DBI is a database access module for the Perl programming language.  It defines
  a set of methods, variables, and conventions that provide a consistent
  database interface, independent of the actual database being used.
  
  It is important to remember that the DBI is just an interface.
  The DBI is a layer
  of "glue" between an application and one or more database I<driver>
  modules.  It is the driver modules which do most of the real work. The DBI
  provides a standard interface and framework for the drivers to operate
  within.
  
  
  =head2 Architecture of a DBI Application
  
               |<- Scope of DBI ->|
                    .-.   .--------------.   .-------------.
    .-------.       | |---| XYZ Driver   |---| XYZ Engine  |
    | Perl  |       | |   `--------------'   `-------------'
    | script|  |A|  |D|   .--------------.   .-------------.
    | using |--|P|--|B|---|Oracle Driver |---|Oracle Engine|
    | DBI   |  |I|  |I|   `--------------'   `-------------'
    | API   |       | |...
    |methods|       | |... Other drivers
    `-------'       | |...
                    `-'
  
  The API, or Application Programming Interface, defines the
  call interface and variables for Perl scripts to use. The API
  is implemented by the Perl DBI extension.
  
  The DBI "dispatches" the method calls to the appropriate driver for
  actual execution.  The DBI is also responsible for the dynamic loading
  of drivers, error checking and handling, providing default
  implementations for methods, and many other non-database specific duties.
  
  Each driver
  contains implementations of the DBI methods using the
  private interface functions of the corresponding database engine.  Only authors
  of sophisticated/multi-database applications or generic library
  functions need be concerned with drivers.
  
  =head2 Notation and Conventions
  
  The following conventions are used in this document:
  
    $dbh    Database handle object
    $sth    Statement handle object
    $drh    Driver handle object (rarely seen or used in applications)
    $h      Any of the handle types above ($dbh, $sth, or $drh)
    $rc     General Return Code  (boolean: true=ok, false=error)
    $rv     General Return Value (typically an integer)
    @ary    List of values returned from the database, typically a row of data
    $rows   Number of rows processed (if available, else -1)
    $fh     A filehandle
    undef   NULL values are represented by undefined values in Perl
    \%attr  Reference to a hash of attribute values passed to methods
  
  Note that Perl will automatically destroy database and statement handle objects
  if all references to them are deleted.
  
  
  =head2 Outline Usage
  
  To use DBI,
  first you need to load the DBI module:
  
    use DBI;
    use strict;
  
  (The C<use strict;> isn't required but is strongly recommended.)
  
  Then you need to L</connect> to your data source and get a I<handle> for that
  connection:
  
    $dbh = DBI->connect($dsn, $user, $password,
                        { RaiseError => 1, AutoCommit => 0 });
  
  Since connecting can be expensive, you generally just connect at the
  start of your program and disconnect at the end.
  
  Explicitly defining the required C<AutoCommit> behaviour is strongly
  recommended and may become mandatory in a later version.  This
  determines whether changes are automatically committed to the
  database when executed, or need to be explicitly committed later.
  
  The DBI allows an application to "prepare" statements for later
  execution.  A prepared statement is identified by a statement handle
  held in a Perl variable.
  We'll call the Perl variable C<$sth> in our examples.
  
  The typical method call sequence for a C<SELECT> statement is:
  
    prepare,
      execute, fetch, fetch, ...
      execute, fetch, fetch, ...
      execute, fetch, fetch, ...
  
  for example:
  
    $sth = $dbh->prepare("SELECT foo, bar FROM table WHERE baz=?");
  
    $sth->execute( $baz );
  
    while ( @row = $sth->fetchrow_array ) {
      print "@row\n";
    }
  
  The typical method call sequence for a I<non>-C<SELECT> statement is:
  
    prepare,
      execute,
      execute,
      execute.
  
  for example:
  
    $sth = $dbh->prepare("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)");
  
    while(<CSV>) {
      chomp;
      my ($foo,$bar,$baz) = split /,/;
  	$sth->execute( $foo, $bar, $baz );
    }
  
  The C<do()> method can be used for non repeated I<non>-C<SELECT> statement
  (or with drivers that don't support placeholders):
  
    $rows_affected = $dbh->do("UPDATE your_table SET foo = foo + 1");
  
  To commit your changes to the database (when L</AutoCommit> is off):
  
    $dbh->commit;  # or call $dbh->rollback; to undo changes
  
  Finally, when you have finished working with the data source, you should
  L</disconnect> from it:
  
    $dbh->disconnect;
  
  
  =head2 General Interface Rules & Caveats
  
  The DBI does not have a concept of a "current session". Every session
  has a handle object (i.e., a C<$dbh>) returned from the C<connect> method.
  That handle object is used to invoke database related methods.
  
  Most data is returned to the Perl script as strings. (Null values are
  returned as C<undef>.)  This allows arbitrary precision numeric data to be
  handled without loss of accuracy.  Beware that Perl may not preserve
  the same accuracy when the string is used as a number.
  
  Dates and times are returned as character strings in the current
  default format of the corresponding database engine.  Time zone effects
  are database/driver dependent.
  
  Perl supports binary data in Perl strings, and the DBI will pass binary
  data to and from the driver without change. It is up to the driver
  implementors to decide how they wish to handle such binary data.
  
  Perl supports two kinds of strings: unicode (utf8 internally) and non-unicode
  (defaults to iso-8859-1 if forced to assume an encoding).  Drivers should
  accept both kinds of strings and, if required, convert them to the character
  set of the database being used. Similarly, when fetching from the database
  character data that isn't iso-8859-1 the driver should convert it into utf8.
  
  Multiple SQL statements may not be combined in a single statement
  handle (C<$sth>), although some databases and drivers do support this
  (notably Sybase and SQL Server).
  
  Non-sequential record reads are not supported in this version of the DBI.
  In other words, records can only be fetched in the order that the
  database returned them, and once fetched they are forgotten.
  
  Positioned updates and deletes are not directly supported by the DBI.
  See the description of the C<CursorName> attribute for an alternative.
  
  Individual driver implementors are free to provide any private
  functions and/or handle attributes that they feel are useful.
  Private driver functions can be invoked using the DBI C<func()> method.
  Private driver attributes are accessed just like standard attributes.
  
  Many methods have an optional C<\%attr> parameter which can be used to
  pass information to the driver implementing the method. Except where
  specifically documented, the C<\%attr> parameter can only be used to pass
  driver specific hints. In general, you can ignore C<\%attr> parameters
  or pass it as C<undef>.
  
  
  =head2 Naming Conventions and Name Space
  
  The DBI package and all packages below it (C<DBI::*>) are reserved for
  use by the DBI. Extensions and related modules use the C<DBIx::>
  namespace (see L<http://www.perl.com/CPAN/modules/by-module/DBIx/>).
  Package names beginning with C<DBD::> are reserved for use
  by DBI database drivers.  All environment variables used by the DBI
  or by individual DBDs begin with "C<DBI_>" or "C<DBD_>".
  
  The letter case used for attribute names is significant and plays an
  important part in the portability of DBI scripts.  The case of the
  attribute name is used to signify who defined the meaning of that name
  and its values.
  
    Case of name  Has a meaning defined by
    ------------  ------------------------
    UPPER_CASE    Standards, e.g.,  X/Open, ISO SQL92 etc (portable)
    MixedCase     DBI API (portable), underscores are not used.
    lower_case    Driver or database engine specific (non-portable)
  
  It is of the utmost importance that Driver developers only use
  lowercase attribute names when defining private attributes. Private
  attribute names must be prefixed with the driver name or suitable
  abbreviation (e.g., "C<ora_>" for Oracle, "C<ing_>" for Ingres, etc).
  
  
  =head2 SQL - A Query Language
  
  Most DBI drivers require applications to use a dialect of SQL
  (Structured Query Language) to interact with the database engine.
  The L</"Standards Reference Information"> section provides links
  to useful information about SQL.
  
  The DBI itself does not mandate or require any particular language to
  be used; it is language independent. In ODBC terms, the DBI is in
  "pass-thru" mode, although individual drivers might not be. The only requirement
  is that queries and other statements must be expressed as a single
  string of characters passed as the first argument to the L</prepare> or
  L</do> methods.
  
  For an interesting diversion on the I<real> history of RDBMS and SQL,
  from the people who made it happen, see:
  
    http://ftp.digital.com/pub/DEC/SRC/technical-notes/SRC-1997-018-html/sqlr95.html
  
  Follow the "Full Contents" then "Intergalactic dataspeak" links for the
  SQL history.
  
  =head2 Placeholders and Bind Values
  
  Some drivers support placeholders and bind values.
  I<Placeholders>, also called parameter markers, are used to indicate
  values in a database statement that will be supplied later,
  before the prepared statement is executed.  For example, an application
  might use the following to insert a row of data into the SALES table:
  
    INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?)
  
  or the following, to select the description for a product:
  
    SELECT description FROM products WHERE product_code = ?
  
  The C<?> characters are the placeholders.  The association of actual
  values with placeholders is known as I<binding>, and the values are
  referred to as I<bind values>.
  Note that the C<?> is not enclosed in quotation marks, even when the
  placeholder represents a string.
  
  Some drivers also allow placeholders like C<:>I<name> and C<:>I<N> (e.g.,
  C<:1>, C<:2>, and so on) in addition to C<?>, but their use is not portable.
  
  If the C<:>I<N> form of placeholder is supported by the driver you're using,
  then you should be able to use either L</bind_param> or L</execute> to bind
  values. Check your driver documentation.
  
  With most drivers, placeholders can't be used for any element of a
  statement that would prevent the database server from validating the
  statement and creating a query execution plan for it. For example:
  
    "SELECT name, age FROM ?"         # wrong (will probably fail)
    "SELECT name, ?   FROM people"    # wrong (but may not 'fail')
  
  Also, placeholders can only represent single scalar values.
  For example, the following
  statement won't work as expected for more than one value:
  
    "SELECT name, age FROM people WHERE name IN (?)"    # wrong
    "SELECT name, age FROM people WHERE name IN (?,?)"  # two names
  
  When using placeholders with the SQL C<LIKE> qualifier, you must
  remember that the placeholder substitutes for the whole string.
  So you should use "C<... LIKE ? ...>" and include any wildcard
  characters in the value that you bind to the placeholder.
  
  B<NULL Values>
  
  Undefined values, or C<undef>, are used to indicate NULL values.
  You can insert and update columns with a NULL value as you would a
  non-NULL value.  These examples insert and update the column
  C<age> with a NULL value:
  
    $sth = $dbh->prepare(qq{
      INSERT INTO people (fullname, age) VALUES (?, ?)
    });
    $sth->execute("Joe Bloggs", undef);
  
    $sth = $dbh->prepare(qq{
      UPDATE people SET age = ? WHERE fullname = ?
    });
    $sth->execute(undef, "Joe Bloggs");
  
  However, care must be taken when trying to use NULL values in a
  C<WHERE> clause.  Consider:
  
    SELECT fullname FROM people WHERE age = ?
  
  Binding an C<undef> (NULL) to the placeholder will I<not> select rows
  which have a NULL C<age>!  At least for database engines that
  conform to the SQL standard.  Refer to the SQL manual for your database
  engine or any SQL book for the reasons for this.  To explicitly select
  NULLs you have to say "C<WHERE age IS NULL>".
  
  A common issue is to have a code fragment handle a value that could be
  either C<defined> or C<undef> (non-NULL or NULL) at runtime.
  A simple technique is to prepare the appropriate statement as needed,
  and substitute the placeholder for non-NULL cases:
  
    $sql_clause = defined $age? "age = ?" : "age IS NULL";
    $sth = $dbh->prepare(qq{
      SELECT fullname FROM people WHERE $sql_clause
    });
    $sth->execute(defined $age ? $age : ());
  
  The following technique illustrates qualifying a C<WHERE> clause with
  several columns, whose associated values (C<defined> or C<undef>) are
  in a hash %h:
  
    for my $col ("age", "phone", "email") {
      if (defined $h{$col}) {
        push @sql_qual, "$col = ?";
        push @sql_bind, $h{$col};
      }
      else {
        push @sql_qual, "$col IS NULL";
      }
    }
    $sql_clause = join(" AND ", @sql_qual);
    $sth = $dbh->prepare(qq{
        SELECT fullname FROM people WHERE $sql_clause
    });
    $sth->execute(@sql_bind);
  
  The techniques above call prepare for the SQL statement with each call to
  execute.  Because calls to prepare() can be expensive, performance
  can suffer when an application iterates many times over statements
  like the above.
  
  A better solution is a single C<WHERE> clause that supports both
  NULL and non-NULL comparisons.  Its SQL statement would need to be
  prepared only once for all cases, thus improving performance.
  Several examples of C<WHERE> clauses that support this are presented
  below.  But each example lacks portability, robustness, or simplicity.
  Whether an example is supported on your database engine depends on
  what SQL extensions it provides, and where it supports the C<?>
  placeholder in a statement.
  
    0)  age = ?
    1)  NVL(age, xx) = NVL(?, xx)
    2)  ISNULL(age, xx) = ISNULL(?, xx)
    3)  DECODE(age, ?, 1, 0) = 1
    4)  age = ? OR (age IS NULL AND ? IS NULL)
    5)  age = ? OR (age IS NULL AND SP_ISNULL(?) = 1)
    6)  age = ? OR (age IS NULL AND ? = 1)
  
  Statements formed with the above C<WHERE> clauses require execute
  statements as follows.  The arguments are required, whether their
  values are C<defined> or C<undef>.
  
    0,1,2,3)  $sth->execute($age);
    4,5)      $sth->execute($age, $age);
    6)        $sth->execute($age, defined($age) ? 0 : 1);
  
  Example 0 should not work (as mentioned earlier), but may work on
  a few database engines anyway (e.g. Sybase).  Example 0 is part
  of examples 4, 5, and 6, so if example 0 works, these other
  examples may work, even if the engine does not properly support
  the right hand side of the C<OR> expression.
  
  Examples 1 and 2 are not robust: they require that you provide a
  valid column value xx (e.g. '~') which is not present in any row.
  That means you must have some notion of what data won't be stored
  in the column, and expect clients to adhere to that.
  
  Example 5 requires that you provide a stored procedure (SP_ISNULL
  in this example) that acts as a function: it checks whether a value
  is null, and returns 1 if it is, or 0 if not.
  
  Example 6, the least simple, is probably the most portable, i.e., it
  should work with with most, if not all, database engines.
  
  Here is a table that indicates which examples above are known to
  work on various database engines:
  
                     -----Examples------
                     0  1  2  3  4  5  6
                     -  -  -  -  -  -  -
    Oracle 9         N  Y  N  Y  Y  ?  Y
    Informix IDS 9   N  N  N  Y  N  Y  Y
    MS SQL           N  N  Y  N  Y  ?  Y
    Sybase           Y  N  N  N  N  N  Y
    AnyData,DBM,CSV  Y  N  N  N  Y  Y* Y
    SQLite 3.3       N  N  N  N  Y  N  N
  
  * Works only because Example 0 works.
  
  DBI provides a sample perl script that will test the examples above
  on your database engine and tell you which ones work.  It is located
  in the F<ex/> subdirectory of the DBI source distribution, or here:
  L<http://svn.perl.org/modules/dbi/trunk/ex/perl_dbi_nulls_test.pl>
  Please use the script to help us fill-in and maintain this table.
  
  B<Performance>
  
  Without using placeholders, the insert statement shown previously would have to
  contain the literal values to be inserted and would have to be
  re-prepared and re-executed for each row. With placeholders, the insert
  statement only needs to be prepared once. The bind values for each row
  can be given to the C<execute> method each time it's called. By avoiding
  the need to re-prepare the statement for each row, the application
  typically runs many times faster. Here's an example:
  
    my $sth = $dbh->prepare(q{
      INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?)
    }) or die $dbh->errstr;
    while (<>) {
        chomp;
        my ($product_code, $qty, $price) = split /,/;
        $sth->execute($product_code, $qty, $price) or die $dbh->errstr;
    }
    $dbh->commit or die $dbh->errstr;
  
  See L</execute> and L</bind_param> for more details.
  
  The C<q{...}> style quoting used in this example avoids clashing with
  quotes that may be used in the SQL statement. Use the double-quote like
  C<qq{...}> operator if you want to interpolate variables into the string.
  See L<perlop/"Quote and Quote-like Operators"> for more details.
  
  See also the L</bind_columns> method, which is used to associate Perl
  variables with the output columns of a C<SELECT> statement.
  
  =head1 THE DBI PACKAGE AND CLASS
  
  In this section, we cover the DBI class methods, utility functions,
  and the dynamic attributes associated with generic DBI handles.
  
  =head2 DBI Constants
  
  Constants representing the values of the SQL standard types can be
  imported individually by name, or all together by importing the
  special C<:sql_types> tag.
  
  The names and values of all the defined SQL standard types can be
  produced like this:
  
    foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) {
      printf "%s=%d\n", $_, &{"DBI::$_"};
    }
  
  These constants are defined by SQL/CLI, ODBC or both.
  C<SQL_BIGINT> is (currently) omitted, because SQL/CLI and ODBC provide
  conflicting codes.
  
  See the L</type_info>, L</type_info_all>, and L</bind_param> methods
  for possible uses.
  
  Note that just because the DBI defines a named constant for a given
  data type doesn't mean that drivers will support that data type.
  
  
  =head2 DBI Class Methods
  
  The following methods are provided by the DBI class:
  
  =head3 C<parse_dsn>
  
    ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn($dsn)
        or die "Can't parse DBI DSN '$dsn'";
  
  Breaks apart a DBI Data Source Name (DSN) and returns the individual
  parts. If $dsn doesn't contain a valid DSN then parse_dsn() returns
  an empty list.
  
  $scheme is the first part of the DSN and is currently always 'dbi'.
  $driver is the driver name, possibly defaulted to $ENV{DBI_DRIVER},
  and may be undefined.  $attr_string is the contents of the optional attribute
  string, which may be undefined.  If $attr_string is not empty then $attr_hash
  is a reference to a hash containing the parsed attribute names and values.
  $driver_dsn is the last part of the DBI DSN string. For example:
  
    ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn)
        = DBI->parse_dsn("DBI:MyDriver(RaiseError=>1):db=test;port=42");
    $scheme      = 'dbi';
    $driver      = 'MyDriver';
    $attr_string = 'RaiseError=>1';
    $attr_hash   = { 'RaiseError' => '1' };
    $driver_dsn  = 'db=test;port=42';
  
  The parse_dsn() method was added in DBI 1.43.
  
  =head3 C<connect>
  
    $dbh = DBI->connect($data_source, $username, $password)
              or die $DBI::errstr;
    $dbh = DBI->connect($data_source, $username, $password, \%attr)
              or die $DBI::errstr;
  
  Establishes a database connection, or session, to the requested C<$data_source>.
  Returns a database handle object if the connection succeeds. Use
  C<$dbh-E<gt>disconnect> to terminate the connection.
  
  If the connect fails (see below), it returns C<undef> and sets both C<$DBI::err>
  and C<$DBI::errstr>. (It does I<not> explicitly set C<$!>.) You should generally
  test the return status of C<connect> and C<print $DBI::errstr> if it has failed.
  
  Multiple simultaneous connections to multiple databases through multiple
  drivers can be made via the DBI. Simply make one C<connect> call for each
  database and keep a copy of each returned database handle.
  
  The C<$data_source> value must begin with "C<dbi:>I<driver_name>C<:>".
  The I<driver_name> specifies the driver that will be used to make the
  connection. (Letter case is significant.)
  
  As a convenience, if the C<$data_source> parameter is undefined or empty,
  the DBI will substitute the value of the environment variable C<DBI_DSN>.
  If just the I<driver_name> part is empty (i.e., the C<$data_source>
  prefix is "C<dbi::>"), the environment variable C<DBI_DRIVER> is
  used. If neither variable is set, then C<connect> dies.
  
  Examples of C<$data_source> values are:
  
    dbi:DriverName:database_name
    dbi:DriverName:database_name@hostname:port
    dbi:DriverName:database=database_name;host=hostname;port=port
  
  There is I<no standard> for the text following the driver name. Each
  driver is free to use whatever syntax it wants. The only requirement the
  DBI makes is that all the information is supplied in a single string.
  You must consult the documentation for the drivers you are using for a
  description of the syntax they require.
  
  It is recommended that drivers support the ODBC style, shown in the
  last example above. It is also recommended that that they support the
  three common names 'C<host>', 'C<port>', and 'C<database>' (plus 'C<db>'
  as an alias for C<database>). This simplifies automatic construction
  of basic DSNs: C<"dbi:$driver:database=$db;host=$host;port=$port">.
  Drivers should aim to 'do something reasonable' when given a DSN
  in this form, but if any part is meaningless for that driver (such
  as 'port' for Informix) it should generate an error if that part
  is not empty.
  
  If the environment variable C<DBI_AUTOPROXY> is defined (and the
  driver in C<$data_source> is not "C<Proxy>") then the connect request
  will automatically be changed to:
  
    $ENV{DBI_AUTOPROXY};dsn=$data_source
  
  C<DBI_AUTOPROXY> is typically set as "C<dbi:Proxy:hostname=...;port=...>".
  If $ENV{DBI_AUTOPROXY} doesn't begin with 'C<dbi:>' then "dbi:Proxy:"
  will be prepended to it first.  See the DBD::Proxy documentation
  for more details.
  
  If C<$username> or C<$password> are undefined (rather than just empty),
  then the DBI will substitute the values of the C<DBI_USER> and C<DBI_PASS>
  environment variables, respectively.  The DBI will warn if the
  environment variables are not defined.  However, the everyday use
  of these environment variables is not recommended for security
  reasons. The mechanism is primarily intended to simplify testing.
  See below for alternative way to specify the username and password.
  
  C<DBI-E<gt>connect> automatically installs the driver if it has not been
  installed yet. Driver installation either returns a valid driver
  handle, or it I<dies> with an error message that includes the string
  "C<install_driver>" and the underlying problem. So C<DBI-E<gt>connect>
  will die
  on a driver installation failure and will only return C<undef> on a
  connect failure, in which case C<$DBI::errstr> will hold the error message.
  Use C<eval { ... }> if you need to catch the "C<install_driver>" error.
  
  The C<$data_source> argument (with the "C<dbi:...:>" prefix removed) and the
  C<$username> and C<$password> arguments are then passed to the driver for
  processing. The DBI does not define any interpretation for the
  contents of these fields.  The driver is free to interpret the
  C<$data_source>, C<$username>, and C<$password> fields in any way, and supply
  whatever defaults are appropriate for the engine being accessed.
  (Oracle, for example, uses the ORACLE_SID and TWO_TASK environment
  variables if no C<$data_source> is specified.)
  
  The C<AutoCommit> and C<PrintError> attributes for each connection
  default to "on". (See L</AutoCommit> and L</PrintError> for more information.)
  However, it is strongly recommended that you explicitly define C<AutoCommit>
  rather than rely on the default. The C<PrintWarn> attribute defaults to
  on if $^W is true, i.e., perl is running with warnings enabled.
  
  The C<\%attr> parameter can be used to alter the default settings of
  C<PrintError>, C<RaiseError>, C<AutoCommit>, and other attributes. For example:
  
    $dbh = DBI->connect($data_source, $user, $pass, {
  	PrintError => 0,
  	AutoCommit => 0
    });
  
  The username and password can also be specified using the attributes
  C<Username> and C<Password>, in which case they take precedence
  over the C<$username> and C<$password> parameters.
  
  You can also define connection attribute values within the C<$data_source>
  parameter. For example:
  
    dbi:DriverName(PrintWarn=>1,PrintError=>0,Taint=>1):...
  
  Individual attributes values specified in this way take precedence over
  any conflicting values specified via the C<\%attr> parameter to C<connect>.
  
  The C<dbi_connect_method> attribute can be used to specify which driver
  method should be called to establish the connection. The only useful
  values are 'connect', 'connect_cached', or some specialized case like
  'Apache::DBI::connect' (which is automatically the default when running
  within Apache).
  
  Where possible, each session (C<$dbh>) is independent from the transactions
  in other sessions. This is useful when you need to hold cursors open
  across transactions--for example, if you use one session for your long lifespan
  cursors (typically read-only) and another for your short update
  transactions.
  
  For compatibility with old DBI scripts, the driver can be specified by
  passing its name as the fourth argument to C<connect> (instead of C<\%attr>):
  
    $dbh = DBI->connect($data_source, $user, $pass, $driver);
  
  In this "old-style" form of C<connect>, the C<$data_source> should not start
  with "C<dbi:driver_name:>". (If it does, the embedded driver_name
  will be ignored). Also note that in this older form of C<connect>,
  the C<$dbh-E<gt>{AutoCommit}> attribute is I<undefined>, the
  C<$dbh-E<gt>{PrintError}> attribute is off, and the old C<DBI_DBNAME>
  environment variable is
  checked if C<DBI_DSN> is not defined. Beware that this "old-style"
  C<connect> will soon be withdrawn in a future version of DBI.
  
  =head3 C<connect_cached>
  
    $dbh = DBI->connect_cached($data_source, $username, $password)
              or die $DBI::errstr;
    $dbh = DBI->connect_cached($data_source, $username, $password, \%attr)
              or die $DBI::errstr;
  
  C<connect_cached> is like L</connect>, except that the database handle
  returned is also
  stored in a hash associated with the given parameters. If another call
  is made to C<connect_cached> with the same parameter values, then the
  corresponding cached C<$dbh> will be returned if it is still valid.
  The cached database handle is replaced with a new connection if it
  has been disconnected or if the C<ping> method fails.
  
  Note that the behaviour of this method differs in several respects from the
  behaviour of persistent connections implemented by Apache::DBI.
  However, if Apache::DBI is loaded then C<connect_cached> will use it.
  
  Caching connections can be useful in some applications, but it can
  also cause problems, such as too many connections, and so should
  be used with care. In particular, avoid changing the attributes of
  a database handle created via connect_cached() because it will affect
  other code that may be using the same handle. When connect_cached()
  returns a handle the attributes will be reset to their initial values.
  This can cause problems, especially with the C<AutoCommit> attribute.
  
  Where multiple separate parts of a program are using connect_cached()
  to connect to the same database with the same (initial) attributes
  it is a good idea to add a private attribute to the connect_cached()
  call to effectively limit the scope of the caching. For example:
  
    DBI->connect_cached(..., { private_foo_cachekey => "Bar", ... });
  
  Handles returned from that connect_cached() call will only be returned
  by other connect_cached() call elsewhere in the code if those other
  calls also pass in the same attribute values, including the private one.
  (I've used C<private_foo_cachekey> here as an example, you can use
  any attribute name with a C<private_> prefix.)
  
  Taking that one step further, you can limit a particular connect_cached()
  call to return handles unique to that one place in the code by setting the
  private attribute to a unique value for that place:
  
    DBI->connect_cached(..., { private_foo_cachekey => __FILE__.__LINE__, ... });
  
  By using a private attribute you still get connection caching for
  the individual calls to connect_cached() but, by making separate
  database connections for separate parts of the code, the database
  handles are isolated from any attribute changes made to other handles.
  
  The cache can be accessed (and cleared) via the L</CachedKids> attribute:
  
    my $CachedKids_hashref = $dbh->{Driver}->{CachedKids};
    %$CachedKids_hashref = () if $CachedKids_hashref;
  
  
  =head3 C<available_drivers>
  
    @ary = DBI->available_drivers;
    @ary = DBI->available_drivers($quiet);
  
  Returns a list of all available drivers by searching for C<DBD::*> modules
  through the directories in C<@INC>. By default, a warning is given if
  some drivers are hidden by others of the same name in earlier
  directories. Passing a true value for C<$quiet> will inhibit the warning.
  
  =head3 C<installed_drivers>
  
    %drivers = DBI->installed_drivers();
  
  Returns a list of driver name and driver handle pairs for all drivers
  'installed' (loaded) into the current process.  The driver name does not
  include the 'DBD::' prefix.
  
  To get a list of all drivers available in your perl installation you can use
  L</available_drivers>.
  
  Added in DBI 1.49.
  
  =head3 C<installed_versions>
  
    DBI->installed_versions;
    @ary  = DBI->installed_versions;
    %hash = DBI->installed_versions;
  
  Calls available_drivers() and attempts to load each of them in turn
  using install_driver().  For each load that succeeds the driver
  name and version number are added to a hash. When running under
  L<DBI::PurePerl> drivers which appear not be pure-perl are ignored.
  
  When called in array context the list of successfully loaded drivers
  is returned (without the 'DBD::' prefix).
  
  When called in scalar context a reference to the hash is returned
  and the hash will also contain other entries for the C<DBI> version,
  C<OS> name, etc.
  
  When called in a void context the installed_versions() method will
  print out a formatted list of the hash contents, one per line.
  
  Due to the potentially high memory cost and unknown risks of loading
  in an unknown number of drivers that just happen to be installed
  on the system, this method is not recommended for general use.
  Use available_drivers() instead.
  
  The installed_versions() method is primarily intended as a quick
  way to see from the command line what's installed. For example:
  
    perl -MDBI -e 'DBI->installed_versions'
  
  The installed_versions() method was added in DBI 1.38.
  
  =head3 C<data_sources>
  
    @ary = DBI->data_sources($driver);
    @ary = DBI->data_sources($driver, \%attr);
  
  Returns a list of data sources (databases) available via the named
  driver.  If C<$driver> is empty or C<undef>, then the value of the
  C<DBI_DRIVER> environment variable is used.
  
  The driver will be loaded if it hasn't been already. Note that if the
  driver loading fails then data_sources() I<dies> with an error message
  that includes the string "C<install_driver>" and the underlying problem.
  
  Data sources are returned in a form suitable for passing to the
  L</connect> method (that is, they will include the "C<dbi:$driver:>" prefix).
  
  Note that many drivers have no way of knowing what data sources might
  be available for it. These drivers return an empty or incomplete list
  or may require driver-specific attributes.
  
  There is also a data_sources() method defined for database handles.
  
  
  =head3 C<trace>
  
    DBI->trace($trace_setting)
    DBI->trace($trace_setting, $trace_filename)
    DBI->trace($trace_setting, $trace_filehandle)
    $trace_setting = DBI->trace;
  
  The C<DBI-E<gt>trace> method sets the I<global default> trace
  settings and returns the I<previous> trace settings. It can also
  be used to change where the trace output is sent.
  
  There's a similar method, C<$h-E<gt>trace>, which sets the trace
  settings for the specific handle it's called on.
  
  See the L</TRACING> section for full details about the DBI's powerful
  tracing facilities.
  
  
  =head3 C<visit_handles>
  
    DBI->visit_handles( $coderef );
    DBI->visit_handles( $coderef, $info );
  
  Where $coderef is a reference to a subroutine and $info is an arbitrary value
  which, if undefined, defaults to a reference to an empty hash. Returns $info.
  
  For each installed driver handle, if any, $coderef is invoked as:
  
    $coderef->($driver_handle, $info);
  
  If the execution of $coderef returns a true value then L</visit_child_handles>
  is called on that child handle and passed the returned value as $info.
  
  For example:
  
    my $info = $dbh->{Driver}->visit_child_handles(sub {
        my ($h, $info) = @_;
        ++$info->{ $h->{Type} }; # count types of handles (dr/db/st)
        return $info; # visit kids
    });
  
  See also L</visit_child_handles>.
  
  =head2 DBI Utility Functions
  
  In addition to the DBI methods listed in the previous section,
  the DBI package also provides several utility functions.
  
  These can be imported into your code by listing them in
  the C<use> statement. For example:
  
    use DBI qw(neat data_diff);
  
  Alternatively, all these utility functions (except hash) can be
  imported using the C<:utils> import tag. For example:
  
    use DBI qw(:utils);
  
  =head3 C<data_string_desc>
  
    $description = data_string_desc($string);
  
  Returns an informal description of the string. For example:
  
    UTF8 off, ASCII, 42 characters 42 bytes
    UTF8 off, non-ASCII, 42 characters 42 bytes
    UTF8 on, non-ASCII, 4 characters 6 bytes
    UTF8 on but INVALID encoding, non-ASCII, 4 characters 6 bytes
    UTF8 off, undef
  
  The initial C<UTF8> on/off refers to Perl's internal SvUTF8 flag.
  If $string has the SvUTF8 flag set but the sequence of bytes it
  contains are not a valid UTF-8 encoding then data_string_desc()
  will report C<UTF8 on but INVALID encoding>.
  
  The C<ASCII> vs C<non-ASCII> portion shows C<ASCII> if I<all> the
  characters in the string are ASCII (have code points <= 127).
  
  The data_string_desc() function was added in DBI 1.46.
  
  =head3 C<data_string_diff>
  
    $diff = data_string_diff($a, $b);
  
  Returns an informal description of the first character difference
  between the strings. If both $a and $b contain the same sequence
  of characters then data_string_diff() returns an empty string.
  For example:
  
   Params a & b     Result
   ------------     ------
   'aaa', 'aaa'     ''
   'aaa', 'abc'     'Strings differ at index 2: a[2]=a, b[2]=b'
   'aaa', undef     'String b is undef, string a has 3 characters'
   'aaa', 'aa'      'String b truncated after 2 characters'
  
  Unicode characters are reported in C<\x{XXXX}> format. Unicode
  code points in the range U+0800 to U+08FF are unassigned and most
  likely to occur due to double-encoding. Characters in this range
  are reported as C<\x{08XX}='C'> where C<C> is the corresponding
  latin-1 character.
  
  The data_string_diff() function only considers logical I<characters>
  and not the underlying encoding. See L</data_diff> for an alternative.
  
  The data_string_diff() function was added in DBI 1.46.
  
  =head3 C<data_diff>
  
    $diff = data_diff($a, $b);
    $diff = data_diff($a, $b, $logical);
  
  Returns an informal description of the difference between two strings.
  It calls L</data_string_desc> and L</data_string_diff>
  and returns the combined results as a multi-line string.
  
  For example, C<data_diff("abc", "ab\x{263a}")> will return:
  
    a: UTF8 off, ASCII, 3 characters 3 bytes
    b: UTF8 on, non-ASCII, 3 characters 5 bytes
    Strings differ at index 2: a[2]=c, b[2]=\x{263A}
  
  If $a and $b are identical in both the characters they contain I<and>
  their physical encoding then data_diff() returns an empty string.
  If $logical is true then physical encoding differences are ignored
  (but are still reported if there is a difference in the characters).
  
  The data_diff() function was added in DBI 1.46.
  
  =head3 C<neat>
  
    $str = neat($value);
    $str = neat($value, $maxlen);
  
  Return a string containing a neat (and tidy) representation of the
  supplied value.
  
  Strings will be quoted, although internal quotes will I<not> be escaped.
  Values known to be numeric will be unquoted. Undefined (NULL) values
  will be shown as C<undef> (without quotes).
  
  If the string is flagged internally as utf8 then double quotes will
  be used, otherwise single quotes are used and unprintable characters
  will be replaced by dot (.).
  
  For result strings longer than C<$maxlen> the result string will be
  truncated to C<$maxlen-4> and "C<...'>" will be appended.  If C<$maxlen> is 0
  or C<undef>, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400.
  
  This function is designed to format values for human consumption.
  It is used internally by the DBI for L</trace> output. It should
  typically I<not> be used for formatting values for database use.
  (See also L</quote>.)
  
  =head3 C<neat_list>
  
    $str = neat_list(\@listref, $maxlen, $field_sep);
  
  Calls C<neat> on each element of the list and returns a string
  containing the results joined with C<$field_sep>. C<$field_sep> defaults
  to C<", ">.
  
  =head3 C<looks_like_number>
  
    @bool = looks_like_number(@array);
  
  Returns true for each element that looks like a number.
  Returns false for each element that does not look like a number.
  Returns C<undef> for each element that is undefined or empty.
  
  =head3 C<hash>
  
    $hash_value = DBI::hash($buffer, $type);
  
  Return a 32-bit integer 'hash' value corresponding to the contents of $buffer.
  The $type parameter selects which kind of hash algorithm should be used.
  
  For the technically curious, type 0 (which is the default if $type
  isn't specified) is based on the Perl 5.1 hash except that the value
  is forced to be negative (for obscure historical reasons).
  Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See
  L<http://www.isthe.com/chongo/tech/comp/fnv/> for more information.
  Both types are implemented in C and are very fast.
  
  This function doesn't have much to do with databases, except that
  it can be handy to store hash values in a database.
  
  =head3 C<sql_type_cast>
  
    $sts = DBI->sql_type_cast($sv, $sql_type, $flags);
  
  sql_type_cast attempts to cast C<$sv> to the SQL type (see L<DBI
  Constants>) specified in C<$sql_type>. At present only the SQL types
  C<SQL_INTEGER>, C<SQL_DOUBLE> and C<SQL_NUMERIC> are supported.
  
  For C<SQL_INTEGER> the effect is similar to using the value in an expression
  that requires an integer. It gives the perl scalar an 'integer aspect'.
  (Technically the value gains an IV, or possibly a UV or NV if the value is too
  large for an IV.)
  
  For C<SQL_DOUBLE> the effect is similar to using the value in an expression
  that requires a general numeric value. It gives the perl scalar a 'numeric
  aspect'.  (Technically the value gains an NV.)
  
  C<SQL_NUMERIC> is similar to C<SQL_INTEGER> or C<SQL_DOUBLE> but more
  general and more cautious.  It will look at the string first and if it
  looks like an integer (that will fit in an IV or UV) it will act like
  C<SQL_INTEGER>, if it looks like a floating point value it will act
  like C<SQL_DOUBLE>, if it looks like neither then it will do nothing -
  and thereby avoid the warnings that would be generated by
  C<SQL_INTEGER> and C<SQL_DOUBLE> when given non-numeric data.
  
  C<$flags> may be:
  
  =over 4
  
  =item C<DBIstcf_DISCARD_STRING>
  
  If this flag is specified then when the driver successfully casts the
  bound perl scalar to a non-string type then the string portion of the
  scalar will be discarded.
  
  =item C<DBIstcf_STRICT>
  
  If C<$sv> cannot be cast to the requested C<$sql_type> then by default
  it is left untouched and no error is generated. If you specify
  C<DBIstcf_STRICT> and the cast fails, this will generate an error.
  
  =back
  
  The returned C<$sts> value is:
  
    -2 sql_type is not handled
    -1 sv is undef so unchanged
     0 sv could not be cast cleanly and DBIstcf_STRICT was used
     1 sv could not be case and DBIstcf_STRICT was not used
     2 sv was cast successfully
  
  This method is exported by the :utils tag and was introduced in DBI
  1.611.
  
  =head2 DBI Dynamic Attributes
  
  Dynamic attributes are always associated with the I<last handle used>
  (that handle is represented by C<$h> in the descriptions below).
  
  Where an attribute is equivalent to a method call, then refer to
  the method call for all related documentation.
  
  Warning: these attributes are provided as a convenience but they
  do have limitations. Specifically, they have a short lifespan:
  because they are associated with
  the last handle used, they should only be used I<immediately> after
  calling the method that "sets" them.
  If in any doubt, use the corresponding method call.
  
  =head3 C<$DBI::err>
  
  Equivalent to C<$h-E<gt>err>.
  
  =head3 C<$DBI::errstr>
  
  Equivalent to C<$h-E<gt>errstr>.
  
  =head3 C<$DBI::state>
  
  Equivalent to C<$h-E<gt>state>.
  
  =head3 C<$DBI::rows>
  
  Equivalent to C<$h-E<gt>rows>. Please refer to the documentation
  for the L</rows> method.
  
  =head3 C<$DBI::lasth>
  
  Returns the DBI object handle used for the most recent DBI method call.
  If the last DBI method call was a DESTROY then $DBI::lasth will return
  the handle of the parent of the destroyed handle, if there is one.
  
  
  =head1 METHODS COMMON TO ALL HANDLES
  
  The following methods can be used by all types of DBI handles.
  
  =head3 C<err>
  
    $rv = $h->err;
  
  Returns the I<native> database engine error code from the last driver
  method called. The code is typically an integer but you should not
  assume that.
  
  The DBI resets $h->err to undef before almost all DBI method calls, so the
  value only has a short lifespan. Also, for most drivers, the statement
  handles share the same error variable as the parent database handle,
  so calling a method on one handle may reset the error on the
  related handles.
  
  (Methods which don't reset err before being called include err() and errstr(),
  obviously, state(), rows(), func(), trace(), trace_msg(), ping(), and the
  tied hash attribute FETCH() and STORE() methods.)
  
  If you need to test for specific error conditions I<and> have your program be
  portable to different database engines, then you'll need to determine what the
  corresponding error codes are for all those engines and test for all of them.
  
  The DBI uses the value of $DBI::stderr as the C<err> value for internal errors.
  Drivers should also do likewise.  The default value for $DBI::stderr is 2000000000.
  
  A driver may return C<0> from err() to indicate a warning condition
  after a method call. Similarly, a driver may return an empty string
  to indicate a 'success with information' condition. In both these
  cases the value is false but not undef. The errstr() and state()
  methods may be used to retrieve extra information in these cases.
  
  See L</set_err> for more information.
  
  =head3 C<errstr>
  
    $str = $h->errstr;
  
  Returns the native database engine error message from the last DBI
  method called. This has the same lifespan issues as the L</err> method
  described above.
  
  The returned string may contain multiple messages separated by
  newline characters.
  
  The errstr() method should not be used to test for errors, use err()
  for that, because drivers may return 'success with information' or
  warning messages via errstr() for methods that have not 'failed'.
  
  See L</set_err> for more information.
  
  =head3 C<state>
  
    $str = $h->state;
  
  Returns a state code in the standard SQLSTATE five character format.
  Note that the specific success code C<00000> is translated to any empty string
  (false). If the driver does not support SQLSTATE (and most don't),
  then state() will return C<S1000> (General Error) for all errors.
  
  The driver is free to return any value via C<state>, e.g., warning
  codes, even if it has not declared an error by returning a true value
  via the L</err> method described above.
  
  The state() method should not be used to test for errors, use err()
  for that, because drivers may return a 'success with information' or
  warning state code via state() for methods that have not 'failed'.
  
  =head3 C<set_err>
  
    $rv = $h->set_err($err, $errstr);
    $rv = $h->set_err($err, $errstr, $state);
    $rv = $h->set_err($err, $errstr, $state, $method);
    $rv = $h->set_err($err, $errstr, $state, $method, $rv);
  
  Set the C<err>, C<errstr>, and C<state> values for the handle.
  This method is typically only used by DBI drivers and DBI subclasses.
  
  If the L</HandleSetErr> attribute holds a reference to a subroutine
  it is called first. The subroutine can alter the $err, $errstr, $state,
  and $method values. See L</HandleSetErr> for full details.
  If the subroutine returns a true value then the handle C<err>,
  C<errstr>, and C<state> values are not altered and set_err() returns
  an empty list (it normally returns $rv which defaults to undef, see below).
  
  Setting C<err> to a I<true> value indicates an error and will trigger
  the normal DBI error handling mechanisms, such as C<RaiseError> and
  C<HandleError>, if they are enabled, when execution returns from
  the DBI back to the application.
  
  Setting C<err> to C<""> indicates an 'information' state, and setting
  it to C<"0"> indicates a 'warning' state. Setting C<err> to C<undef>
  also sets C<errstr> to undef, and C<state> to C<"">, irrespective
  of the values of the $errstr and $state parameters.
  
  The $method parameter provides an alternate method name for the
  C<RaiseError>/C<PrintError>/C<PrintWarn> error string instead of
  the fairly unhelpful 'C<set_err>'.
  
  The C<set_err> method normally returns undef.  The $rv parameter
  provides an alternate return value.
  
  Some special rules apply if the C<err> or C<errstr>
  values for the handle are I<already> set...
  
  If C<errstr> is true then: "C< [err was %s now %s]>" is appended if $err is
  true and C<err> is already true and the new err value differs from the original
  one. Similarly "C< [state was %s now %s]>" is appended if $state is true and C<state> is
  already true and the new state value differs from the original one. Finally
  "C<\n>" and the new $errstr are appended if $errstr differs from the existing
  errstr value. Obviously the C<%s>'s above are replaced by the corresponding values.
  
  The handle C<err> value is set to $err if: $err is true; or handle
  C<err> value is undef; or $err is defined and the length is greater
  than the handle C<err> length. The effect is that an 'information'
  state only overrides undef; a 'warning' overrides undef or 'information',
  and an 'error' state overrides anything.
  
  The handle C<state> value is set to $state if $state is true and
  the handle C<err> value was set (by the rules above).
  
  Support for warning and information states was added in DBI 1.41.
  
  =head3 C<trace>
  
    $h->trace($trace_settings);
    $h->trace($trace_settings, $trace_filename);
    $trace_settings = $h->trace;
  
  The trace() method is used to alter the trace settings for a handle
  (and any future children of that handle).  It can also be used to
  change where the trace output is sent.
  
  There's a similar method, C<DBI-E<gt>trace>, which sets the global
  default trace settings.
  
  See the L</TRACING> section for full details about the DBI's powerful
  tracing facilities.
  
  =head3 C<trace_msg>
  
    $h->trace_msg($message_text);
    $h->trace_msg($message_text, $min_level);
  
  Writes C<$message_text> to the trace file if the trace level is
  greater than or equal to $min_level (which defaults to 1).
  Can also be called as C<DBI-E<gt>trace_msg($msg)>.
  
  See L</TRACING> for more details.
  
  =head3 C<func>
  
    $h->func(@func_arguments, $func_name) or die ...;
  
  The C<func> method can be used to call private non-standard and
  non-portable methods implemented by the driver. Note that the function
  name is given as the I<last> argument.
  
  It's also important to note that the func() method does not clear
  a previous error ($DBI::err etc.) and it does not trigger automatic
  error detection (RaiseError etc.) so you must check the return
  status and/or $h->err to detect errors.
  
  (This method is not directly related to calling stored procedures.
  Calling stored procedures is currently not defined by the DBI.
  Some drivers, such as DBD::Oracle, support it in non-portable ways.
  See driver documentation for more details.)
  
  See also install_method() in L<DBI::DBD> for how you can avoid needing to
  use func() and gain direct access to driver-private methods.
  
  =head3 C<can>
  
    $is_implemented = $h->can($method_name);
  
  Returns true if $method_name is implemented by the driver or a
  default method is provided by the DBI.
  It returns false where a driver hasn't implemented a method and the
  default method is provided by the DBI is just an empty stub.
  
  =head3 C<parse_trace_flags>
  
    $trace_settings_integer = $h->parse_trace_flags($trace_settings);
  
  Parses a string containing trace settings and returns the corresponding
  integer value used internally by the DBI and drivers.
  
  The $trace_settings argument is a string containing a trace level
  between 0 and 15 and/or trace flag names separated by vertical bar
  ("C<|>") or comma ("C<,>") characters. For example: C<"SQL|3|foo">.
  
  It uses the parse_trace_flag() method, described below, to process
  the individual trace flag names.
  
  The parse_trace_flags() method was added in DBI 1.42.
  
  =head3 C<parse_trace_flag>
  
    $bit_flag = $h->parse_trace_flag($trace_flag_name);
  
  Returns the bit flag corresponding to the trace flag name in
  $trace_flag_name.  Drivers are expected to override this method and
  check if $trace_flag_name is a driver specific trace flags and, if
  not, then call the DBI's default parse_trace_flag().
  
  The parse_trace_flag() method was added in DBI 1.42.
  
  =head3 C<private_attribute_info>
  
    $hash_ref = $h->private_attribute_info();
  
  Returns a reference to a hash whose keys are the names of driver-private
  attributes available for the kind of handle (driver, database, statement)
  that the method was called on.
  
  For example, the return value when called with a DBD::Sybase $dbh could look like this:
  
    {
        syb_dynamic_supported => undef,
        syb_oc_version => undef,
        syb_server_version => undef,
        syb_server_version_string => undef,
    }
  
  and when called with a DBD::Sybase $sth they could look like this:
  
    {
        syb_types => undef,
        syb_proc_status => undef,
        syb_result_type => undef,
    }
  
  The values should be undef. Meanings may be assigned to particular values in future.
  
  =head3 C<swap_inner_handle>
  
    $rc = $h1->swap_inner_handle( $h2 );
    $rc = $h1->swap_inner_handle( $h2, $allow_reparent );
  
  Brain transplants for handles. You don't need to know about this
  unless you want to become a handle surgeon.
  
  A DBI handle is a reference to a tied hash. A tied hash has an
  I<inner> hash that actually holds the contents.  The swap_inner_handle()
  method swaps the inner hashes between two handles. The $h1 and $h2
  handles still point to the same tied hashes, but what those hashes
  are tied to has been swapped.  In effect $h1 I<becomes> $h2 and
  vice-versa. This is powerful stuff, expect problems. Use with care.
  
  As a small safety measure, the two handles, $h1 and $h2, have to
  share the same parent unless $allow_reparent is true.
  
  The swap_inner_handle() method was added in DBI 1.44.
  
  Here's a quick kind of 'diagram' as a worked example to help think about what's
  happening:
  
      Original state:
              dbh1o -> dbh1i
              sthAo -> sthAi(dbh1i)
              dbh2o -> dbh2i
  
      swap_inner_handle dbh1o with dbh2o:
              dbh2o -> dbh1i
              sthAo -> sthAi(dbh1i)
              dbh1o -> dbh2i
  
      create new sth from dbh1o:
              dbh2o -> dbh1i
              sthAo -> sthAi(dbh1i)
              dbh1o -> dbh2i
              sthBo -> sthBi(dbh2i)
  
      swap_inner_handle sthAo with sthBo:
              dbh2o -> dbh1i
              sthBo -> sthAi(dbh1i)
              dbh1o -> dbh2i
              sthAo -> sthBi(dbh2i)
  
  =head3 C<visit_child_handles>
  
    $h->visit_child_handles( $coderef );
    $h->visit_child_handles( $coderef, $info );
  
  Where $coderef is a reference to a subroutine and $info is an arbitrary value
  which, if undefined, defaults to a reference to an empty hash. Returns $info.
  
  For each child handle of $h, if any, $coderef is invoked as:
  
    $coderef->($child_handle, $info);
  
  If the execution of $coderef returns a true value then C<visit_child_handles>
  is called on that child handle and passed the returned value as $info.
  
  For example:
  
    # count database connections with names (DSN) matching a pattern
    my $connections = 0;
    $dbh->{Driver}->visit_child_handles(sub {
        my ($h, $info) = @_;
        ++$connections if $h->{Name} =~ /foo/;
        return 0; # don't visit kids
    })
  
  See also L</visit_handles>.
  
  =head1 ATTRIBUTES COMMON TO ALL HANDLES
  
  These attributes are common to all types of DBI handles.
  
  Some attributes are inherited by child handles. That is, the value
  of an inherited attribute in a newly created statement handle is the
  same as the value in the parent database handle. Changes to attributes
  in the new statement handle do not affect the parent database handle
  and changes to the database handle do not affect existing statement
  handles, only future ones.
  
  Attempting to set or get the value of an unknown attribute generates a warning,
  except for private driver specific attributes (which all have names
  starting with a lowercase letter).
  
  Example:
  
    $h->{AttributeName} = ...;	# set/write
    ... = $h->{AttributeName};	# get/read
  
  =head3 C<Warn> (boolean, inherited)
  
  The C<Warn> attribute enables useful warnings for certain bad
  practices. It is enabled by default and should only be disabled in
  rare circumstances.  Since warnings are generated using the Perl
  C<warn> function, they can be intercepted using the Perl C<$SIG{__WARN__}>
  hook.
  
  The C<Warn> attribute is not related to the C<PrintWarn> attribute.
  
  =head3 C<Active> (boolean, read-only)
  
  The C<Active> attribute is true if the handle object is "active". This is rarely used in
  applications. The exact meaning of active is somewhat vague at the
  moment. For a database handle it typically means that the handle is
  connected to a database (C<$dbh-E<gt>disconnect> sets C<Active> off).  For
  a statement handle it typically means that the handle is a C<SELECT>
  that may have more data to fetch. (Fetching all the data or calling C<$sth-E<gt>finish>
  sets C<Active> off.)
  
  =head3 C<Executed> (boolean)
  
  The C<Executed> attribute is true if the handle object has been "executed".
  Currently only the $dbh do() method and the $sth execute(), execute_array(),
  and execute_for_fetch() methods set the C<Executed> attribute.
  
  When it's set on a handle it is also set on the parent handle at the
  same time. So calling execute() on a $sth also sets the C<Executed>
  attribute on the parent $dbh.
  
  The C<Executed> attribute for a database handle is cleared by the commit() and
  rollback() methods (even if they fail). The C<Executed> attribute of a
  statement handle is not cleared by the DBI under any circumstances and so acts
  as a permanent record of whether the statement handle was ever used.
  
  The C<Executed> attribute was added in DBI 1.41.
  
  =head3 C<Kids> (integer, read-only)
  
  For a driver handle, C<Kids> is the number of currently existing database
  handles that were created from that driver handle.  For a database
  handle, C<Kids> is the number of currently existing statement handles that
  were created from that database handle.
  For a statement handle, the value is zero.
  
  =head3 C<ActiveKids> (integer, read-only)
  
  Like C<Kids>, but only counting those that are C<Active> (as above).
  
  =head3 C<CachedKids> (hash ref)
  
  For a database handle, C<CachedKids> returns a reference to the cache (hash) of
  statement handles created by the L</prepare_cached> method.  For a
  driver handle, returns a reference to the cache (hash) of
  database handles created by the L</connect_cached> method.
  
  =head3 C<Type> (scalar, read-only)
  
  The C<Type> attribute identifies the type of a DBI handle.  Returns
  "dr" for driver handles, "db" for database handles and "st" for
  statement handles.
  
  =head3 C<ChildHandles> (array ref)
  
  The ChildHandles attribute contains a reference to an array of all the
  handles created by this handle which are still accessible.  The
  contents of the array are weak-refs and will become undef when the
  handle goes out of scope.
  
  C<ChildHandles> returns undef if your perl version does not support weak
  references (check the L<Scalar::Util|Scalar::Util> module).  The referenced
  array returned should be treated as read-only.
  
  For example, to enumerate all driver handles, database handles and
  statement handles:
  
      sub show_child_handles {
          my ($h, $level) = @_;
          printf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h;
          show_child_handles($_, $level + 1)
              for (grep { defined } @{$h->{ChildHandles}});
      }
  
      my %drivers = DBI->installed_drivers();
      show_child_handles($_, 0) for (values %drivers);
  
  =head3 C<CompatMode> (boolean, inherited)
  
  The C<CompatMode> attribute is used by emulation layers (such as
  Oraperl) to enable compatible behaviour in the underlying driver
  (e.g., DBD::Oracle) for this handle. Not normally set by application code.
  
  It also has the effect of disabling the 'quick FETCH' of attribute
  values from the handles attribute cache. So all attribute values
  are handled by the drivers own FETCH method. This makes them slightly
  slower but is useful for special-purpose drivers like DBD::Multiplex.
  
  =head3 C<InactiveDestroy> (boolean)
  
  The default value, false, means a handle will be fully destroyed
  as normal when the last reference to it is removed, just as you'd expect.
  
  If set true then the handle will be treated by the DESTROY as if it was no
  longer Active, and so the I<database engine> related effects of DESTROYing a
  handle will be skipped.
  
  Think of the name as meaning 'treat the handle as not-Active in the DESTROY
  method'.
  
  For a database handle, this attribute does not disable an I<explicit>
  call to the disconnect method, only the implicit call from DESTROY
  that happens if the handle is still marked as C<Active>.
  
  This attribute is specifically designed for use in Unix applications
  that "fork" child processes. Either the parent or the child process,
  but not both, should set C<InactiveDestroy> true on all their shared handles.
  (Note that some databases, including Oracle, don't support passing a
  database connection across a fork.)
  
  To help tracing applications using fork the process id is shown in
  the trace log whenever a DBI or handle trace() method is called.
  The process id also shown for I<every> method call if the DBI trace
  level (not handle trace level) is set high enough to show the trace
  from the DBI's method dispatcher, e.g. >= 9.
  
  =head3 C<PrintWarn> (boolean, inherited)
  
  The C<PrintWarn> attribute controls the printing of warnings recorded
  by the driver.  When set to a true value the DBI will check method
  calls to see if a warning condition has been set. If so, the DBI
  will effectively do a C<warn("$class $method warning: $DBI::errstr")>
  where C<$class> is the driver class and C<$method> is the name of
  the method which failed. E.g.,
  
    DBD::Oracle::db execute warning: ... warning text here ...
  
  By default, C<DBI-E<gt>connect> sets C<PrintWarn> "on" if $^W is true,
  i.e., perl is running with warnings enabled.
  
  If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}>
  handler or modules like CGI::Carp and CGI::ErrorWrap.
  
  See also L</set_err> for how warnings are recorded and L</HandleSetErr>
  for how to influence it.
  
  Fetching the full details of warnings can require an extra round-trip
  to the database server for some drivers. In which case the driver
  may opt to only fetch the full details of warnings if the C<PrintWarn>
  attribute is true. If C<PrintWarn> is false then these drivers should
  still indicate the fact that there were warnings by setting the
  warning string to, for example: "3 warnings".
  
  =head3 C<PrintError> (boolean, inherited)
  
  The C<PrintError> attribute can be used to force errors to generate warnings (using
  C<warn>) in addition to returning error codes in the normal way.  When set
  "on", any method which results in an error occurring will cause the DBI to
  effectively do a C<warn("$class $method failed: $DBI::errstr")> where C<$class>
  is the driver class and C<$method> is the name of the method which failed. E.g.,
  
    DBD::Oracle::db prepare failed: ... error text here ...
  
  By default, C<DBI-E<gt>connect> sets C<PrintError> "on".
  
  If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}>
  handler or modules like CGI::Carp and CGI::ErrorWrap.
  
  =head3 C<RaiseError> (boolean, inherited)
  
  The C<RaiseError> attribute can be used to force errors to raise exceptions rather
  than simply return error codes in the normal way. It is "off" by default.
  When set "on", any method which results in an error will cause
  the DBI to effectively do a C<die("$class $method failed: $DBI::errstr")>,
  where C<$class> is the driver class and C<$method> is the name of the method
  that failed. E.g.,
  
    DBD::Oracle::db prepare failed: ... error text here ...
  
  If you turn C<RaiseError> on then you'd normally turn C<PrintError> off.
  If C<PrintError> is also on, then the C<PrintError> is done first (naturally).
  
  Typically C<RaiseError> is used in conjunction with C<eval { ... }>
  to catch the exception that's been thrown and followed by an
  C<if ($@) { ... }> block to handle the caught exception.
  For example:
  
    eval {
      ...
      $sth->execute();
      ...
    };
    if ($@) {
      # $sth->err and $DBI::err will be true if error was from DBI
      warn $@; # print the error
      ... # do whatever you need to deal with the error
    }
  
  In that eval block the $DBI::lasth variable can be useful for
  diagnosis and reporting if you can't be sure which handle triggered
  the error.  For example, $DBI::lasth->{Type} and $DBI::lasth->{Statement}.
  
  See also L</Transactions>.
  
  If you want to temporarily turn C<RaiseError> off (inside a library function
  that is likely to fail, for example), the recommended way is like this:
  
    {
      local $h->{RaiseError};  # localize and turn off for this block
      ...
    }
  
  The original value will automatically and reliably be restored by Perl,
  regardless of how the block is exited.
  The same logic applies to other attributes, including C<PrintError>.
  
  =head3 C<HandleError> (code ref, inherited)
  
  The C<HandleError> attribute can be used to provide your own alternative behaviour
  in case of errors. If set to a reference to a subroutine then that
  subroutine is called when an error is detected (at the same point that
  C<RaiseError> and C<PrintError> are handled).
  
  The subroutine is called with three parameters: the error message
  string that C<RaiseError> and C<PrintError> would use,
  the DBI handle being used, and the first value being returned by
  the method that failed (typically undef).
  
  If the subroutine returns a false value then the C<RaiseError>
  and/or C<PrintError> attributes are checked and acted upon as normal.
  
  For example, to C<die> with a full stack trace for any error:
  
    use Carp;
    $h->{HandleError} = sub { confess(shift) };
  
  Or to turn errors into exceptions:
  
    use Exception; # or your own favourite exception module
    $h->{HandleError} = sub { Exception->new('DBI')->raise($_[0]) };
  
  It is possible to 'stack' multiple HandleError handlers by using
  closures:
  
    sub your_subroutine {
      my $previous_handler = $h->{HandleError};
      $h->{HandleError} = sub {
        return 1 if $previous_handler and &$previous_handler(@_);
        ... your code here ...
      };
    }
  
  Using a C<my> inside a subroutine to store the previous C<HandleError>
  value is important.  See L<perlsub> and L<perlref> for more information
  about I<closures>.
  
  It is possible for C<HandleError> to alter the error message that
  will be used by C<RaiseError> and C<PrintError> if it returns false.
  It can do that by altering the value of $_[0]. This example appends
  a stack trace to all errors and, unlike the previous example using
  Carp::confess, this will work C<PrintError> as well as C<RaiseError>:
  
    $h->{HandleError} = sub { $_[0]=Carp::longmess($_[0]); 0; };
  
  It is also possible for C<HandleError> to hide an error, to a limited
  degree, by using L</set_err> to reset $DBI::err and $DBI::errstr,
  and altering the return value of the failed method. For example:
  
    $h->{HandleError} = sub {
      return 0 unless $_[0] =~ /^\S+ fetchrow_arrayref failed:/;
      return 0 unless $_[1]->err == 1234; # the error to 'hide'
      $h->set_err(undef,undef);	# turn off the error
      $_[2] = [ ... ];	# supply alternative return value
      return 1;
    };
  
  This only works for methods which return a single value and is hard
  to make reliable (avoiding infinite loops, for example) and so isn't
  recommended for general use!  If you find a I<good> use for it then
  please let me know.
  
  =head3 C<HandleSetErr> (code ref, inherited)
  
  The C<HandleSetErr> attribute can be used to intercept
  the setting of handle C<err>, C<errstr>, and C<state> values.
  If set to a reference to a subroutine then that subroutine is called
  whenever set_err() is called, typically by the driver or a subclass.
  
  The subroutine is called with five arguments, the first five that
  were passed to set_err(): the handle, the C<err>, C<errstr>, and
  C<state> values being set, and the method name. These can be altered
  by changing the values in the @_ array. The return value affects
  set_err() behaviour, see L</set_err> for details.
  
  It is possible to 'stack' multiple HandleSetErr handlers by using
  closures. See L</HandleError> for an example.
  
  The C<HandleSetErr> and C<HandleError> subroutines differ in subtle
  but significant ways. HandleError is only invoked at the point where
  the DBI is about to return to the application with C<err> set true.
  It's not invoked by the failure of a method that's been called by
  another DBI method.  HandleSetErr, on the other hand, is called
  whenever set_err() is called with a defined C<err> value, even if false.
  So it's not just for errors, despite the name, but also warn and info states.
  The set_err() method, and thus HandleSetErr, may be called multiple
  times within a method and is usually invoked from deep within driver code.
  
  In theory a driver can use the return value from HandleSetErr via
  set_err() to decide whether to continue or not. If set_err() returns
  an empty list, indicating that the HandleSetErr code has 'handled'
  the 'error', the driver could then continue instead of failing (if
  that's a reasonable thing to do).  This isn't excepted to be
  common and any such cases should be clearly marked in the driver
  documentation and discussed on the dbi-dev mailing list.
  
  The C<HandleSetErr> attribute was added in DBI 1.41.
  
  =head3 C<ErrCount> (unsigned integer)
  
  The C<ErrCount> attribute is incremented whenever the set_err()
  method records an error. It isn't incremented by warnings or
  information states. It is not reset by the DBI at any time.
  
  The C<ErrCount> attribute was added in DBI 1.41. Older drivers may
  not have been updated to use set_err() to record errors and so this
  attribute may not be incremented when using them.
  
  
  =head3 C<ShowErrorStatement> (boolean, inherited)
  
  The C<ShowErrorStatement> attribute can be used to cause the relevant
  Statement text to be appended to the error messages generated by
  the C<RaiseError>, C<PrintError>, and C<PrintWarn> attributes.
  Only applies to errors on statement handles
  plus the prepare(), do(), and the various C<select*()> database handle methods.
  (The exact format of the appended text is subject to change.)
  
  If C<$h-E<gt>{ParamValues}> returns a hash reference of parameter
  (placeholder) values then those are formatted and appended to the
  end of the Statement text in the error message.
  
  =head3 C<TraceLevel> (integer, inherited)
  
  The C<TraceLevel> attribute can be used as an alternative to the
  L</trace> method to set the DBI trace level and trace flags for a
  specific handle.  See L</TRACING> for more details.
  
  The C<TraceLevel> attribute is especially useful combined with
  C<local> to alter the trace settings for just a single block of code.
  
  =head3 C<FetchHashKeyName> (string, inherited)
  
  The C<FetchHashKeyName> attribute is used to specify whether the fetchrow_hashref()
  method should perform case conversion on the field names used for
  the hash keys. For historical reasons it defaults to 'C<NAME>' but
  it is recommended to set it to 'C<NAME_lc>' (convert to lower case)
  or 'C<NAME_uc>' (convert to upper case) according to your preference.
  It can only be set for driver and database handles.  For statement
  handles the value is frozen when prepare() is called.
  
  
  =head3 C<ChopBlanks> (boolean, inherited)
  
  The C<ChopBlanks> attribute can be used to control the trimming of trailing space
  characters from fixed width character (CHAR) fields. No other field
  types are affected, even where field values have trailing spaces.
  
  The default is false (although it is possible that the default may change).
  Applications that need specific behaviour should set the attribute as
  needed.
  
  Drivers are not required to support this attribute, but any driver which
  does not support it must arrange to return C<undef> as the attribute value.
  
  
  =head3 C<LongReadLen> (unsigned integer, inherited)
  
  The C<LongReadLen> attribute may be used to control the maximum
  length of 'long' type fields (LONG, BLOB, CLOB, MEMO, etc.) which the driver will
  read from the database automatically when it fetches each row of data.
  
  The C<LongReadLen> attribute only relates to fetching and reading
  long values; it is not involved in inserting or updating them.
  
  A value of 0 means not to automatically fetch any long data.
  Drivers may return undef or an empty string for long fields when
  C<LongReadLen> is 0.
  
  The default is typically 0 (zero) or 80 bytes but may vary between drivers.
  Applications fetching long fields should set this value to slightly
  larger than the longest long field value to be fetched.
  
  Some databases return some long types encoded as pairs of hex digits.
  For these types, C<LongReadLen> relates to the underlying data
  length and not the doubled-up length of the encoded string.
  
  Changing the value of C<LongReadLen> for a statement handle after it
  has been C<prepare>'d will typically have no effect, so it's common to
  set C<LongReadLen> on the C<$dbh> before calling C<prepare>.
  
  For most drivers the value used here has a direct effect on the
  memory used by the statement handle while it's active, so don't be
  too generous. If you can't be sure what value to use you could
  execute an extra select statement to determine the longest value.
  For example:
  
    $dbh->{LongReadLen} = $dbh->selectrow_array(qq{
        SELECT MAX(OCTET_LENGTH(long_column_name))
        FROM table WHERE ...
    });
    $sth = $dbh->prepare(qq{
        SELECT long_column_name, ... FROM table WHERE ...
    });
  
  You may need to take extra care if the table can be modified between
  the first select and the second being executed. You may also need to
  use a different function if OCTET_LENGTH() does not work for long
  types in your database. For example, for Sybase use DATALENGTH() and
  for Oracle use LENGTHB().
  
  See also L</LongTruncOk> for information on truncation of long types.
  
  =head3 C<LongTruncOk> (boolean, inherited)
  
  The C<LongTruncOk> attribute may be used to control the effect of
  fetching a long field value which has been truncated (typically
  because it's longer than the value of the C<LongReadLen> attribute).
  
  By default, C<LongTruncOk> is false and so fetching a long value that
  needs to be truncated will cause the fetch to fail.
  (Applications should always be sure to
  check for errors after a fetch loop in case an error, such as a divide
  by zero or long field truncation, caused the fetch to terminate
  prematurely.)
  
  If a fetch fails due to a long field truncation when C<LongTruncOk> is
  false, many drivers will allow you to continue fetching further rows.
  
  See also L</LongReadLen>.
  
  =head3 C<TaintIn> (boolean, inherited)
  
  If the C<TaintIn> attribute is set to a true value I<and> Perl is running in
  taint mode (e.g., started with the C<-T> option), then all the arguments
  to most DBI method calls are checked for being tainted. I<This may change.>
  
  The attribute defaults to off, even if Perl is in taint mode.
  See L<perlsec> for more about taint mode.  If Perl is not
  running in taint mode, this attribute has no effect.
  
  When fetching data that you trust you can turn off the TaintIn attribute,
  for that statement handle, for the duration of the fetch loop.
  
  The C<TaintIn> attribute was added in DBI 1.31.
  
  =head3 C<TaintOut> (boolean, inherited)
  
  If the C<TaintOut> attribute is set to a true value I<and> Perl is running in
  taint mode (e.g., started with the C<-T> option), then most data fetched
  from the database is considered tainted. I<This may change.>
  
  The attribute defaults to off, even if Perl is in taint mode.
  See L<perlsec> for more about taint mode.  If Perl is not
  running in taint mode, this attribute has no effect.
  
  When fetching data that you trust you can turn off the TaintOut attribute,
  for that statement handle, for the duration of the fetch loop.
  
  Currently only fetched data is tainted. It is possible that the results
  of other DBI method calls, and the value of fetched attributes, may
  also be tainted in future versions. That change may well break your
  applications unless you take great care now. If you use DBI Taint mode,
  please report your experience and any suggestions for changes.
  
  The C<TaintOut> attribute was added in DBI 1.31.
  
  =head3 C<Taint> (boolean, inherited)
  
  The C<Taint> attribute is a shortcut for L</TaintIn> and L</TaintOut> (it is also present
  for backwards compatibility).
  
  Setting this attribute sets both L</TaintIn> and L</TaintOut>, and retrieving
  it returns a true value if and only if L</TaintIn> and L</TaintOut> are
  both set to true values.
  
  =head3 C<Profile> (inherited)
  
  The C<Profile> attribute enables the collection and reporting of method call timing statistics.
  See the L<DBI::Profile> module documentation for I<much> more detail.
  
  The C<Profile> attribute was added in DBI 1.24.
  
  =head3 C<ReadOnly> (boolean, inherited)
  
  An application can set the C<ReadOnly> attribute of a handle to a true value to
  indicate that it will not be attempting to make any changes using that handle
  or any children of it.
  
  Note that the exact definition of 'read only' is rather fuzzy.
  For more details see the documentation for the driver you're using.
  
  If the driver can make the handle truly read-only then it should
  (unless doing so would have unpleasant side effect, like changing the
  consistency level from per-statement to per-session).
  Otherwise the attribute is simply advisory.
  
  A driver can set the C<ReadOnly> attribute itself to indicate that the data it
  is connected to cannot be changed for some reason.
  
  Library modules and proxy drivers can use the attribute to influence their behavior.
  For example, the DBD::Gofer driver considers the C<ReadOnly> attribute when
  making a decision about whether to retry an operation that failed.
  
  The attribute should be set to 1 or 0 (or undef). Other values are reserved.
  
  =head3 C<Callbacks> (hash ref)
  
  The DBI callback mechanism lets you intercept, and optionally replace, any
  method call on a DBI handle. At the extreme, it lets you become a puppet
  master, deceiving the application in any way you want.
  
  The C<Callbacks> attribute is a hash reference where the keys are DBI method
  names and the values are code references. For each key naming a method, the
  DBI will execute the associated code reference before executing the method.
  
  The arguments to the code reference will be the same as to the method,
  including the invocant (a database handle or statement handle). For example,
  say that to callback to some code on a call to C<prepare()>:
  
    $dbh->{Callbacks} = {
        prepare => sub {
            my ($dbh, $query, $attrs) = @_;
            print "Preparing q{$query}\n"
        },
    };
  
  The callback would then be executed when you called the C<prepare()> method:
  
    $dbh->prepare('SELECT 1');
  
  And the output of course would be:
  
    Preparing q{SELECT 1}
  
  Because callbacks are executed I<before> the methods
  they're associated with, you can modify the arguments before they're passed on
  to the method call. For example, to make sure that all calls to C<prepare()>
  are immediately prepared by L<DBD::Pg>, add a callback that makes sure that
  the C<pg_prepare_now> attribute is always set:
  
    my $dbh = DBI->connect($dsn, $username, $auth, {
        Callbacks => {
            prepare => sub {
                $_[2] ||= {};
                $_[2]->{pg_prepare_now} = 1;
                return; # must return nothing
            },
        }
    });
  
  Note that we are editing the contents of C<@_> directly. In this case we've
  created the attributes hash if it's not passed to the C<prepare> call.
  
  You can also prevent the associated method from ever executing. While a
  callback executes, C<$_> holds the method name. (This allows multiple callbacks
  to share the same code reference and still know what method was called.)
  To prevent the method from
  executing, simply C<undef $_>. For example, if you wanted to disable calls to
  C<ping()>, you could do this:
  
    $dbh->{Callbacks} = {
        ping => sub {
            # tell dispatch to not call the method:
            undef $_;
            # return this value instead:
            return "42 bells";
        }
    };
  
  As with other attributes, Callbacks can be specified on a handle or via the
  attributes to C<connect()>. Callbacks can also be applied to a statement
  methods on a statement handle. For example:
  
    $sth->{Callbacks} = {
        execute => sub {
            print "Executing ", shift->{Statement}, "\n";
        }
    };
  
  The C<Callbacks> attribute of a database handle isn't copied to any statement
  handles it creates. So setting callbacks for a statement handle requires you to
  set the C<Callbacks> attribute on the statement handle yourself, as in the
  example above, or use the special C<ChildCallbacks> key described below.
  
  B<Special Keys in Callbacks Attribute>
  
  In addition to DBI handle method names, the C<Callbacks> hash reference
  supports three additional keys.
  
  The first is the C<ChildCallbacks> key. When a statement handle is created from
  a database handle the C<ChildCallbacks> key of the database handle's
  C<Callbacks> attribute, if any, becomes the new C<Callbacks> attribute of the
  statement handle.
  This allows you to define callbacks for all statement handles created from a
  database handle. For example, if you wanted to count how many times C<execute>
  was called in your application, you could write:
  
    my $exec_count = 0;
    my $dbh = DBI->connect( $dsn, $username, $auth, {
        Callbacks => {
            ChildCallbacks => {
                execute => sub { $exec_count++; return; }
            }
        }
    });
  
    END {
        print "The execute method was called $exec_count times\n";
    }
  
  The other two special keys are C<connect_cached.new> and
  C<connect_cached.reused>. These keys define callbacks that are called when
  C<connect_cached()> is called, but allow different behaviors depending on
  whether a new handle is created or a handle is returned. The callback is
  invoked with these arguments: C<$dbh, $dsn, $user, $auth, $attr>.
  
  For example, some applications uses C<connect_cached()> to connect with
  C<AutoCommit> enabled and then disable C<AutoCommit> temporarily for
  transactions. If C<connect_cached()> is called during a transaction, perhaps in
  a utility method, then it might select the same cached handle and then force
  C<AutoCommit> on, forcing a commit of the transaction. See the L</connect_cached>
  documentation for one way to deal with that. Here we'll describe an alternative
  approach using a callback.
  
  Because the C<connect_cached.*> callbacks are invoked before connect_cached()
  has applied the connect attributes you can use a callback to edit the attributes
  that will be applied.  To prevent a cached handle from having its transactions
  committed before it's returned, you can eliminate the C<AutoCommit> attribute
  in a C<connect_cached.reused> callback, like so:
  
    my $cb = {
        ‘connect_cached.reused’ => sub { delete $_[4]->{AutoCommit} },
    };
  
    sub dbh {
        my $self = shift;
        DBI->connect_cached( $dsn, $username, $auth, {
            PrintError => 0,
            RaiseError => 1,
            AutoCommit => 1,
            Callbacks  => $cb,
        });
    }
  
  The upshot is that new database handles are created with C<AutoCommit>
  enabled, while cached database handles are left in whatever transaction state
  they happened to be in when retrieved from the cache.
  
  A more common application for callbacks is setting connection state only when a
  new connection is made (by connect() or connect_cached()). Adding a callback to
  the connected method makes this easy.
  This method is a no-op by default (unless you subclass the DBI and change it).
  The DBI calls it to indicate that a new connection has been made and the connection
  attributes have all been set.  You can
  give it a bit of added functionality by applying a callback to it. For
  example, to make sure that MySQL understands your application's ANSI-compliant
  SQL, set it up like so:
  
    my $dbh = DBI->connect($dsn, $username, $auth, {
        Callbacks => {
            connected => sub {
                shift->do(q{
                    SET SESSION sql_mode='ansi,strict_trans_tables,no_auto_value_on_zero';
                });
                return;
            },
        }
    });
  
  One significant limitation with callbacks is that there can only be one per
  method per handle. This means it's easy for one use of callbacks to interfere
  with, or typically simply overwrite, another use of callbacks. For this reason
  modules using callbacks should document the fact clearly so application authors
  can tell if use of callbacks by the module will clash with use of callbacks by
  the application.
  
  You might be able to work around this issue by taking a copy of the original
  callback and calling it within your own. For example:
  
    my $prev_cb = $h->{Callbacks}{method_name};
    $h->{Callbacks}{method_name} = sub {
      if ($prev_cb) {
          my @result = $prev_cb->(@_);
  	return @result if not $_; # $prev_cb vetoed call
      }
      ... your callback logic here ...
    };
  
  =head3 C<private_your_module_name_*>
  
  The DBI provides a way to store extra information in a DBI handle as
  "private" attributes. The DBI will allow you to store and retrieve any
  attribute which has a name starting with "C<private_>".
  
  It is I<strongly> recommended that you use just I<one> private
  attribute (e.g., use a hash ref) I<and> give it a long and unambiguous
  name that includes the module or application name that the attribute
  relates to (e.g., "C<private_YourFullModuleName_thingy>").
  
  Because of the way the Perl tie mechanism works you cannot reliably
  use the C<||=> operator directly to initialise the attribute, like this:
  
    my $foo = $dbh->{private_yourmodname_foo} ||= { ... }; # WRONG
  
  you should use a two step approach like this:
  
    my $foo = $dbh->{private_yourmodname_foo};
    $foo ||= $dbh->{private_yourmodname_foo} = { ... };
  
  This attribute is primarily of interest to people sub-classing DBI,
  or for applications to piggy-back extra information onto DBI handles.
  
  =head1 DBI DATABASE HANDLE OBJECTS
  
  This section covers the methods and attributes associated with
  database handles.
  
  =head2 Database Handle Methods
  
  The following methods are specified for DBI database handles:
  
  =head3 C<clone>
  
    $new_dbh = $dbh->clone();
    $new_dbh = $dbh->clone(\%attr);
  
  The C<clone> method duplicates the $dbh connection by connecting
  with the same parameters ($dsn, $user, $password) as originally used.
  
  The attributes for the cloned connect are the same as those used
  for the original connect, with some other attributes merged over
  them depending on the \%attr parameter.
  
  If \%attr is given then the attributes it contains are merged into
  the original attributes and override any with the same names.
  Effectively the same as doing:
  
    %attribues_used = ( %original_attributes, %attr );
  
  If \%attr is not given then it defaults to a hash containing all
  the attributes in the attribute cache of $dbh excluding any non-code
  references, plus the main boolean attributes (RaiseError, PrintError,
  AutoCommit, etc.). This behaviour is subject to change.
  
  The clone method can be used even if the database handle is disconnected.
  
  The C<clone> method was added in DBI 1.33. It is very new and likely
  to change.
  
  =head3 C<data_sources>
  
    @ary = $dbh->data_sources();
    @ary = $dbh->data_sources(\%attr);
  
  Returns a list of data sources (databases) available via the $dbh
  driver's data_sources() method, plus any extra data sources that
  the driver can discover via the connected $dbh. Typically the extra
  data sources are other databases managed by the same server process
  that the $dbh is connected to.
  
  Data sources are returned in a form suitable for passing to the
  L</connect> method (that is, they will include the "C<dbi:$driver:>" prefix).
  
  The data_sources() method, for a $dbh, was added in DBI 1.38.
  
  =head3 C<do>
  
    $rows = $dbh->do($statement)           or die $dbh->errstr;
    $rows = $dbh->do($statement, \%attr)   or die $dbh->errstr;
    $rows = $dbh->do($statement, \%attr, @bind_values) or die ...
  
  Prepare and execute a single statement. Returns the number of rows
  affected or C<undef> on error. A return value of C<-1> means the
  number of rows is not known, not applicable, or not available.
  
  This method is typically most useful for I<non>-C<SELECT> statements that
  either cannot be prepared in advance (due to a limitation of the
  driver) or do not need to be executed repeatedly. It should not
  be used for C<SELECT> statements because it does not return a statement
  handle (so you can't fetch any data).
  
  The default C<do> method is logically similar to:
  
    sub do {
        my($dbh, $statement, $attr, @bind_values) = @_;
        my $sth = $dbh->prepare($statement, $attr) or return undef;
        $sth->execute(@bind_values) or return undef;
        my $rows = $sth->rows;
        ($rows == 0) ? "0E0" : $rows; # always return true if no error
    }
  
  For example:
  
    my $rows_deleted = $dbh->do(q{
        DELETE FROM table
        WHERE status = ?
    }, undef, 'DONE') or die $dbh->errstr;
  
  Using placeholders and C<@bind_values> with the C<do> method can be
  useful because it avoids the need to correctly quote any variables
  in the C<$statement>. But if you'll be executing the statement many
  times then it's more efficient to C<prepare> it once and call
  C<execute> many times instead.
  
  The C<q{...}> style quoting used in this example avoids clashing with
  quotes that may be used in the SQL statement. Use the double-quote-like
  C<qq{...}> operator if you want to interpolate variables into the string.
  See L<perlop/"Quote and Quote-like Operators"> for more details.
  
  =head3 C<last_insert_id>
  
    $rv = $dbh->last_insert_id($catalog, $schema, $table, $field);
    $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr);
  
  Returns a value 'identifying' the row just inserted, if possible.
  Typically this would be a value assigned by the database server
  to a column with an I<auto_increment> or I<serial> type.
  Returns undef if the driver does not support the method or can't
  determine the value.
  
  The $catalog, $schema, $table, and $field parameters may be required
  for some drivers (see below).  If you don't know the parameter values
  and your driver does not need them, then use C<undef> for each.
  
  There are several caveats to be aware of with this method if you want
  to use it for portable applications:
  
  B<*> For some drivers the value may only available immediately after
  the insert statement has executed (e.g., mysql, Informix).
  
  B<*> For some drivers the $catalog, $schema, $table, and $field parameters
  are required, for others they are ignored (e.g., mysql).
  
  B<*> Drivers may return an indeterminate value if no insert has
  been performed yet.
  
  B<*> For some drivers the value may only be available if placeholders
  have I<not> been used (e.g., Sybase, MS SQL). In this case the value
  returned would be from the last non-placeholder insert statement.
  
  B<*> Some drivers may need driver-specific hints about how to get
  the value. For example, being told the name of the database 'sequence'
  object that holds the value. Any such hints are passed as driver-specific
  attributes in the \%attr parameter.
  
  B<*> If the underlying database offers nothing better, then some
  drivers may attempt to implement this method by executing
  "C<select max($field) from $table>". Drivers using any approach
  like this should issue a warning if C<AutoCommit> is true because
  it is generally unsafe - another process may have modified the table
  between your insert and the select. For situations where you know
  it is safe, such as when you have locked the table, you can silence
  the warning by passing C<Warn> => 0 in \%attr.
  
  B<*> If no insert has been performed yet, or the last insert failed,
  then the value is implementation defined.
  
  Given all the caveats above, it's clear that this method must be
  used with care.
  
  The C<last_insert_id> method was added in DBI 1.38.
  
  =head3 C<selectrow_array>
  
    @row_ary = $dbh->selectrow_array($statement);
    @row_ary = $dbh->selectrow_array($statement, \%attr);
    @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute> and
  L</fetchrow_array> into a single call. If called in a list context, it
  returns the first row of data from the statement.  The C<$statement>
  parameter can be a previously prepared statement handle, in which case
  the C<prepare> is skipped.
  
  If any method fails, and L</RaiseError> is not set, C<selectrow_array>
  will return an empty list.
  
  If called in a scalar context for a statement handle that has more
  than one column, it is undefined whether the driver will return
  the value of the first column or the last. So don't do that.
  Also, in a scalar context, an C<undef> is returned if there are no
  more rows or if an error occurred. That C<undef> can't be distinguished
  from an C<undef> returned because the first field value was NULL.
  For these reasons you should exercise some caution if you use
  C<selectrow_array> in a scalar context, or just don't do that.
  
  
  =head3 C<selectrow_arrayref>
  
    $ary_ref = $dbh->selectrow_arrayref($statement);
    $ary_ref = $dbh->selectrow_arrayref($statement, \%attr);
    $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute> and
  L</fetchrow_arrayref> into a single call. It returns the first row of
  data from the statement.  The C<$statement> parameter can be a previously
  prepared statement handle, in which case the C<prepare> is skipped.
  
  If any method fails, and L</RaiseError> is not set, C<selectrow_array>
  will return undef.
  
  
  =head3 C<selectrow_hashref>
  
    $hash_ref = $dbh->selectrow_hashref($statement);
    $hash_ref = $dbh->selectrow_hashref($statement, \%attr);
    $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute> and
  L</fetchrow_hashref> into a single call. It returns the first row of
  data from the statement.  The C<$statement> parameter can be a previously
  prepared statement handle, in which case the C<prepare> is skipped.
  
  If any method fails, and L</RaiseError> is not set, C<selectrow_hashref>
  will return undef.
  
  
  =head3 C<selectall_arrayref>
  
    $ary_ref = $dbh->selectall_arrayref($statement);
    $ary_ref = $dbh->selectall_arrayref($statement, \%attr);
    $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute> and
  L</fetchall_arrayref> into a single call. It returns a reference to an
  array containing a reference to an array (or hash, see below) for each row of
  data fetched.
  
  The C<$statement> parameter can be a previously prepared statement handle,
  in which case the C<prepare> is skipped. This is recommended if the
  statement is going to be executed many times.
  
  If L</RaiseError> is not set and any method except C<fetchall_arrayref>
  fails then C<selectall_arrayref> will return C<undef>; if
  C<fetchall_arrayref> fails then it will return with whatever data
  has been fetched thus far. You should check C<$sth-E<gt>err>
  afterwards (or use the C<RaiseError> attribute) to discover if the data is
  complete or was truncated due to an error.
  
  The L</fetchall_arrayref> method called by C<selectall_arrayref>
  supports a $max_rows parameter. You can specify a value for $max_rows
  by including a 'C<MaxRows>' attribute in \%attr. In which case finish()
  is called for you after fetchall_arrayref() returns.
  
  The L</fetchall_arrayref> method called by C<selectall_arrayref>
  also supports a $slice parameter. You can specify a value for $slice by
  including a 'C<Slice>' or 'C<Columns>' attribute in \%attr. The only
  difference between the two is that if C<Slice> is not defined and
  C<Columns> is an array ref, then the array is assumed to contain column
  index values (which count from 1), rather than perl array index values.
  In which case the array is copied and each value decremented before
  passing to C</fetchall_arrayref>.
  
  You may often want to fetch an array of rows where each row is stored as a
  hash. That can be done simple using:
  
    my $emps = $dbh->selectall_arrayref(
        "SELECT ename FROM emp ORDER BY ename",
        { Slice => {} }
    );
    foreach my $emp ( @$emps ) {
        print "Employee: $emp->{ename}\n";
    }
  
  Or, to fetch into an array instead of an array ref:
  
    @result = @{ $dbh->selectall_arrayref($sql, { Slice => {} }) };
  
  See L</fetchall_arrayref> method for more details.
  
  =head3 C<selectall_hashref>
  
    $hash_ref = $dbh->selectall_hashref($statement, $key_field);
    $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr);
    $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute> and
  L</fetchall_hashref> into a single call. It returns a reference to a
  hash containing one entry, at most, for each row, as returned by fetchall_hashref().
  
  The C<$statement> parameter can be a previously prepared statement handle,
  in which case the C<prepare> is skipped.  This is recommended if the
  statement is going to be executed many times.
  
  The C<$key_field> parameter defines which column, or columns, are used as keys
  in the returned hash. It can either be the name of a single field, or a
  reference to an array containing multiple field names. Using multiple names
  yields a tree of nested hashes.
  
  If a row has the same key as an earlier row then it replaces the earlier row.
  
  If any method except C<fetchrow_hashref> fails, and L</RaiseError> is not set,
  C<selectall_hashref> will return C<undef>.  If C<fetchrow_hashref> fails and
  L</RaiseError> is not set, then it will return with whatever data it
  has fetched thus far. $DBI::err should be checked to catch that.
  
  See fetchall_hashref() for more details.
  
  =head3 C<selectcol_arrayref>
  
    $ary_ref = $dbh->selectcol_arrayref($statement);
    $ary_ref = $dbh->selectcol_arrayref($statement, \%attr);
    $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values);
  
  This utility method combines L</prepare>, L</execute>, and fetching one
  column from all the rows, into a single call. It returns a reference to
  an array containing the values of the first column from each row.
  
  The C<$statement> parameter can be a previously prepared statement handle,
  in which case the C<prepare> is skipped. This is recommended if the
  statement is going to be executed many times.
  
  If any method except C<fetch> fails, and L</RaiseError> is not set,
  C<selectcol_arrayref> will return C<undef>.  If C<fetch> fails and
  L</RaiseError> is not set, then it will return with whatever data it
  has fetched thus far. $DBI::err should be checked to catch that.
  
  The C<selectcol_arrayref> method defaults to pushing a single column
  value (the first) from each row into the result array. However, it can
  also push another column, or even multiple columns per row, into the
  result array. This behaviour can be specified via a 'C<Columns>'
  attribute which must be a ref to an array containing the column number
  or numbers to use. For example:
  
    # get array of id and name pairs:
    my $ary_ref = $dbh->selectcol_arrayref("select id, name from table", { Columns=>[1,2] });
    my %hash = @$ary_ref; # build hash from key-value pairs so $hash{$id} => name
  
  You can specify a maximum number of rows to fetch by including a
  'C<MaxRows>' attribute in \%attr.
  
  =head3 C<prepare>
  
    $sth = $dbh->prepare($statement)          or die $dbh->errstr;
    $sth = $dbh->prepare($statement, \%attr)  or die $dbh->errstr;
  
  Prepares a statement for later execution by the database
  engine and returns a reference to a statement handle object.
  
  The returned statement handle can be used to get attributes of the
  statement and invoke the L</execute> method. See L</Statement Handle Methods>.
  
  Drivers for engines without the concept of preparing a
  statement will typically just store the statement in the returned
  handle and process it when C<$sth-E<gt>execute> is called. Such drivers are
  unlikely to give much useful information about the
  statement, such as C<$sth-E<gt>{NUM_OF_FIELDS}>, until after C<$sth-E<gt>execute>
  has been called. Portable applications should take this into account.
  
  In general, DBI drivers do not parse the contents of the statement
  (other than simply counting any L</Placeholders>). The statement is
  passed directly to the database engine, sometimes known as pass-thru
  mode. This has advantages and disadvantages. On the plus side, you can
  access all the functionality of the engine being used. On the downside,
  you're limited if you're using a simple engine, and you need to take extra care if
  writing applications intended to be portable between engines.
  
  Portable applications should not assume that a new statement can be
  prepared and/or executed while still fetching results from a previous
  statement.
  
  Some command-line SQL tools use statement terminators, like a semicolon,
  to indicate the end of a statement. Such terminators should not normally
  be used with the DBI.
  
  
  =head3 C<prepare_cached>
  
    $sth = $dbh->prepare_cached($statement)
    $sth = $dbh->prepare_cached($statement, \%attr)
    $sth = $dbh->prepare_cached($statement, \%attr, $if_active)
  
  Like L</prepare> except that the statement handle returned will be
  stored in a hash associated with the C<$dbh>. If another call is made to
  C<prepare_cached> with the same C<$statement> and C<%attr> parameter values,
  then the corresponding cached C<$sth> will be returned without contacting the
  database server.
  
  The C<$if_active> parameter lets you adjust the behaviour if an
  already cached statement handle is still Active.  There are several
  alternatives:
  
  =over 4
  
  =item B<0>: A warning will be generated, and finish() will be called on
  the statement handle before it is returned.  This is the default
  behaviour if $if_active is not passed.
  
  =item B<1>: finish() will be called on the statement handle, but the
  warning is suppressed.
  
  =item B<2>: Disables any checking.
  
  =item B<3>: The existing active statement handle will be removed from the
  cache and a new statement handle prepared and cached in its place.
  This is the safest option because it doesn't affect the state of the
  old handle, it just removes it from the cache. [Added in DBI 1.40]
  
  =back
  
  Here are some examples of C<prepare_cached>:
  
    sub insert_hash {
      my ($table, $field_values) = @_;
      # sort to keep field order, and thus sql, stable for prepare_cached
      my @fields = sort keys %$field_values;
      my @values = @{$field_values}{@fields};
      my $sql = sprintf "insert into %s (%s) values (%s)",
  	$table, join(",", @fields), join(",", ("?")x@fields);
      my $sth = $dbh->prepare_cached($sql);
      return $sth->execute(@values);
    }
  
    sub search_hash {
      my ($table, $field_values) = @_;
      # sort to keep field order, and thus sql, stable for prepare_cached
      my @fields = sort keys %$field_values;
      my @values = @{$field_values}{@fields};
      my $qualifier = "";
      $qualifier = "where ".join(" and ", map { "$_=?" } @fields) if @fields;
      $sth = $dbh->prepare_cached("SELECT * FROM $table $qualifier");
      return $dbh->selectall_arrayref($sth, {}, @values);
    }
  
  I<Caveat emptor:> This caching can be useful in some applications,
  but it can also cause problems and should be used with care. Here
  is a contrived case where caching would cause a significant problem:
  
    my $sth = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?');
    $sth->execute(...);
    while (my $data = $sth->fetchrow_hashref) {
  
      # later, in some other code called within the loop...
      my $sth2 = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?');
      $sth2->execute(...);
      while (my $data2 = $sth2->fetchrow_arrayref) {
        do_stuff(...);
      }
    }
  
  In this example, since both handles are preparing the exact same statement,
  C<$sth2> will not be its own statement handle, but a duplicate of C<$sth>
  returned from the cache. The results will certainly not be what you expect.
  Typically the inner fetch loop will work normally, fetching all
  the records and terminating when there are no more, but now that $sth
  is the same as $sth2 the outer fetch loop will also terminate.
  
  You'll know if you run into this problem because prepare_cached()
  will generate a warning by default (when $if_active is false).
  
  The cache used by prepare_cached() is keyed by both the statement
  and any attributes so you can also avoid this issue by doing something
  like:
  
    $sth = $dbh->prepare_cached("...", { dbi_dummy => __FILE__.__LINE__ });
  
  which will ensure that prepare_cached only returns statements cached
  by that line of code in that source file.
  
  If you'd like the cache to managed intelligently, you can tie the
  hashref returned by C<CachedKids> to an appropriate caching module,
  such as L<Tie::Cache::LRU>:
  
    my $cache;
    tie %$cache, 'Tie::Cache::LRU', 500;
    $dbh->{CachedKids} = $cache;
  
  =head3 C<commit>
  
    $rc  = $dbh->commit     or die $dbh->errstr;
  
  Commit (make permanent) the most recent series of database changes
  if the database supports transactions and AutoCommit is off.
  
  If C<AutoCommit> is on, then calling
  C<commit> will issue a "commit ineffective with AutoCommit" warning.
  
  See also L</Transactions> in the L</FURTHER INFORMATION> section below.
  
  =head3 C<rollback>
  
    $rc  = $dbh->rollback   or die $dbh->errstr;
  
  Rollback (undo) the most recent series of uncommitted database
  changes if the database supports transactions and AutoCommit is off.
  
  If C<AutoCommit> is on, then calling
  C<rollback> will issue a "rollback ineffective with AutoCommit" warning.
  
  See also L</Transactions> in the L</FURTHER INFORMATION> section below.
  
  =head3 C<begin_work>
  
    $rc  = $dbh->begin_work   or die $dbh->errstr;
  
  Enable transactions (by turning C<AutoCommit> off) until the next call
  to C<commit> or C<rollback>. After the next C<commit> or C<rollback>,
  C<AutoCommit> will automatically be turned on again.
  
  If C<AutoCommit> is already off when C<begin_work> is called then
  it does nothing except return an error. If the driver does not support
  transactions then when C<begin_work> attempts to set C<AutoCommit> off
  the driver will trigger a fatal error.
  
  See also L</Transactions> in the L</FURTHER INFORMATION> section below.
  
  
  =head3 C<disconnect>
  
    $rc = $dbh->disconnect  or warn $dbh->errstr;
  
  Disconnects the database from the database handle. C<disconnect> is typically only used
  before exiting the program. The handle is of little use after disconnecting.
  
  The transaction behaviour of the C<disconnect> method is, sadly,
  undefined.  Some database systems (such as Oracle and Ingres) will
  automatically commit any outstanding changes, but others (such as
  Informix) will rollback any outstanding changes.  Applications not
  using C<AutoCommit> should explicitly call C<commit> or C<rollback> before
  calling C<disconnect>.
  
  The database is automatically disconnected by the C<DESTROY> method if
  still connected when there are no longer any references to the handle.
  The C<DESTROY> method for each driver should implicitly call C<rollback> to
  undo any uncommitted changes. This is vital behaviour to ensure that
  incomplete transactions don't get committed simply because Perl calls
  C<DESTROY> on every object before exiting. Also, do not rely on the order
  of object destruction during "global destruction", as it is undefined.
  
  Generally, if you want your changes to be committed or rolled back when
  you disconnect, then you should explicitly call L</commit> or L</rollback>
  before disconnecting.
  
  If you disconnect from a database while you still have active
  statement handles (e.g., SELECT statement handles that may have
  more data to fetch), you will get a warning. The warning may indicate
  that a fetch loop terminated early, perhaps due to an uncaught error.
  To avoid the warning call the C<finish> method on the active handles.
  
  
  =head3 C<ping>
  
    $rc = $dbh->ping;
  
  Attempts to determine, in a reasonably efficient way, if the database
  server is still running and the connection to it is still working.
  Individual drivers should implement this function in the most suitable
  manner for their database engine.
  
  The current I<default> implementation always returns true without
  actually doing anything. Actually, it returns "C<0 but true>" which is
  true but zero. That way you can tell if the return value is genuine or
  just the default. Drivers should override this method with one that
  does the right thing for their type of database.
  
  Few applications would have direct use for this method. See the specialized
  Apache::DBI module for one example usage.
  
  
  =head3 C<get_info>
  
    $value = $dbh->get_info( $info_type );
  
  Returns information about the implementation, i.e. driver and data
  source capabilities, restrictions etc. It returns C<undef> for
  unknown or unimplemented information types. For example:
  
    $database_version  = $dbh->get_info(  18 ); # SQL_DBMS_VER
    $max_select_tables = $dbh->get_info( 106 ); # SQL_MAXIMUM_TABLES_IN_SELECT
  
  See L</"Standards Reference Information"> for more detailed information
  about the information types and their meanings and possible return values.
  
  The DBI::Const::GetInfoType module exports a %GetInfoType hash that
  can be used to map info type names to numbers. For example:
  
    $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
  
  The names are a merging of the ANSI and ODBC standards (which differ
  in some cases). See L<DBI::Const::GetInfoType> for more details.
  
  Because some DBI methods make use of get_info(), drivers are strongly
  encouraged to support I<at least> the following very minimal set
  of information types to ensure the DBI itself works properly:
  
   Type  Name                        Example A     Example B
   ----  --------------------------  ------------  ----------------
     17  SQL_DBMS_NAME               'ACCESS'      'Oracle'
     18  SQL_DBMS_VER                '03.50.0000'  '08.01.0721 ...'
     29  SQL_IDENTIFIER_QUOTE_CHAR   '`'           '"'
     41  SQL_CATALOG_NAME_SEPARATOR  '.'           '@'
    114  SQL_CATALOG_LOCATION        1             2
  
  =head3 C<table_info>
  
    $sth = $dbh->table_info( $catalog, $schema, $table, $type );
    $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr );
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Returns an active statement handle that can be used to fetch
  information about tables and views that exist in the database.
  
  The arguments $catalog, $schema and $table may accept search patterns
  according to the database/driver, for example: $table = '%FOO%';
  Remember that the underscore character ('C<_>') is a search pattern
  that means match any character, so 'FOO_%' is the same as 'FOO%'
  and 'FOO_BAR%' will match names like 'FOO1BAR'.
  
  The value of $type is a comma-separated list of one or more types of
  tables to be returned in the result set. Each value may optionally be
  quoted, e.g.:
  
    $type = "TABLE";
    $type = "'TABLE','VIEW'";
  
  In addition the following special cases may also be supported by some drivers:
  
  =over 4
  
  =item *
  If the value of $catalog is '%' and $schema and $table name
  are empty strings, the result set contains a list of catalog names.
  For example:
  
    $sth = $dbh->table_info('%', '', '');
  
  =item *
  If the value of $schema is '%' and $catalog and $table are empty
  strings, the result set contains a list of schema names.
  
  =item *
  If the value of $type is '%' and $catalog, $schema, and $table are all
  empty strings, the result set contains a list of table types.
  
  =back
  
  If your driver doesn't support one or more of the selection filter
  parameters then you may get back more than you asked for and can
  do the filtering yourself.
  
  This method can be expensive, and can return a large amount of data.
  (For example, small Oracle installation returns over 2000 rows.)
  So it's a good idea to use the filters to limit the data as much as possible.
  
  The statement handle returned has at least the following fields in the
  order show below. Other fields, after these, may also be present.
  
  B<TABLE_CAT>: Table catalog identifier. This field is NULL (C<undef>) if not
  applicable to the data source, which is usually the case. This field
  is empty if not applicable to the table.
  
  B<TABLE_SCHEM>: The name of the schema containing the TABLE_NAME value.
  This field is NULL (C<undef>) if not applicable to data source, and
  empty if not applicable to the table.
  
  B<TABLE_NAME>: Name of the table (or view, synonym, etc).
  
  B<TABLE_TYPE>: One of the following: "TABLE", "VIEW", "SYSTEM TABLE",
  "GLOBAL TEMPORARY", "LOCAL TEMPORARY", "ALIAS", "SYNONYM" or a type
  identifier that is specific to the data
  source.
  
  B<REMARKS>: A description of the table. May be NULL (C<undef>).
  
  Note that C<table_info> might not return records for all tables.
  Applications can use any valid table regardless of whether it's
  returned by C<table_info>.
  
  See also L</tables>, L</"Catalog Methods"> and
  L</"Standards Reference Information">.
  
  =head3 C<column_info>
  
    $sth = $dbh->column_info( $catalog, $schema, $table, $column );
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Returns an active statement handle that can be used to fetch
  information about columns in specified tables.
  
  The arguments $schema, $table and $column may accept search patterns
  according to the database/driver, for example: $table = '%FOO%';
  
  Note: The support for the selection criteria is driver specific. If the
  driver doesn't support one or more of them then you may get back more
  than you asked for and can do the filtering yourself.
  
  Note: If your driver does not support column_info an undef is
  returned.  This is distinct from asking for something which does not
  exist in a driver which supports column_info as a valid statement
  handle to an empty result-set will be returned in this case.
  
  If the arguments don't match any tables then you'll still get a statement
  handle, it'll just return no rows.
  
  The statement handle returned has at least the following fields in the
  order shown below. Other fields, after these, may also be present.
  
  B<TABLE_CAT>: The catalog identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  which is often the case.  This field is empty if not applicable to the
  table.
  
  B<TABLE_SCHEM>: The schema identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  and empty if not applicable to the table.
  
  B<TABLE_NAME>: The table identifier.
  Note: A driver may provide column metadata not only for base tables, but
  also for derived objects like SYNONYMS etc.
  
  B<COLUMN_NAME>: The column identifier.
  
  B<DATA_TYPE>: The concise data type code.
  
  B<TYPE_NAME>: A data source dependent data type name.
  
  B<COLUMN_SIZE>: The column size.
  This is the maximum length in characters for character data types,
  the number of digits or bits for numeric data types or the length
  in the representation of temporal types.
  See the relevant specifications for detailed information.
  
  B<BUFFER_LENGTH>: The length in bytes of transferred data.
  
  B<DECIMAL_DIGITS>: The total number of significant digits to the right of
  the decimal point.
  
  B<NUM_PREC_RADIX>: The radix for numeric precision.
  The value is 10 or 2 for numeric data types and NULL (C<undef>) if not
  applicable.
  
  B<NULLABLE>: Indicates if a column can accept NULLs.
  The following values are defined:
  
    SQL_NO_NULLS          0
    SQL_NULLABLE          1
    SQL_NULLABLE_UNKNOWN  2
  
  B<REMARKS>: A description of the column.
  
  B<COLUMN_DEF>: The default value of the column, in a format that can be used
  directly in an SQL statement.
  
  Note that this may be an expression and not simply the text used for the
  default value in the original CREATE TABLE statement. For example, given:
  
      col1 char(30) default current_user    -- a 'function'
      col2 char(30) default 'string'        -- a string literal
  
  where "current_user" is the name of a function, the corresponding C<COLUMN_DEF>
  values would be:
  
      Database        col1                     col2
      --------        ----                     ----
      Oracle:         current_user             'string'
      Postgres:       "current_user"()         'string'::text
      MS SQL:         (user_name())            ('string')
  
  B<SQL_DATA_TYPE>: The SQL data type.
  
  B<SQL_DATETIME_SUB>: The subtype code for datetime and interval data types.
  
  B<CHAR_OCTET_LENGTH>: The maximum length in bytes of a character or binary
  data type column.
  
  B<ORDINAL_POSITION>: The column sequence number (starting with 1).
  
  B<IS_NULLABLE>: Indicates if the column can accept NULLs.
  Possible values are: 'NO', 'YES' and ''.
  
  SQL/CLI defines the following additional columns:
  
    CHAR_SET_CAT
    CHAR_SET_SCHEM
    CHAR_SET_NAME
    COLLATION_CAT
    COLLATION_SCHEM
    COLLATION_NAME
    UDT_CAT
    UDT_SCHEM
    UDT_NAME
    DOMAIN_CAT
    DOMAIN_SCHEM
    DOMAIN_NAME
    SCOPE_CAT
    SCOPE_SCHEM
    SCOPE_NAME
    MAX_CARDINALITY
    DTD_IDENTIFIER
    IS_SELF_REF
  
  Drivers capable of supplying any of those values should do so in
  the corresponding column and supply undef values for the others.
  
  Drivers wishing to provide extra database/driver specific information
  should do so in extra columns beyond all those listed above, and
  use lowercase field names with the driver-specific prefix (i.e.,
  'ora_...'). Applications accessing such fields should do so by name
  and not by column number.
  
  The result set is ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME
  and ORDINAL_POSITION.
  
  Note: There is some overlap with statement handle attributes (in perl) and
  SQLDescribeCol (in ODBC). However, SQLColumns provides more metadata.
  
  See also L</"Catalog Methods"> and L</"Standards Reference Information">.
  
  =head3 C<primary_key_info>
  
    $sth = $dbh->primary_key_info( $catalog, $schema, $table );
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Returns an active statement handle that can be used to fetch information
  about columns that make up the primary key for a table.
  The arguments don't accept search patterns (unlike table_info()).
  
  The statement handle will return one row per column, ordered by
  TABLE_CAT, TABLE_SCHEM, TABLE_NAME, and KEY_SEQ.
  If there is no primary key then the statement handle will fetch no rows.
  
  Note: The support for the selection criteria, such as $catalog, is
  driver specific.  If the driver doesn't support catalogs and/or
  schemas, it may ignore these criteria.
  
  The statement handle returned has at least the following fields in the
  order shown below. Other fields, after these, may also be present.
  
  B<TABLE_CAT>: The catalog identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  which is often the case.  This field is empty if not applicable to the
  table.
  
  B<TABLE_SCHEM>: The schema identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  and empty if not applicable to the table.
  
  B<TABLE_NAME>: The table identifier.
  
  B<COLUMN_NAME>: The column identifier.
  
  B<KEY_SEQ>: The column sequence number (starting with 1).
  Note: This field is named B<ORDINAL_POSITION> in SQL/CLI.
  
  B<PK_NAME>: The primary key constraint identifier.
  This field is NULL (C<undef>) if not applicable to the data source.
  
  See also L</"Catalog Methods"> and L</"Standards Reference Information">.
  
  =head3 C<primary_key>
  
    @key_column_names = $dbh->primary_key( $catalog, $schema, $table );
  
  Simple interface to the primary_key_info() method. Returns a list of
  the column names that comprise the primary key of the specified table.
  The list is in primary key column sequence order.
  If there is no primary key then an empty list is returned.
  
  =head3 C<foreign_key_info>
  
    $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table
                                 , $fk_catalog, $fk_schema, $fk_table );
  
    $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table
                                 , $fk_catalog, $fk_schema, $fk_table
                                 , \%attr );
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Returns an active statement handle that can be used to fetch information
  about foreign keys in and/or referencing the specified table(s).
  The arguments don't accept search patterns (unlike table_info()).
  
  C<$pk_catalog>, C<$pk_schema>, C<$pk_table>
  identify the primary (unique) key table (B<PKT>).
  
  C<$fk_catalog>, C<$fk_schema>, C<$fk_table>
  identify the foreign key table (B<FKT>).
  
  If both B<PKT> and B<FKT> are given, the function returns the foreign key, if
  any, in table B<FKT> that refers to the primary (unique) key of table B<PKT>.
  (Note: In SQL/CLI, the result is implementation-defined.)
  
  If only B<PKT> is given, then the result set contains the primary key
  of that table and all foreign keys that refer to it.
  
  If only B<FKT> is given, then the result set contains all foreign keys
  in that table and the primary keys to which they refer.
  (Note: In SQL/CLI, the result includes unique keys too.)
  
  For example:
  
    $sth = $dbh->foreign_key_info( undef, $user, 'master');
    $sth = $dbh->foreign_key_info( undef, undef,   undef , undef, $user, 'detail');
    $sth = $dbh->foreign_key_info( undef, $user, 'master', undef, $user, 'detail');
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Note: The support for the selection criteria, such as C<$catalog>, is
  driver specific.  If the driver doesn't support catalogs and/or
  schemas, it may ignore these criteria.
  
  The statement handle returned has the following fields in the order shown below.
  Because ODBC never includes unique keys, they define different columns in the
  result set than SQL/CLI. SQL/CLI column names are shown in parentheses.
  
  B<PKTABLE_CAT    ( UK_TABLE_CAT      )>:
  The primary (unique) key table catalog identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  which is often the case.  This field is empty if not applicable to the
  table.
  
  B<PKTABLE_SCHEM  ( UK_TABLE_SCHEM    )>:
  The primary (unique) key table schema identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  and empty if not applicable to the table.
  
  B<PKTABLE_NAME   ( UK_TABLE_NAME     )>:
  The primary (unique) key table identifier.
  
  B<PKCOLUMN_NAME  (UK_COLUMN_NAME    )>:
  The primary (unique) key column identifier.
  
  B<FKTABLE_CAT    ( FK_TABLE_CAT      )>:
  The foreign key table catalog identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  which is often the case.  This field is empty if not applicable to the
  table.
  
  B<FKTABLE_SCHEM  ( FK_TABLE_SCHEM    )>:
  The foreign key table schema identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  and empty if not applicable to the table.
  
  B<FKTABLE_NAME   ( FK_TABLE_NAME     )>:
  The foreign key table identifier.
  
  B<FKCOLUMN_NAME  ( FK_COLUMN_NAME    )>:
  The foreign key column identifier.
  
  B<KEY_SEQ        ( ORDINAL_POSITION  )>:
  The column sequence number (starting with 1).
  
  B<UPDATE_RULE    ( UPDATE_RULE       )>:
  The referential action for the UPDATE rule.
  The following codes are defined:
  
    CASCADE              0
    RESTRICT             1
    SET NULL             2
    NO ACTION            3
    SET DEFAULT          4
  
  B<DELETE_RULE    ( DELETE_RULE       )>:
  The referential action for the DELETE rule.
  The codes are the same as for UPDATE_RULE.
  
  B<FK_NAME        ( FK_NAME           )>:
  The foreign key name.
  
  B<PK_NAME        ( UK_NAME           )>:
  The primary (unique) key name.
  
  B<DEFERRABILITY  ( DEFERABILITY      )>:
  The deferrability of the foreign key constraint.
  The following codes are defined:
  
    INITIALLY DEFERRED   5
    INITIALLY IMMEDIATE  6
    NOT DEFERRABLE       7
  
  B<               ( UNIQUE_OR_PRIMARY )>:
  This column is necessary if a driver includes all candidate (i.e. primary and
  alternate) keys in the result set (as specified by SQL/CLI).
  The value of this column is UNIQUE if the foreign key references an alternate
  key and PRIMARY if the foreign key references a primary key, or it
  may be undefined if the driver doesn't have access to the information.
  
  See also L</"Catalog Methods"> and L</"Standards Reference Information">.
  
  =head3 C<statistics_info>
  
  B<Warning:> This method is experimental and may change.
  
    $sth = $dbh->statistics_info( $catalog, $schema, $table, $unique_only, $quick );
  
    # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc
  
  Returns an active statement handle that can be used to fetch statistical
  information about a table and its indexes.
  
  The arguments don't accept search patterns (unlike L</table_info>).
  
  If the boolean argument $unique_only is true, only UNIQUE indexes will be
  returned in the result set, otherwise all indexes will be returned.
  
  If the boolean argument $quick is set, the actual statistical information
  columns (CARDINALITY and PAGES) will only be returned if they are readily
  available from the server, and might not be current.  Some databases may
  return stale statistics or no statistics at all with this flag set.
  
  The statement handle will return at most one row per column name per index,
  plus at most one row for the entire table itself, ordered by NON_UNIQUE, TYPE,
  INDEX_QUALIFIER, INDEX_NAME, and ORDINAL_POSITION.
  
  Note: The support for the selection criteria, such as $catalog, is
  driver specific.  If the driver doesn't support catalogs and/or
  schemas, it may ignore these criteria.
  
  The statement handle returned has at least the following fields in the
  order shown below. Other fields, after these, may also be present.
  
  B<TABLE_CAT>: The catalog identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  which is often the case.  This field is empty if not applicable to the
  table.
  
  B<TABLE_SCHEM>: The schema identifier.
  This field is NULL (C<undef>) if not applicable to the data source,
  and empty if not applicable to the table.
  
  B<TABLE_NAME>: The table identifier.
  
  B<NON_UNIQUE>: Unique index indicator.
  Returns 0 for unique indexes, 1 for non-unique indexes
  
  B<INDEX_QUALIFIER>: Index qualifier identifier.
  The identifier that is used to qualify the index name when doing a
  C<DROP INDEX>; NULL (C<undef>) is returned if an index qualifier is not
  supported by the data source.
  If a non-NULL (defined) value is returned in this column, it must be used
  to qualify the index name on a C<DROP INDEX> statement; otherwise,
  the TABLE_SCHEM should be used to qualify the index name.
  
  B<INDEX_NAME>: The index identifier.
  
  B<TYPE>: The type of information being returned.  Can be any of the
  following values: 'table', 'btree', 'clustered', 'content', 'hashed',
  or 'other'.
  
  In the case that this field is 'table', all fields
  other than TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TYPE,
  CARDINALITY, and PAGES will be NULL (C<undef>).
  
  B<ORDINAL_POSITION>: Column sequence number (starting with 1).
  
  B<COLUMN_NAME>: The column identifier.
  
  B<ASC_OR_DESC>: Column sort sequence.
  C<A> for Ascending, C<D> for Descending, or NULL (C<undef>) if
  not supported for this index.
  
  B<CARDINALITY>: Cardinality of the table or index.
  For indexes, this is the number of unique values in the index.
  For tables, this is the number of rows in the table.
  If not supported, the value will be NULL (C<undef>).
  
  B<PAGES>: Number of storage pages used by this table or index.
  If not supported, the value will be NULL (C<undef>).
  
  B<FILTER_CONDITION>: The index filter condition as a string.
  If the index is not a filtered index, or it cannot be determined
  whether the index is a filtered index, this value is NULL (C<undef>).
  If the index is a filtered index, but the filter condition
  cannot be determined, this value is the empty string C<''>.
  Otherwise it will be the literal filter condition as a string,
  such as C<SALARY <= 4500>.
  
  See also L</"Catalog Methods"> and L</"Standards Reference Information">.
  
  =head3 C<tables>
  
    @names = $dbh->tables( $catalog, $schema, $table, $type );
    @names = $dbh->tables;	# deprecated
  
  Simple interface to table_info(). Returns a list of matching
  table names, possibly including a catalog/schema prefix.
  
  See L</table_info> for a description of the parameters.
  
  If C<$dbh-E<gt>get_info(29)> returns true (29 is SQL_IDENTIFIER_QUOTE_CHAR)
  then the table names are constructed and quoted by L</quote_identifier>
  to ensure they are usable even if they contain whitespace or reserved
  words etc. This means that the table names returned will include
  quote characters.
  
  =head3 C<type_info_all>
  
    $type_info_all = $dbh->type_info_all;
  
  Returns a reference to an array which holds information about each data
  type variant supported by the database and driver. The array and its
  contents should be treated as read-only.
  
  The first item is a reference to an 'index' hash of C<Name =>E<gt> C<Index> pairs.
  The items following that are references to arrays, one per supported data
  type variant. The leading index hash defines the names and order of the
  fields within the arrays that follow it.
  For example:
  
    $type_info_all = [
      {   TYPE_NAME         => 0,
  	DATA_TYPE         => 1,
  	COLUMN_SIZE       => 2,     # was PRECISION originally
  	LITERAL_PREFIX    => 3,
  	LITERAL_SUFFIX    => 4,
  	CREATE_PARAMS     => 5,
  	NULLABLE          => 6,
  	CASE_SENSITIVE    => 7,
  	SEARCHABLE        => 8,
  	UNSIGNED_ATTRIBUTE=> 9,
  	FIXED_PREC_SCALE  => 10,    # was MONEY originally
  	AUTO_UNIQUE_VALUE => 11,    # was AUTO_INCREMENT originally
  	LOCAL_TYPE_NAME   => 12,
  	MINIMUM_SCALE     => 13,
  	MAXIMUM_SCALE     => 14,
  	SQL_DATA_TYPE     => 15,
  	SQL_DATETIME_SUB  => 16,
  	NUM_PREC_RADIX    => 17,
  	INTERVAL_PRECISION=> 18,
      },
      [ 'VARCHAR', SQL_VARCHAR,
  	undef, "'","'", undef,0, 1,1,0,0,0,undef,1,255, undef
      ],
      [ 'INTEGER', SQL_INTEGER,
  	undef,  "", "", undef,0, 0,1,0,0,0,undef,0,  0, 10
      ],
    ];
  
  More than one row may have the same value in the C<DATA_TYPE>
  field if there are different ways to spell the type name and/or there
  are variants of the type with different attributes (e.g., with and
  without C<AUTO_UNIQUE_VALUE> set, with and without C<UNSIGNED_ATTRIBUTE>, etc).
  
  The rows are ordered by C<DATA_TYPE> first and then by how closely each
  type maps to the corresponding ODBC SQL data type, closest first.
  
  The meaning of the fields is described in the documentation for
  the L</type_info> method.
  
  An 'index' hash is provided so you don't need to rely on index
  values defined above.  However, using DBD::ODBC with some old ODBC
  drivers may return older names, shown as comments in the example above.
  Another issue with the index hash is that the lettercase of the
  keys is not defined. It is usually uppercase, as show here, but
  drivers may return names with any lettercase.
  
  Drivers are also free to return extra driver-specific columns of
  information - though it's recommended that they start at column
  index 50 to leave room for expansion of the DBI/ODBC specification.
  
  The type_info_all() method is not normally used directly.
  The L</type_info> method provides a more usable and useful interface
  to the data.
  
  =head3 C<type_info>
  
    @type_info = $dbh->type_info($data_type);
  
  Returns a list of hash references holding information about one or more
  variants of $data_type. The list is ordered by C<DATA_TYPE> first and
  then by how closely each type maps to the corresponding ODBC SQL data
  type, closest first.  If called in a scalar context then only the first
  (best) element is returned.
  
  If $data_type is undefined or C<SQL_ALL_TYPES>, then the list will
  contain hashes for all data type variants supported by the database and driver.
  
  If $data_type is an array reference then C<type_info> returns the
  information for the I<first> type in the array that has any matches.
  
  The keys of the hash follow the same letter case conventions as the
  rest of the DBI (see L</Naming Conventions and Name Space>). The
  following uppercase items should always exist, though may be undef:
  
  =over 4
  
  =item TYPE_NAME (string)
  
  Data type name for use in CREATE TABLE statements etc.
  
  =item DATA_TYPE (integer)
  
  SQL data type number.
  
  =item COLUMN_SIZE (integer)
  
  For numeric types, this is either the total number of digits (if the
  NUM_PREC_RADIX value is 10) or the total number of bits allowed in the
  column (if NUM_PREC_RADIX is 2).
  
  For string types, this is the maximum size of the string in characters.
  
  For date and interval types, this is the maximum number of characters
  needed to display the value.
  
  =item LITERAL_PREFIX (string)
  
  Characters used to prefix a literal. A typical prefix is "C<'>" for characters,
  or possibly "C<0x>" for binary values passed as hexadecimal.  NULL (C<undef>) is
  returned for data types for which this is not applicable.
  
  
  =item LITERAL_SUFFIX (string)
  
  Characters used to suffix a literal. Typically "C<'>" for characters.
  NULL (C<undef>) is returned for data types where this is not applicable.
  
  =item CREATE_PARAMS (string)
  
  Parameter names for data type definition. For example, C<CREATE_PARAMS> for a
  C<DECIMAL> would be "C<precision,scale>" if the DECIMAL type should be
  declared as C<DECIMAL(>I<precision,scale>C<)> where I<precision> and I<scale>
  are integer values.  For a C<VARCHAR> it would be "C<max length>".
  NULL (C<undef>) is returned for data types for which this is not applicable.
  
  =item NULLABLE (integer)
  
  Indicates whether the data type accepts a NULL value:
  C<0> or an empty string = no, C<1> = yes, C<2> = unknown.
  
  =item CASE_SENSITIVE (boolean)
  
  Indicates whether the data type is case sensitive in collations and
  comparisons.
  
  =item SEARCHABLE (integer)
  
  Indicates how the data type can be used in a WHERE clause, as
  follows:
  
    0 - Cannot be used in a WHERE clause
    1 - Only with a LIKE predicate
    2 - All comparison operators except LIKE
    3 - Can be used in a WHERE clause with any comparison operator
  
  =item UNSIGNED_ATTRIBUTE (boolean)
  
  Indicates whether the data type is unsigned.  NULL (C<undef>) is returned
  for data types for which this is not applicable.
  
  =item FIXED_PREC_SCALE (boolean)
  
  Indicates whether the data type always has the same precision and scale
  (such as a money type).  NULL (C<undef>) is returned for data types
  for which
  this is not applicable.
  
  =item AUTO_UNIQUE_VALUE (boolean)
  
  Indicates whether a column of this data type is automatically set to a
  unique value whenever a new row is inserted.  NULL (C<undef>) is returned
  for data types for which this is not applicable.
  
  =item LOCAL_TYPE_NAME (string)
  
  Localized version of the C<TYPE_NAME> for use in dialog with users.
  NULL (C<undef>) is returned if a localized name is not available (in which
  case C<TYPE_NAME> should be used).
  
  =item MINIMUM_SCALE (integer)
  
  The minimum scale of the data type. If a data type has a fixed scale,
  then C<MAXIMUM_SCALE> holds the same value.  NULL (C<undef>) is returned for
  data types for which this is not applicable.
  
  =item MAXIMUM_SCALE (integer)
  
  The maximum scale of the data type. If a data type has a fixed scale,
  then C<MINIMUM_SCALE> holds the same value.  NULL (C<undef>) is returned for
  data types for which this is not applicable.
  
  =item SQL_DATA_TYPE (integer)
  
  This column is the same as the C<DATA_TYPE> column, except for interval
  and datetime data types.  For interval and datetime data types, the
  C<SQL_DATA_TYPE> field will return C<SQL_INTERVAL> or C<SQL_DATETIME>, and the
  C<SQL_DATETIME_SUB> field below will return the subcode for the specific
  interval or datetime data type. If this field is NULL, then the driver
  does not support or report on interval or datetime subtypes.
  
  =item SQL_DATETIME_SUB (integer)
  
  For interval or datetime data types, where the C<SQL_DATA_TYPE>
  field above is C<SQL_INTERVAL> or C<SQL_DATETIME>, this field will
  hold the I<subcode> for the specific interval or datetime data type.
  Otherwise it will be NULL (C<undef>).
  
  Although not mentioned explicitly in the standards, it seems there
  is a simple relationship between these values:
  
    DATA_TYPE == (10 * SQL_DATA_TYPE) + SQL_DATETIME_SUB
  
  =item NUM_PREC_RADIX (integer)
  
  The radix value of the data type. For approximate numeric types,
  C<NUM_PREC_RADIX>
  contains the value 2 and C<COLUMN_SIZE> holds the number of bits. For
  exact numeric types, C<NUM_PREC_RADIX> contains the value 10 and C<COLUMN_SIZE> holds
  the number of decimal digits. NULL (C<undef>) is returned either for data types
  for which this is not applicable or if the driver cannot report this information.
  
  =item INTERVAL_PRECISION (integer)
  
  The interval leading precision for interval types. NULL is returned
  either for data types for which this is not applicable or if the driver
  cannot report this information.
  
  =back
  
  For example, to find the type name for the fields in a select statement
  you can do:
  
    @names = map { scalar $dbh->type_info($_)->{TYPE_NAME} } @{ $sth->{TYPE} }
  
  Since DBI and ODBC drivers vary in how they map their types into the
  ISO standard types you may need to search for more than one type.
  Here's an example looking for a usable type to store a date:
  
    $my_date_type = $dbh->type_info( [ SQL_DATE, SQL_TIMESTAMP ] );
  
  Similarly, to more reliably find a type to store small integers, you could
  use a list starting with C<SQL_SMALLINT>, C<SQL_INTEGER>, C<SQL_DECIMAL>, etc.
  
  See also L</"Standards Reference Information">.
  
  
  =head3 C<quote>
  
    $sql = $dbh->quote($value);
    $sql = $dbh->quote($value, $data_type);
  
  Quote a string literal for use as a literal value in an SQL statement,
  by escaping any special characters (such as quotation marks)
  contained within the string and adding the required type of outer
  quotation marks.
  
    $sql = sprintf "SELECT foo FROM bar WHERE baz = %s",
                  $dbh->quote("Don't");
  
  For most database types, at least those that conform to SQL standards, quote
  would return C<'Don''t'> (including the outer quotation marks). For others it
  may return something like C<'Don\'t'>
  
  An undefined C<$value> value will be returned as the string C<NULL> (without
  single quotation marks) to match how NULLs are represented in SQL.
  
  If C<$data_type> is supplied, it is used to try to determine the required
  quoting behaviour by using the information returned by L</type_info>.
  As a special case, the standard numeric types are optimized to return
  C<$value> without calling C<type_info>.
  
  Quote will probably I<not> be able to deal with all possible input
  (such as binary data or data containing newlines), and is not related in
  any way with escaping or quoting shell meta-characters.
  
  It is valid for the quote() method to return an SQL expression that
  evaluates to the desired string. For example:
  
    $quoted = $dbh->quote("one\ntwo\0three")
  
  may return something like:
  
    CONCAT('one', CHAR(12), 'two', CHAR(0), 'three')
  
  The quote() method should I<not> be used with L</"Placeholders and
  Bind Values">.
  
  =head3 C<quote_identifier>
  
    $sql = $dbh->quote_identifier( $name );
    $sql = $dbh->quote_identifier( $catalog, $schema, $table, \%attr );
  
  Quote an identifier (table name etc.) for use in an SQL statement,
  by escaping any special characters (such as double quotation marks)
  it contains and adding the required type of outer quotation marks.
  
  Undefined names are ignored and the remainder are quoted and then
  joined together, typically with a dot (C<.>) character. For example:
  
    $id = $dbh->quote_identifier( undef, 'Her schema', 'My table' );
  
  would, for most database types, return C<"Her schema"."My table">
  (including all the double quotation marks).
  
  If three names are supplied then the first is assumed to be a
  catalog name and special rules may be applied based on what L</get_info>
  returns for SQL_CATALOG_NAME_SEPARATOR (41) and SQL_CATALOG_LOCATION (114).
  For example, for Oracle:
  
    $id = $dbh->quote_identifier( 'link', 'schema', 'table' );
  
  would return C<"schema"."table"@"link">.
  
  =head3 C<take_imp_data>
  
    $imp_data = $dbh->take_imp_data;
  
  Leaves the $dbh in an almost dead, zombie-like, state and returns
  a binary string of raw implementation data from the driver which
  describes the current database connection. Effectively it detaches
  the underlying database API connection data from the DBI handle.
  After calling take_imp_data(), all other methods except C<DESTROY>
  will generate a warning and return undef.
  
  Why would you want to do this? You don't, forget I even mentioned it.
  Unless, that is, you're implementing something advanced like a
  multi-threaded connection pool. See L<DBI::Pool>.
  
  The returned $imp_data can be passed as a C<dbi_imp_data> attribute
  to a later connect() call, even in a separate thread in the same
  process, where the driver can use it to 'adopt' the existing
  connection that the implementation data was taken from.
  
  Some things to keep in mind...
  
  B<*> the $imp_data holds the only reference to the underlying
  database API connection data. That connection is still 'live' and
  won't be cleaned up properly unless the $imp_data is used to create
  a new $dbh which is then allowed to disconnect() normally.
  
  B<*> using the same $imp_data to create more than one other new
  $dbh at a time may well lead to unpleasant problems. Don't do that.
  
  Any child statement handles are effectively destroyed when take_imp_data() is
  called.
  
  The C<take_imp_data> method was added in DBI 1.36 but wasn't useful till 1.49.
  
  
  =head2 Database Handle Attributes
  
  This section describes attributes specific to database handles.
  
  Changes to these database handle attributes do not affect any other
  existing or future database handles.
  
  Attempting to set or get the value of an unknown attribute generates a warning,
  except for private driver-specific attributes (which all have names
  starting with a lowercase letter).
  
  Example:
  
    $h->{AutoCommit} = ...;	# set/write
    ... = $h->{AutoCommit};	# get/read
  
  =head3 C<AutoCommit>  (boolean)
  
  If true, then database changes cannot be rolled-back (undone).  If false,
  then database changes automatically occur within a "transaction", which
  must either be committed or rolled back using the C<commit> or C<rollback>
  methods.
  
  Drivers should always default to C<AutoCommit> mode (an unfortunate
  choice largely forced on the DBI by ODBC and JDBC conventions.)
  
  Attempting to set C<AutoCommit> to an unsupported value is a fatal error.
  This is an important feature of the DBI. Applications that need
  full transaction behaviour can set C<$dbh-E<gt>{AutoCommit} = 0> (or
  set C<AutoCommit> to 0 via L</connect>)
  without having to check that the value was assigned successfully.
  
  For the purposes of this description, we can divide databases into three
  categories:
  
    Databases which don't support transactions at all.
    Databases in which a transaction is always active.
    Databases in which a transaction must be explicitly started (C<'BEGIN WORK'>).
  
  B<* Databases which don't support transactions at all>
  
  For these databases, attempting to turn C<AutoCommit> off is a fatal error.
  C<commit> and C<rollback> both issue warnings about being ineffective while
  C<AutoCommit> is in effect.
  
  B<* Databases in which a transaction is always active>
  
  These are typically mainstream commercial relational databases with
  "ANSI standard" transaction behaviour.
  If C<AutoCommit> is off, then changes to the database won't have any
  lasting effect unless L</commit> is called (but see also
  L</disconnect>). If L</rollback> is called then any changes since the
  last commit are undone.
  
  If C<AutoCommit> is on, then the effect is the same as if the DBI
  called C<commit> automatically after every successful database
  operation. So calling C<commit> or C<rollback> explicitly while
  C<AutoCommit> is on would be ineffective because the changes would
  have already been committed.
  
  Changing C<AutoCommit> from off to on will trigger a L</commit>.
  
  For databases which don't support a specific auto-commit mode, the
  driver has to commit each statement automatically using an explicit
  C<COMMIT> after it completes successfully (and roll it back using an
  explicit C<ROLLBACK> if it fails).  The error information reported to the
  application will correspond to the statement which was executed, unless
  it succeeded and the commit or rollback failed.
  
  B<* Databases in which a transaction must be explicitly started>
  
  For these databases, the intention is to have them act like databases in
  which a transaction is always active (as described above).
  
  To do this, the driver will automatically begin an explicit transaction
  when C<AutoCommit> is turned off, or after a L</commit> or
  L</rollback> (or when the application issues the next database
  operation after one of those events).
  
  In this way, the application does not have to treat these databases
  as a special case.
  
  See L</commit>, L</disconnect> and L</Transactions> for other important
  notes about transactions.
  
  
  =head3 C<Driver>  (handle)
  
  Holds the handle of the parent driver. The only recommended use for this
  is to find the name of the driver using:
  
    $dbh->{Driver}->{Name}
  
  
  =head3 C<Name>  (string)
  
  Holds the "name" of the database. Usually (and recommended to be) the
  same as the "C<dbi:DriverName:...>" string used to connect to the database,
  but with the leading "C<dbi:DriverName:>" removed.
  
  
  =head3 C<Statement>  (string, read-only)
  
  Returns the statement string passed to the most recent L</prepare> method
  called in this database handle, even if that method failed. This is especially
  useful where C<RaiseError> is enabled and the exception handler checks $@
  and sees that a 'prepare' method call failed.
  
  
  =head3 C<RowCacheSize>  (integer)
  
  A hint to the driver indicating the size of the local row cache that the
  application would like the driver to use for future C<SELECT> statements.
  If a row cache is not implemented, then setting C<RowCacheSize> is ignored
  and getting the value returns C<undef>.
  
  Some C<RowCacheSize> values have special meaning, as follows:
  
    0 - Automatically determine a reasonable cache size for each C<SELECT>
    1 - Disable the local row cache
   >1 - Cache this many rows
   <0 - Cache as many rows that will fit into this much memory for each C<SELECT>.
  
  Note that large cache sizes may require a very large amount of memory
  (I<cached rows * maximum size of row>). Also, a large cache will cause
  a longer delay not only for the first fetch, but also whenever the
  cache needs refilling.
  
  See also the L</RowsInCache> statement handle attribute.
  
  =head3 C<Username>  (string)
  
  Returns the username used to connect to the database.
  
  
  =head1 DBI STATEMENT HANDLE OBJECTS
  
  This section lists the methods and attributes associated with DBI
  statement handles.
  
  =head2 Statement Handle Methods
  
  The DBI defines the following methods for use on DBI statement handles:
  
  =head3 C<bind_param>
  
    $sth->bind_param($p_num, $bind_value)
    $sth->bind_param($p_num, $bind_value, \%attr)
    $sth->bind_param($p_num, $bind_value, $bind_type)
  
  The C<bind_param> method takes a copy of $bind_value and associates it
  (binds it) with a placeholder, identified by $p_num, embedded in
  the prepared statement. Placeholders are indicated with question
  mark character (C<?>). For example:
  
    $dbh->{RaiseError} = 1;        # save having to check each method call
    $sth = $dbh->prepare("SELECT name, age FROM people WHERE name LIKE ?");
    $sth->bind_param(1, "John%");  # placeholders are numbered from 1
    $sth->execute;
    DBI::dump_results($sth);
  
  See L</"Placeholders and Bind Values"> for more information.
  
  
  B<Data Types for Placeholders>
  
  The C<\%attr> parameter can be used to hint at the data type the
  placeholder should have. This is rarely needed. Typically, the driver is only
  interested in knowing if the placeholder should be bound as a number or a string.
  
    $sth->bind_param(1, $value, { TYPE => SQL_INTEGER });
  
  As a short-cut for the common case, the data type can be passed
  directly, in place of the C<\%attr> hash reference. This example is
  equivalent to the one above:
  
    $sth->bind_param(1, $value, SQL_INTEGER);
  
  The C<TYPE> value indicates the standard (non-driver-specific) type for
  this parameter. To specify the driver-specific type, the driver may
  support a driver-specific attribute, such as C<{ ora_type =E<gt> 97 }>.
  
  The SQL_INTEGER and other related constants can be imported using
  
    use DBI qw(:sql_types);
  
  See L</"DBI Constants"> for more information.
  
  The data type is 'sticky' in that bind values passed to execute() are bound
  with the data type specified by earlier bind_param() calls, if any.
  Portable applications should not rely on being able to change the data type
  after the first C<bind_param> call.
  
  Perl only has string and number scalar data types. All database types
  that aren't numbers are bound as strings and must be in a format the
  database will understand except where the bind_param() TYPE attribute
  specifies a type that implies a particular format. For example, given:
  
    $sth->bind_param(1, $value, SQL_DATETIME);
  
  the driver should expect $value to be in the ODBC standard SQL_DATETIME
  format, which is 'YYYY-MM-DD HH:MM:SS'. Similarly for SQL_DATE, SQL_TIME etc.
  
  As an alternative to specifying the data type in the C<bind_param> call,
  you can let the driver pass the value as the default type (C<VARCHAR>).
  You can then use an SQL function to convert the type within the statement.
  For example:
  
    INSERT INTO price(code, price) VALUES (?, CONVERT(MONEY,?))
  
  The C<CONVERT> function used here is just an example. The actual function
  and syntax will vary between different databases and is non-portable.
  
  See also L</"Placeholders and Bind Values"> for more information.
  
  
  =head3 C<bind_param_inout>
  
    $rc = $sth->bind_param_inout($p_num, \$bind_value, $max_len)  or die $sth->errstr;
    $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, \%attr)     or ...
    $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, $bind_type) or ...
  
  This method acts like L</bind_param>, but also enables values to be
  updated by the statement. The statement is typically
  a call to a stored procedure. The C<$bind_value> must be passed as a
  reference to the actual value to be used.
  
  Note that unlike L</bind_param>, the C<$bind_value> variable is not
  copied when C<bind_param_inout> is called. Instead, the value in the
  variable is read at the time L</execute> is called.
  
  The additional C<$max_len> parameter specifies the minimum amount of
  memory to allocate to C<$bind_value> for the new value. If the value
  returned from the database is too
  big to fit, then the execution should fail. If unsure what value to use,
  pick a generous length, i.e., a length larger than the longest value that would ever be
  returned.  The only cost of using a larger value than needed is wasted memory.
  
  Undefined values or C<undef> are used to indicate null values.
  See also L</"Placeholders and Bind Values"> for more information.
  
  
  =head3 C<bind_param_array>
  
    $rc = $sth->bind_param_array($p_num, $array_ref_or_value)
    $rc = $sth->bind_param_array($p_num, $array_ref_or_value, \%attr)
    $rc = $sth->bind_param_array($p_num, $array_ref_or_value, $bind_type)
  
  The C<bind_param_array> method is used to bind an array of values
  to a placeholder embedded in the prepared statement which is to be executed
  with L</execute_array>. For example:
  
    $dbh->{RaiseError} = 1;        # save having to check each method call
    $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name, dept) VALUES(?, ?, ?)");
    $sth->bind_param_array(1, [ 'John', 'Mary', 'Tim' ]);
    $sth->bind_param_array(2, [ 'Booth', 'Todd', 'Robinson' ]);
    $sth->bind_param_array(3, "SALES"); # scalar will be reused for each row
    $sth->execute_array( { ArrayTupleStatus => \my @tuple_status } );
  
  The C<%attr> ($bind_type) argument is the same as defined for L</bind_param>.
  Refer to L</bind_param> for general details on using placeholders.
  
  (Note that bind_param_array() can I<not> be used to expand a
  placeholder into a list of values for a statement like "SELECT foo
  WHERE bar IN (?)".  A placeholder can only ever represent one value
  per execution.)
  
  Scalar values, including C<undef>, may also be bound by
  C<bind_param_array>. In which case the same value will be used for each
  L</execute> call. Driver-specific implementations may behave
  differently, e.g., when binding to a stored procedure call, some
  databases may permit mixing scalars and arrays as arguments.
  
  The default implementation provided by DBI (for drivers that have
  not implemented array binding) is to iteratively call L</execute> for
  each parameter tuple provided in the bound arrays.  Drivers may
  provide more optimized implementations using whatever bulk operation
  support the database API provides. The default driver behaviour should
  match the default DBI behaviour, but always consult your driver
  documentation as there may be driver specific issues to consider.
  
  Note that the default implementation currently only supports non-data
  returning statements (INSERT, UPDATE, but not SELECT). Also,
  C<bind_param_array> and L</bind_param> cannot be mixed in the same
  statement execution, and C<bind_param_array> must be used with
  L</execute_array>; using C<bind_param_array> will have no effect
  for L</execute>.
  
  The C<bind_param_array> method was added in DBI 1.22.
  
  =head3 C<execute>
  
    $rv = $sth->execute                or die $sth->errstr;
    $rv = $sth->execute(@bind_values)  or die $sth->errstr;
  
  Perform whatever processing is necessary to execute the prepared
  statement.  An C<undef> is returned if an error occurs.  A successful
  C<execute> always returns true regardless of the number of rows affected,
  even if it's zero (see below). It is always important to check the
  return status of C<execute> (and most other DBI methods) for errors
  if you're not using L</RaiseError>.
  
  For a I<non>-C<SELECT> statement, C<execute> returns the number of rows
  affected, if known. If no rows were affected, then C<execute> returns
  "C<0E0>", which Perl will treat as 0 but will regard as true. Note that it
  is I<not> an error for no rows to be affected by a statement. If the
  number of rows affected is not known, then C<execute> returns -1.
  
  For C<SELECT> statements, execute simply "starts" the query within the
  database engine. Use one of the fetch methods to retrieve the data after
  calling C<execute>.  The C<execute> method does I<not> return the number of
  rows that will be returned by the query (because most databases can't
  tell in advance), it simply returns a true value.
  
  You can tell if the statement was a C<SELECT> statement by checking if
  C<$sth-E<gt>{NUM_OF_FIELDS}> is greater than zero after calling C<execute>.
  
  If any arguments are given, then C<execute> will effectively call
  L</bind_param> for each value before executing the statement.  Values
  bound in this way are usually treated as C<SQL_VARCHAR> types unless
  the driver can determine the correct type (which is rare), or unless
  C<bind_param> (or C<bind_param_inout>) has already been used to
  specify the type.
  
  Note that passing C<execute> an empty array is the same as passing no arguments
  at all, which will execute the statement with previously bound values.
  That's probably not what you want.
  
  If execute() is called on a statement handle that's still active
  ($sth->{Active} is true) then it should effectively call finish()
  to tidy up the previous execution results before starting this new
  execution.
  
  =head3 C<execute_array>
  
    $tuples = $sth->execute_array(\%attr) or die $sth->errstr;
    $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr;
  
    ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr;
    ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr;
  
  Execute the prepared statement once for each parameter tuple
  (group of values) provided either in the @bind_values, or by prior
  calls to L</bind_param_array>, or via a reference passed in \%attr.
  
  When called in scalar context the execute_array() method returns the
  number of tuples executed, or C<undef> if an error occurred.  Like
  execute(), a successful execute_array() always returns true regardless
  of the number of tuples executed, even if it's zero. If there were any
  errors the ArrayTupleStatus array can be used to discover which tuples
  failed and with what errors.
  
  When called in list context the execute_array() method returns two scalars;
  $tuples is the same as calling execute_array() in scalar context and $rows is
  the sum of the number of rows affected for each tuple, if available or
  -1 if the driver cannot determine this.
  If you are doing an update operation the returned rows affected may not be what
  you expect if, for instance, one or more of the tuples affected the same row
  multiple times.  Some drivers may not yet support list context, in which case
  $rows will be undef, or may not be able to provide the number of rows affected
  when performing this batch operation, in which case $rows will be -1.
  
  Bind values for the tuples to be executed may be supplied row-wise
  by an C<ArrayTupleFetch> attribute, or else column-wise in the
  C<@bind_values> argument, or else column-wise by prior calls to
  L</bind_param_array>.
  
  Where column-wise binding is used (via the C<@bind_values> argument
  or calls to bind_param_array()) the maximum number of elements in
  any one of the bound value arrays determines the number of tuples
  executed. Placeholders with fewer values in their parameter arrays
  are treated as if padded with undef (NULL) values.
  
  If a scalar value is bound, instead of an array reference, it is
  treated as a I<variable> length array with all elements having the
  same value. It's does not influence the number of tuples executed,
  so if all bound arrays have zero elements then zero tuples will
  be executed. If I<all> bound values are scalars then one tuple
  will be executed, making execute_array() act just like execute().
  
  The C<ArrayTupleFetch> attribute can be used to specify a reference
  to a subroutine that will be called to provide the bind values for
  each tuple execution. The subroutine should return an reference to
  an array which contains the appropriate number of bind values, or
  return an undef if there is no more data to execute.
  
  As a convenience, the C<ArrayTupleFetch> attribute can also be
  used to specify a statement handle. In which case the fetchrow_arrayref()
  method will be called on the given statement handle in order to
  provide the bind values for each tuple execution.
  
  The values specified via bind_param_array() or the @bind_values
  parameter may be either scalars, or arrayrefs.  If any C<@bind_values>
  are given, then C<execute_array> will effectively call L</bind_param_array>
  for each value before executing the statement.  Values bound in
  this way are usually treated as C<SQL_VARCHAR> types unless the
  driver can determine the correct type (which is rare), or unless
  C<bind_param>, C<bind_param_inout>, C<bind_param_array>, or
  C<bind_param_inout_array> has already been used to specify the type.
  See L</bind_param_array> for details.
  
  The C<ArrayTupleStatus> attribute can be used to specify a
  reference to an array which will receive the execute status of each
  executed parameter tuple. Note the C<ArrayTupleStatus> attribute was
  mandatory until DBI 1.38.
  
  For tuples which are successfully executed, the element at the same
  ordinal position in the status array is the resulting rowcount.
  If the execution of a tuple causes an error, then the corresponding
  status array element will be set to a reference to an array containing
  the error code and error string set by the failed execution.
  
  If B<any> tuple execution returns an error, C<execute_array> will
  return C<undef>. In that case, the application should inspect the
  status array to determine which parameter tuples failed.
  Some databases may not continue executing tuples beyond the first
  failure. In this case the status array will either hold fewer
  elements, or the elements beyond the failure will be undef.
  
  If all parameter tuples are successfully executed, C<execute_array>
  returns the number tuples executed.  If no tuples were executed,
  then execute_array() returns "C<0E0>", just like execute() does,
  which Perl will treat as 0 but will regard as true.
  
  For example:
  
    $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name) VALUES (?, ?)");
    my $tuples = $sth->execute_array(
        { ArrayTupleStatus => \my @tuple_status },
        \@first_names,
        \@last_names,
    );
    if ($tuples) {
        print "Successfully inserted $tuples records\n";
    }
    else {
        for my $tuple (0..@last_names-1) {
            my $status = $tuple_status[$tuple];
            $status = [0, "Skipped"] unless defined $status;
            next unless ref $status;
            printf "Failed to insert (%s, %s): %s\n",
                $first_names[$tuple], $last_names[$tuple], $status->[1];
        }
    }
  
  Support for data returning statements such as SELECT is driver-specific
  and subject to change. At present, the default implementation
  provided by DBI only supports non-data returning statements.
  
  Transaction semantics when using array binding are driver and
  database specific.  If C<AutoCommit> is on, the default DBI
  implementation will cause each parameter tuple to be individually
  committed (or rolled back in the event of an error). If C<AutoCommit>
  is off, the application is responsible for explicitly committing
  the entire set of bound parameter tuples.  Note that different
  drivers and databases may have different behaviours when some
  parameter tuples cause failures. In some cases, the driver or
  database may automatically rollback the effect of all prior parameter
  tuples that succeeded in the transaction; other drivers or databases
  may retain the effect of prior successfully executed parameter
  tuples. Be sure to check your driver and database for its specific
  behaviour.
  
  Note that, in general, performance will usually be better with
  C<AutoCommit> turned off, and using explicit C<commit> after each
  C<execute_array> call.
  
  The C<execute_array> method was added in DBI 1.22, and ArrayTupleFetch
  was added in 1.36.
  
  =head3 C<execute_for_fetch>
  
    $tuples = $sth->execute_for_fetch($fetch_tuple_sub);
    $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status);
  
    ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub);
    ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status);
  
  The execute_for_fetch() method is used to perform bulk operations
  and is most often used via the execute_array() method, not directly.
  
  The fetch subroutine, referenced by $fetch_tuple_sub, is expected
  to return a reference to an array (known as a 'tuple') or undef.
  
  The execute_for_fetch() method calls $fetch_tuple_sub, without any
  parameters, until it returns a false value. Each tuple returned is
  used to provide bind values for an $sth->execute(@$tuple) call.
  
  In scalar context execute_for_fetch() returns C<undef> if there were any
  errors and the number of tuples executed otherwise. Like execute() and
  execute_array() a zero is returned as "0E0" so execute_for_fetch() is
  only false on error.  If there were any errors the @tuple_status array
  can be used to discover which tuples failed and with what errors.
  
  When called in list context execute_for_fetch() returns two scalars;
  $tuples is the same as calling execute_for_fetch() in scalar context and $rows is
  the sum of the number of rows affected for each tuple, if available or -1
  if the driver cannot determine this.
  If you are doing an update operation the returned rows affected may not be what
  you expect if, for instance, one or more of the tuples affected the same row
  multiple times.  Some drivers may not yet support list context, in which case
  $rows will be undef, or may not be able to provide the number of rows affected
  when performing this batch operation, in which case $rows will be -1.
  
  If \@tuple_status is passed then the execute_for_fetch method uses
  it to return status information. The tuple_status array holds one
  element per tuple. If the corresponding execute() did not fail then
  the element holds the return value from execute(), which is typically
  a row count. If the execute() did fail then the element holds a
  reference to an array containing ($sth->err, $sth->errstr, $sth->state).
  
  If the driver detects an error that it knows means no further tuples can be
  executed then it may return, with an error status, even though $fetch_tuple_sub
  may still have more tuples to be executed.
  
  Although each tuple returned by $fetch_tuple_sub is effectively used
  to call $sth->execute(@$tuple_array_ref) the exact timing may vary.
  Drivers are free to accumulate sets of tuples to pass to the
  database server in bulk group operations for more efficient execution.
  However, the $fetch_tuple_sub is specifically allowed to return
  the same array reference each time (which is what fetchrow_arrayref()
  usually does).
  
  For example:
  
    my $sel = $dbh1->prepare("select foo, bar from table1");
    $sel->execute;
  
    my $ins = $dbh2->prepare("insert into table2 (foo, bar) values (?,?)");
    my $fetch_tuple_sub = sub { $sel->fetchrow_arrayref };
  
    my @tuple_status;
    $rc = $ins->execute_for_fetch($fetch_tuple_sub, \@tuple_status);
    my @errors = grep { ref $_ } @tuple_status;
  
  Similarly, if you already have an array containing the data rows
  to be processed you'd use a subroutine to shift off and return
  each array ref in turn:
  
    $ins->execute_for_fetch( sub { shift @array_of_arrays }, \@tuple_status);
  
  The C<execute_for_fetch> method was added in DBI 1.38.
  
  
  =head3 C<fetchrow_arrayref>
  
    $ary_ref = $sth->fetchrow_arrayref;
    $ary_ref = $sth->fetch;    # alias
  
  Fetches the next row of data and returns a reference to an array
  holding the field values.  Null fields are returned as C<undef>
  values in the array.
  This is the fastest way to fetch data, particularly if used with
  C<$sth-E<gt>bind_columns>.
  
  If there are no more rows or if an error occurs, then C<fetchrow_arrayref>
  returns an C<undef>. You should check C<$sth-E<gt>err> afterwards (or use the
  C<RaiseError> attribute) to discover if the C<undef> returned was due to an
  error.
  
  Note that the same array reference is returned for each fetch, so don't
  store the reference and then use it after a later fetch.  Also, the
  elements of the array are also reused for each row, so take care if you
  want to take a reference to an element. See also L</bind_columns>.
  
  =head3 C<fetchrow_array>
  
   @ary = $sth->fetchrow_array;
  
  An alternative to C<fetchrow_arrayref>. Fetches the next row of data
  and returns it as a list containing the field values.  Null fields
  are returned as C<undef> values in the list.
  
  If there are no more rows or if an error occurs, then C<fetchrow_array>
  returns an empty list. You should check C<$sth-E<gt>err> afterwards (or use
  the C<RaiseError> attribute) to discover if the empty list returned was
  due to an error.
  
  If called in a scalar context for a statement handle that has more
  than one column, it is undefined whether the driver will return
  the value of the first column or the last. So don't do that.
  Also, in a scalar context, an C<undef> is returned if there are no
  more rows or if an error occurred. That C<undef> can't be distinguished
  from an C<undef> returned because the first field value was NULL.
  For these reasons you should exercise some caution if you use
  C<fetchrow_array> in a scalar context.
  
  =head3 C<fetchrow_hashref>
  
   $hash_ref = $sth->fetchrow_hashref;
   $hash_ref = $sth->fetchrow_hashref($name);
  
  An alternative to C<fetchrow_arrayref>. Fetches the next row of data
  and returns it as a reference to a hash containing field name and field
  value pairs.  Null fields are returned as C<undef> values in the hash.
  
  If there are no more rows or if an error occurs, then C<fetchrow_hashref>
  returns an C<undef>. You should check C<$sth-E<gt>err> afterwards (or use the
  C<RaiseError> attribute) to discover if the C<undef> returned was due to an
  error.
  
  The optional C<$name> parameter specifies the name of the statement handle
  attribute. For historical reasons it defaults to "C<NAME>", however using
  either "C<NAME_lc>" or "C<NAME_uc>" is recommended for portability.
  
  The keys of the hash are the same names returned by C<$sth-E<gt>{$name}>. If
  more than one field has the same name, there will only be one entry in the
  returned hash for those fields, so statements like "C<select foo, foo from bar>"
  will return only a single key from C<fetchrow_hashref>. In these cases use
  column aliases or C<fetchrow_arrayref>.  Note that it is the database server
  (and not the DBD implementation) which provides the I<name> for fields
  containing functions like "C<count(*)>" or "C<max(c_foo)>" and they may clash
  with existing column names (most databases don't care about duplicate column
  names in a result-set). If you want these to return as unique names that are
  the same across databases, use I<aliases>, as in "C<select count(*) as cnt>"
  or "C<select max(c_foo) mx_foo, ...>" depending on the syntax your database
  supports.
  
  Because of the extra work C<fetchrow_hashref> and Perl have to perform, it
  is not as efficient as C<fetchrow_arrayref> or C<fetchrow_array>.
  
  By default a reference to a new hash is returned for each row.
  It is likely that a future version of the DBI will support an
  attribute which will enable the same hash to be reused for each
  row. This will give a significant performance boost, but it won't
  be enabled by default because of the risk of breaking old code.
  
  
  =head3 C<fetchall_arrayref>
  
    $tbl_ary_ref = $sth->fetchall_arrayref;
    $tbl_ary_ref = $sth->fetchall_arrayref( $slice );
    $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows  );
  
  The C<fetchall_arrayref> method can be used to fetch all the data to be
  returned from a prepared and executed statement handle. It returns a
  reference to an array that contains one reference per row.
  
  If there are no rows to return, C<fetchall_arrayref> returns a reference
  to an empty array. If an error occurs, C<fetchall_arrayref> returns the
  data fetched thus far, which may be none.  You should check C<$sth-E<gt>err>
  afterwards (or use the C<RaiseError> attribute) to discover if the data is
  complete or was truncated due to an error.
  
  If $slice is an array reference, C<fetchall_arrayref> uses L</fetchrow_arrayref>
  to fetch each row as an array ref. If the $slice array is not empty
  then it is used as a slice to select individual columns by perl array
  index number (starting at 0, unlike column and parameter numbers which
  start at 1).
  
  With no parameters, or if $slice is undefined, C<fetchall_arrayref>
  acts as if passed an empty array ref.
  
  If $slice is a hash reference, C<fetchall_arrayref> uses L</fetchrow_hashref>
  to fetch each row as a hash reference. If the $slice hash is empty then
  fetchrow_hashref() is simply called in a tight loop and the keys in the hashes
  have whatever name lettercase is returned by default from fetchrow_hashref.
  (See L</FetchHashKeyName> attribute.) If the $slice hash is not
  empty, then it is used as a slice to select individual columns by
  name.  The values of the hash should be set to 1.  The key names
  of the returned hashes match the letter case of the names in the
  parameter hash, regardless of the L</FetchHashKeyName> attribute.
  
  For example, to fetch just the first column of every row:
  
    $tbl_ary_ref = $sth->fetchall_arrayref([0]);
  
  To fetch the second to last and last column of every row:
  
    $tbl_ary_ref = $sth->fetchall_arrayref([-2,-1]);
  
  To fetch all fields of every row as a hash ref:
  
    $tbl_ary_ref = $sth->fetchall_arrayref({});
  
  To fetch only the fields called "foo" and "bar" of every row as a hash ref
  (with keys named "foo" and "BAR"):
  
    $tbl_ary_ref = $sth->fetchall_arrayref({ foo=>1, BAR=>1 });
  
  The first two examples return a reference to an array of array refs.
  The third and forth return a reference to an array of hash refs.
  
  If $max_rows is defined and greater than or equal to zero then it
  is used to limit the number of rows fetched before returning.
  fetchall_arrayref() can then be called again to fetch more rows.
  This is especially useful when you need the better performance of
  fetchall_arrayref() but don't have enough memory to fetch and return
  all the rows in one go.
  
  Here's an example (assumes RaiseError is enabled):
  
    my $rows = []; # cache for batches of rows
    while( my $row = ( shift(@$rows) || # get row from cache, or reload cache:
                       shift(@{$rows=$sth->fetchall_arrayref(undef,10_000)||[]}) )
    ) {
      ...
    }
  
  That I<might> be the fastest way to fetch and process lots of rows using the DBI,
  but it depends on the relative cost of method calls vs memory allocation.
  
  A standard C<while> loop with column binding is often faster because
  the cost of allocating memory for the batch of rows is greater than
  the saving by reducing method calls. It's possible that the DBI may
  provide a way to reuse the memory of a previous batch in future, which
  would then shift the balance back towards fetchall_arrayref().
  
  
  =head3 C<fetchall_hashref>
  
    $hash_ref = $sth->fetchall_hashref($key_field);
  
  The C<fetchall_hashref> method can be used to fetch all the data to be
  returned from a prepared and executed statement handle. It returns a reference
  to a hash containing a key for each distinct value of the $key_field column
  that was fetched. For each key the corresponding value is a reference to a hash
  containing all the selected columns and their values, as returned by
  C<fetchrow_hashref()>.
  
  If there are no rows to return, C<fetchall_hashref> returns a reference
  to an empty hash. If an error occurs, C<fetchall_hashref> returns the
  data fetched thus far, which may be none.  You should check
  C<$sth-E<gt>err> afterwards (or use the C<RaiseError> attribute) to
  discover if the data is complete or was truncated due to an error.
  
  The $key_field parameter provides the name of the field that holds the
  value to be used for the key for the returned hash.  For example:
  
    $dbh->{FetchHashKeyName} = 'NAME_lc';
    $sth = $dbh->prepare("SELECT FOO, BAR, ID, NAME, BAZ FROM TABLE");
    $sth->execute;
    $hash_ref = $sth->fetchall_hashref('id');
    print "Name for id 42 is $hash_ref->{42}->{name}\n";
  
  The $key_field parameter can also be specified as an integer column
  number (counting from 1).  If $key_field doesn't match any column in
  the statement, as a name first then as a number, then an error is
  returned.
  
  For queries returning more than one 'key' column, you can specify
  multiple column names by passing $key_field as a reference to an
  array containing one or more key column names (or index numbers).
  For example:
  
    $sth = $dbh->prepare("SELECT foo, bar, baz FROM table");
    $sth->execute;
    $hash_ref = $sth->fetchall_hashref( [ qw(foo bar) ] );
    print "For foo 42 and bar 38, baz is $hash_ref->{42}->{38}->{baz}\n";
  
  The fetchall_hashref() method is normally used only where the key
  fields values for each row are unique.  If multiple rows are returned
  with the same values for the key fields then later rows overwrite
  earlier ones.
  
  =head3 C<finish>
  
    $rc  = $sth->finish;
  
  Indicate that no more data will be fetched from this statement handle
  before it is either executed again or destroyed.  The C<finish> method
  is rarely needed, and frequently overused, but can sometimes be
  helpful in a few very specific situations to allow the server to free
  up resources (such as sort buffers).
  
  When all the data has been fetched from a C<SELECT> statement, the
  driver should automatically call C<finish> for you. So you should
  I<not> normally need to call it explicitly I<except> when you know
  that you've not fetched all the data from a statement handle.
  The most common example is when you only want to fetch one row,
  but in that case the C<selectrow_*> methods are usually better anyway.
  Adding calls to C<finish> after each fetch loop is a common mistake,
  don't do it, it can mask genuine problems like uncaught fetch errors.
  
  Consider a query like:
  
    SELECT foo FROM table WHERE bar=? ORDER BY foo
  
  where you want to select just the first (smallest) "foo" value from a
  very large table. When executed, the database server will have to use
  temporary buffer space to store the sorted rows. If, after executing
  the handle and selecting one row, the handle won't be re-executed for
  some time and won't be destroyed, the C<finish> method can be used to tell
  the server that the buffer space can be freed.
  
  Calling C<finish> resets the L</Active> attribute for the statement.  It
  may also make some statement handle attributes (such as C<NAME> and C<TYPE>)
  unavailable if they have not already been accessed (and thus cached).
  
  The C<finish> method does not affect the transaction status of the
  database connection.  It has nothing to do with transactions. It's mostly an
  internal "housekeeping" method that is rarely needed.
  See also L</disconnect> and the L</Active> attribute.
  
  The C<finish> method should have been called C<discard_pending_rows>.
  
  
  =head3 C<rows>
  
    $rv = $sth->rows;
  
  Returns the number of rows affected by the last row affecting command,
  or -1 if the number of rows is not known or not available.
  
  Generally, you can only rely on a row count after a I<non>-C<SELECT>
  C<execute> (for some specific operations like C<UPDATE> and C<DELETE>), or
  after fetching all the rows of a C<SELECT> statement.
  
  For C<SELECT> statements, it is generally not possible to know how many
  rows will be returned except by fetching them all.  Some drivers will
  return the number of rows the application has fetched so far, but
  others may return -1 until all rows have been fetched.  So use of the
  C<rows> method or C<$DBI::rows> with C<SELECT> statements is not
  recommended.
  
  One alternative method to get a row count for a C<SELECT> is to execute a
  "SELECT COUNT(*) FROM ..." SQL statement with the same "..." as your
  query and then fetch the row count from that.
  
  
  =head3 C<bind_col>
  
    $rc = $sth->bind_col($column_number, \$var_to_bind);
    $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr );
    $rc = $sth->bind_col($column_number, \$var_to_bind, $bind_type );
  
  Binds a Perl variable and/or some attributes to an output column
  (field) of a C<SELECT> statement.  Column numbers count up from 1.
  You do not need to bind output columns in order to fetch data.
  For maximum portability between drivers, bind_col() should be called
  after execute() and not before.
  See also C<bind_columns> for an example.
  
  The binding is performed at a low level using Perl aliasing.
  Whenever a row is fetched from the database $var_to_bind appears
  to be automatically updated simply because it now refers to the same
  memory location as the corresponding column value.  This makes using
  bound variables very efficient.
  Binding a tied variable doesn't work, currently.
  
  The L</bind_param> method
  performs a similar, but opposite, function for input variables.
  
  B<Data Types for Column Binding>
  
  The C<\%attr> parameter can be used to hint at the data type
  formatting the column should have. For example, you can use:
  
    $sth->bind_col(1, undef, { TYPE => SQL_DATETIME });
  
  to specify that you'd like the column (which presumably is some
  kind of datetime type) to be returned in the standard format for
  SQL_DATETIME, which is 'YYYY-MM-DD HH:MM:SS', rather than the
  native formatting the database would normally use.
  
  There's no $var_to_bind in that example to emphasize the point
  that bind_col() works on the underlying column and not just
  a particular bound variable.
  
  As a short-cut for the common case, the data type can be passed
  directly, in place of the C<\%attr> hash reference. This example is
  equivalent to the one above:
  
    $sth->bind_col(1, undef, SQL_DATETIME);
  
  The C<TYPE> value indicates the standard (non-driver-specific) type for
  this parameter. To specify the driver-specific type, the driver may
  support a driver-specific attribute, such as C<{ ora_type =E<gt> 97 }>.
  
  The SQL_DATETIME and other related constants can be imported using
  
    use DBI qw(:sql_types);
  
  See L</"DBI Constants"> for more information.
  
  Few drivers support specifying a data type via a C<bind_col> call
  (most will simply ignore the data type). Fewer still allow the data
  type to be altered once set.
  
  The TYPE attribute for bind_col() was first specified in DBI 1.41.
  
  From DBI 1.611, drivers can use the C<TYPE> attribute to attempt to
  cast the bound scalar to a perl type which more closely matches
  C<TYPE>. At present DBI supports C<SQL_INTEGER>, C<SQL_DOUBLE> and
  C<SQL_NUMERIC>. See L</sql_type_cast> for details of how types are
  cast.
  
  B<Other attributes for Column Binding>
  
  The C<\%attr> parameter may also contain the following attributes:
  
  =over
  
  =item C<StrictlyTyped>
  
  If a C<TYPE> attribute is passed to bind_col, then the driver will
  attempt to change the bound perl scalar to match the type more
  closely. If the bound value cannot be cast to the requested C<TYPE>
  then by default it is left untouched and no error is generated. If you
  specify C<StrictlyTyped> as 1 and the cast fails, this will generate
  an error.
  
  This attribute was first added in DBI 1.611. When 1.611 was released
  few drivers actually supported this attribute but DBD::Oracle and
  DBD::ODBC should from versions 1.24.
  
  =item C<DiscardString>
  
  When the C<TYPE> attribute is passed to L</bind_col> and the driver
  successfully casts the bound perl scalar to a non-string type
  then if C<DiscardString> is set to 1, the string portion of the
  scalar will be discarded. By default, C<DiscardString> is not set.
  
  This attribute was first added in DBI 1.611. When 1.611 was released
  few drivers actually supported this attribute but DBD::Oracle and
  DBD::ODBC should from versions 1.24.
  
  =back
  
  
  =head3 C<bind_columns>
  
    $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
  
  Calls L</bind_col> for each column of the C<SELECT> statement.
  
  The list of references should have the same number of elements as the number of
  columns in the C<SELECT> statement. If it doesn't then C<bind_columns> will
  bind the elements given, up to the number of columns, and then return an error.
  
  For maximum portability between drivers, bind_columns() should be called
  after execute() and not before.
  
  For example:
  
    $dbh->{RaiseError} = 1; # do this, or check every call for errors
    $sth = $dbh->prepare(q{ SELECT region, sales FROM sales_by_region });
    $sth->execute;
    my ($region, $sales);
  
    # Bind Perl variables to columns:
    $rv = $sth->bind_columns(\$region, \$sales);
  
    # you can also use Perl's \(...) syntax (see perlref docs):
    #     $sth->bind_columns(\($region, $sales));
  
    # Column binding is the most efficient way to fetch data
    while ($sth->fetch) {
        print "$region: $sales\n";
    }
  
  For compatibility with old scripts, the first parameter will be
  ignored if it is C<undef> or a hash reference.
  
  Here's a more fancy example that binds columns to the values I<inside>
  a hash (thanks to H.Merijn Brand):
  
    $sth->execute;
    my %row;
    $sth->bind_columns( \( @row{ @{$sth->{NAME_lc} } } ));
    while ($sth->fetch) {
        print "$row{region}: $row{sales}\n";
    }
  
  
  =head3 C<dump_results>
  
    $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh);
  
  Fetches all the rows from C<$sth>, calls C<DBI::neat_list> for each row, and
  prints the results to C<$fh> (defaults to C<STDOUT>) separated by C<$lsep>
  (default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35.
  
  This method is designed as a handy utility for prototyping and
  testing queries. Since it uses L</neat_list> to
  format and edit the string for reading by humans, it is not recommended
  for data transfer applications.
  
  
  =head2 Statement Handle Attributes
  
  This section describes attributes specific to statement handles. Most
  of these attributes are read-only.
  
  Changes to these statement handle attributes do not affect any other
  existing or future statement handles.
  
  Attempting to set or get the value of an unknown attribute generates a warning,
  except for private driver specific attributes (which all have names
  starting with a lowercase letter).
  
  Example:
  
    ... = $h->{NUM_OF_FIELDS};	# get/read
  
  Some drivers cannot provide valid values for some or all of these
  attributes until after C<$sth-E<gt>execute> has been successfully
  called. Typically the attribute will be C<undef> in these situations.
  
  Some attributes, like NAME, are not appropriate to some types of
  statement, like SELECT. Typically the attribute will be C<undef>
  in these situations.
  
  For drivers which support stored procedures and multiple result sets
  (see more_results) these attributes relate to the I<current> result set.
  
  See also L</finish> to learn more about the effect it
  may have on some attributes.
  
  =head3 C<NUM_OF_FIELDS>  (integer, read-only)
  
  Number of fields (columns) in the data the prepared statement may return.
  Statements that don't return rows of data, like C<DELETE> and C<CREATE>
  set C<NUM_OF_FIELDS> to 0 (though it may be undef in some drivers).
  
  
  =head3 C<NUM_OF_PARAMS>  (integer, read-only)
  
  The number of parameters (placeholders) in the prepared statement.
  See SUBSTITUTION VARIABLES below for more details.
  
  
  =head3 C<NAME>  (array-ref, read-only)
  
  Returns a reference to an array of field names for each column. The
  names may contain spaces but should not be truncated or have any
  trailing space. Note that the names have the letter case (upper, lower
  or mixed) as returned by the driver being used. Portable applications
  should use L</NAME_lc> or L</NAME_uc>.
  
    print "First column name: $sth->{NAME}->[0]\n";
  
  Also note that the name returned for (aggregate) functions like C<count(*)>
  or C<max(c_foo)> is determined by the database server and not by C<DBI> or
  the C<DBD> backend.
  
  =head3 C<NAME_lc>  (array-ref, read-only)
  
  Like L</NAME> but always returns lowercase names.
  
  =head3 C<NAME_uc>  (array-ref, read-only)
  
  Like L</NAME> but always returns uppercase names.
  
  =head3 C<NAME_hash>  (hash-ref, read-only)
  
  =head3 C<NAME_lc_hash>  (hash-ref, read-only)
  
  =head3 C<NAME_uc_hash>  (hash-ref, read-only)
  
  The C<NAME_hash>, C<NAME_lc_hash>, and C<NAME_uc_hash> attributes
  return column name information as a reference to a hash.
  
  The keys of the hash are the names of the columns.  The letter case of
  the keys corresponds to the letter case returned by the C<NAME>,
  C<NAME_lc>, and C<NAME_uc> attributes respectively (as described above).
  
  The value of each hash entry is the perl index number of the
  corresponding column (counting from 0). For example:
  
    $sth = $dbh->prepare("select Id, Name from table");
    $sth->execute;
    @row = $sth->fetchrow_array;
    print "Name $row[ $sth->{NAME_lc_hash}{name} ]\n";
  
  
  =head3 C<TYPE>  (array-ref, read-only)
  
  Returns a reference to an array of integer values for each
  column. The value indicates the data type of the corresponding column.
  
  The values correspond to the international standards (ANSI X3.135
  and ISO/IEC 9075) which, in general terms, means ODBC. Driver-specific
  types that don't exactly match standard types should generally return
  the same values as an ODBC driver supplied by the makers of the
  database. That might include private type numbers in ranges the vendor
  has officially registered with the ISO working group:
  
    ftp://sqlstandards.org/SC32/SQL_Registry/
  
  Where there's no vendor-supplied ODBC driver to be compatible with,
  the DBI driver can use type numbers in the range that is now
  officially reserved for use by the DBI: -9999 to -9000.
  
  All possible values for C<TYPE> should have at least one entry in the
  output of the C<type_info_all> method (see L</type_info_all>).
  
  =head3 C<PRECISION>  (array-ref, read-only)
  
  Returns a reference to an array of integer values for each column.
  
  For numeric columns, the value is the maximum number of digits
  (without considering a sign character or decimal point). Note that
  the "display size" for floating point types (REAL, FLOAT, DOUBLE)
  can be up to 7 characters greater than the precision (for the
  sign + decimal point + the letter E + a sign + 2 or 3 digits).
  
  For any character type column the value is the OCTET_LENGTH,
  in other words the number of bytes, not characters.
  
  (More recent standards refer to this as COLUMN_SIZE but we stick
  with PRECISION for backwards compatibility.)
  
  =head3 C<SCALE>  (array-ref, read-only)
  
  Returns a reference to an array of integer values for each column.
  NULL (C<undef>) values indicate columns where scale is not applicable.
  
  =head3 C<NULLABLE>  (array-ref, read-only)
  
  Returns a reference to an array indicating the possibility of each
  column returning a null.  Possible values are C<0>
  (or an empty string) = no, C<1> = yes, C<2> = unknown.
  
    print "First column may return NULL\n" if $sth->{NULLABLE}->[0];
  
  
  =head3 C<CursorName>  (string, read-only)
  
  Returns the name of the cursor associated with the statement handle, if
  available. If not available or if the database driver does not support the
  C<"where current of ..."> SQL syntax, then it returns C<undef>.
  
  
  =head3 C<Database>  (dbh, read-only)
  
  Returns the parent $dbh of the statement handle.
  
  
  =head3 C<Statement>  (string, read-only)
  
  Returns the statement string passed to the L</prepare> method.
  
  
  =head3 C<ParamValues>  (hash ref, read-only)
  
  Returns a reference to a hash containing the values currently bound
  to placeholders.  The keys of the hash are the 'names' of the
  placeholders, typically integers starting at 1.  Returns undef if
  not supported by the driver.
  
  See L</ShowErrorStatement> for an example of how this is used.
  
  * Keys:
  
  If the driver supports C<ParamValues> but no values have been bound
  yet then the driver should return a hash with placeholders names
  in the keys but all the values undef, but some drivers may return
  a ref to an empty hash because they can't pre-determine the names.
  
  It is possible that the keys in the hash returned by C<ParamValues>
  are not exactly the same as those implied by the prepared statement.
  For example, DBD::Oracle translates 'C<?>' placeholders into 'C<:pN>'
  where N is a sequence number starting at 1.
  
  * Values:
  
  It is possible that the values in the hash returned by C<ParamValues>
  are not I<exactly> the same as those passed to bind_param() or execute().
  The driver may have slightly modified values in some way based on the
  TYPE the value was bound with. For example a floating point value
  bound as an SQL_INTEGER type may be returned as an integer.
  The values returned by C<ParamValues> can be passed to another
  bind_param() method with the same TYPE and will be seen by the
  database as the same value. See also L</ParamTypes> below.
  
  The C<ParamValues> attribute was added in DBI 1.28.
  
  =head3 C<ParamTypes>  (hash ref, read-only)
  
  Returns a reference to a hash containing the type information
  currently bound to placeholders.
  Returns undef if not supported by the driver.
  
  * Keys:
  
  See L</ParamValues> above.
  
  * Values:
  
  The hash values are hashrefs of type information in the same form as that
  passed to the various bind_param() methods (See L</bind_param> for the format
  and values).
  
  It is possible that the values in the hash returned by C<ParamTypes>
  are not exactly the same as those passed to bind_param() or execute().
  Param attributes specified using the abreviated form, like this:
  
      $sth->bind_param(1, SQL_INTEGER);
  
  are returned in the expanded form, as if called like this:
  
      $sth->bind_param(1, { TYPE => SQL_INTEGER });
  
  The driver may have modified the type information in some way based
  on the bound values, other hints provided by the prepare()'d
  SQL statement, or alternate type mappings required by the driver or target
  database system. The driver may also add private keys (with names beginning
  with the drivers reserved prefix, e.g., odbc_xxx).
  
  * Example:
  
  The keys and values in the returned hash can be passed to the various
  bind_param() methods to effectively reproduce a previous param binding.
  For example:
  
    # assuming $sth1 is a previously prepared statement handle
    my $sth2 = $dbh->prepare( $sth1->{Statement} );
    my $ParamValues = $sth1->{ParamValues} || {};
    my $ParamTypes  = $sth1->{ParamTypes}  || {};
    $sth2->bind_param($_, $PV->{$_} $PT->{$_})
      for keys %{ %$PV, %$PT };
    $sth2->execute();
  
  The C<ParamTypes> attribute was added in DBI 1.49. Implementation
  is the responsibility of individual drivers; the DBI layer default
  implementation simply returns undef.
  
  
  =head3 C<ParamArrays>  (hash ref, read-only)
  
  Returns a reference to a hash containing the values currently bound to
  placeholders with L</execute_array> or L</bind_param_array>.  The
  keys of the hash are the 'names' of the placeholders, typically
  integers starting at 1.  Returns undef if not supported by the driver
  or no arrays of parameters are bound.
  
  Each key value is an array reference containing a list of the bound
  parameters for that column.
  
  For example:
  
    $sth = $dbh->prepare("INSERT INTO staff (id, name) values (?,?)");
    $sth->execute_array({},[1,2], ['fred','dave']);
    if ($sth->{ParamArrays}) {
        foreach $param (keys %{$sth->{ParamArrays}}) {
  	  printf "Parameters for %s : %s\n", $param,
  	  join(",", @{$sth->{ParamArrays}->{$param}});
        }
    }
  
  It is possible that the values in the hash returned by C<ParamArrays>
  are not I<exactly> the same as those passed to L</bind_param_array> or
  L</execute_array>.  The driver may have slightly modified values in some
  way based on the TYPE the value was bound with. For example a floating
  point value bound as an SQL_INTEGER type may be returned as an
  integer.
  
  It is also possible that the keys in the hash returned by
  C<ParamArrays> are not exactly the same as those implied by the
  prepared statement.  For example, DBD::Oracle translates 'C<?>'
  placeholders into 'C<:pN>' where N is a sequence number starting at 1.
  
  =head3 C<RowsInCache>  (integer, read-only)
  
  If the driver supports a local row cache for C<SELECT> statements, then
  this attribute holds the number of un-fetched rows in the cache. If the
  driver doesn't, then it returns C<undef>. Note that some drivers pre-fetch
  rows on execute, whereas others wait till the first fetch.
  
  See also the L</RowCacheSize> database handle attribute.
  
  =head1 FURTHER INFORMATION
  
  =head2 Catalog Methods
  
  An application can retrieve metadata information from the DBMS by issuing
  appropriate queries on the views of the Information Schema. Unfortunately,
  C<INFORMATION_SCHEMA> views are seldom supported by the DBMS.
  Special methods (catalog methods) are available to return result sets
  for a small but important portion of that metadata:
  
    column_info
    foreign_key_info
    primary_key_info
    table_info
    statistics_info
  
  All catalog methods accept arguments in order to restrict the result sets.
  Passing C<undef> to an optional argument does not constrain the search for
  that argument.
  However, an empty string ('') is treated as a regular search criteria
  and will only match an empty value.
  
  B<Note>: SQL/CLI and ODBC differ in the handling of empty strings. An
  empty string will not restrict the result set in SQL/CLI.
  
  Most arguments in the catalog methods accept only I<ordinary values>, e.g.
  the arguments of C<primary_key_info()>.
  Such arguments are treated as a literal string, i.e. the case is significant
  and quote characters are taken literally.
  
  Some arguments in the catalog methods accept I<search patterns> (strings
  containing '_' and/or '%'), e.g. the C<$table> argument of C<column_info()>.
  Passing '%' is equivalent to leaving the argument C<undef>.
  
  B<Caveat>: The underscore ('_') is valid and often used in SQL identifiers.
  Passing such a value to a search pattern argument may return more rows than
  expected!
  To include pattern characters as literals, they must be preceded by an
  escape character which can be achieved with
  
    $esc = $dbh->get_info( 14 );  # SQL_SEARCH_PATTERN_ESCAPE
    $search_pattern =~ s/([_%])/$esc$1/g;
  
  The ODBC and SQL/CLI specifications define a way to change the default
  behaviour described above: All arguments (except I<list value arguments>)
  are treated as I<identifier> if the C<SQL_ATTR_METADATA_ID> attribute is
  set to C<SQL_TRUE>.
  I<Quoted identifiers> are very similar to I<ordinary values>, i.e. their
  body (the string within the quotes) is interpreted literally.
  I<Unquoted identifiers> are compared in UPPERCASE.
  
  The DBI (currently) does not support the C<SQL_ATTR_METADATA_ID> attribute,
  i.e. it behaves like an ODBC driver where C<SQL_ATTR_METADATA_ID> is set to
  C<SQL_FALSE>.
  
  
  =head2 Transactions
  
  Transactions are a fundamental part of any robust database system. They
  protect against errors and database corruption by ensuring that sets of
  related changes to the database take place in atomic (indivisible,
  all-or-nothing) units.
  
  This section applies to databases that support transactions and where
  C<AutoCommit> is off.  See L</AutoCommit> for details of using C<AutoCommit>
  with various types of databases.
  
  The recommended way to implement robust transactions in Perl
  applications is to use C<RaiseError> and S<C<eval { ... }>>
  (which is very fast, unlike S<C<eval "...">>). For example:
  
    $dbh->{AutoCommit} = 0;  # enable transactions, if possible
    $dbh->{RaiseError} = 1;
    eval {
        foo(...)        # do lots of work here
        bar(...)        # including inserts
        baz(...)        # and updates
        $dbh->commit;   # commit the changes if we get this far
    };
    if ($@) {
        warn "Transaction aborted because $@";
        # now rollback to undo the incomplete changes
        # but do it in an eval{} as it may also fail
        eval { $dbh->rollback };
        # add other application on-error-clean-up code here
    }
  
  If the C<RaiseError> attribute is not set, then DBI calls would need to be
  manually checked for errors, typically like this:
  
    $h->method(@args) or die $h->errstr;
  
  With C<RaiseError> set, the DBI will automatically C<die> if any DBI method
  call on that handle (or a child handle) fails, so you don't have to
  test the return value of each method call. See L</RaiseError> for more
  details.
  
  A major advantage of the C<eval> approach is that the transaction will be
  properly rolled back if I<any> code (not just DBI calls) in the inner
  application dies for any reason. The major advantage of using the
  C<$h-E<gt>{RaiseError}> attribute is that all DBI calls will be checked
  automatically. Both techniques are strongly recommended.
  
  After calling C<commit> or C<rollback> many drivers will not let you
  fetch from a previously active C<SELECT> statement handle that's a child
  of the same database handle. A typical way round this is to connect the
  the database twice and use one connection for C<SELECT> statements.
  
  See L</AutoCommit> and L</disconnect> for other important information
  about transactions.
  
  
  =head2 Handling BLOB / LONG / Memo Fields
  
  Many databases support "blob" (binary large objects), "long", or similar
  datatypes for holding very long strings or large amounts of binary
  data in a single field. Some databases support variable length long
  values over 2,000,000,000 bytes in length.
  
  Since values of that size can't usually be held in memory, and because
  databases can't usually know in advance the length of the longest long
  that will be returned from a C<SELECT> statement (unlike other data
  types), some special handling is required.
  
  In this situation, the value of the C<$h-E<gt>{LongReadLen}>
  attribute is used to determine how much buffer space to allocate
  when fetching such fields.  The C<$h-E<gt>{LongTruncOk}> attribute
  is used to determine how to behave if a fetched value can't fit
  into the buffer.
  
  See the description of L</LongReadLen> for more information.
  
  When trying to insert long or binary values, placeholders should be used
  since there are often limits on the maximum size of an C<INSERT>
  statement and the L</quote> method generally can't cope with binary
  data.  See L</Placeholders and Bind Values>.
  
  
  =head2 Simple Examples
  
  Here's a complete example program to select and fetch some data:
  
    my $data_source = "dbi::DriverName:db_name";
    my $dbh = DBI->connect($data_source, $user, $password)
        or die "Can't connect to $data_source: $DBI::errstr";
  
    my $sth = $dbh->prepare( q{
            SELECT name, phone
            FROM mytelbook
    }) or die "Can't prepare statement: $DBI::errstr";
  
    my $rc = $sth->execute
        or die "Can't execute statement: $DBI::errstr";
  
    print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n";
    print "Field names: @{ $sth->{NAME} }\n";
  
    while (($name, $phone) = $sth->fetchrow_array) {
        print "$name: $phone\n";
    }
    # check for problems which may have terminated the fetch early
    die $sth->errstr if $sth->err;
  
    $dbh->disconnect;
  
  Here's a complete example program to insert some data from a file.
  (This example uses C<RaiseError> to avoid needing to check each call).
  
    my $dbh = DBI->connect("dbi:DriverName:db_name", $user, $password, {
        RaiseError => 1, AutoCommit => 0
    });
  
    my $sth = $dbh->prepare( q{
        INSERT INTO table (name, phone) VALUES (?, ?)
    });
  
    open FH, "<phone.csv" or die "Unable to open phone.csv: $!";
    while (<FH>) {
        chomp;
        my ($name, $phone) = split /,/;
        $sth->execute($name, $phone);
    }
    close FH;
  
    $dbh->commit;
    $dbh->disconnect;
  
  Here's how to convert fetched NULLs (undefined values) into empty strings:
  
    while($row = $sth->fetchrow_arrayref) {
      # this is a fast and simple way to deal with nulls:
      foreach (@$row) { $_ = '' unless defined }
      print "@$row\n";
    }
  
  The C<q{...}> style quoting used in these examples avoids clashing with
  quotes that may be used in the SQL statement. Use the double-quote like
  C<qq{...}> operator if you want to interpolate variables into the string.
  See L<perlop/"Quote and Quote-like Operators"> for more details.
  
  =head2 Threads and Thread Safety
  
  Perl 5.7 and later support a new threading model called iThreads.
  (The old "5.005 style" threads are not supported by the DBI.)
  
  In the iThreads model each thread has it's own copy of the perl
  interpreter.  When a new thread is created the original perl
  interpreter is 'cloned' to create a new copy for the new thread.
  
  If the DBI and drivers are loaded and handles created before the
  thread is created then it will get a cloned copy of the DBI, the
  drivers and the handles.
  
  However, the internal pointer data within the handles will refer
  to the DBI and drivers in the original interpreter. Using those
  handles in the new interpreter thread is not safe, so the DBI detects
  this and croaks on any method call using handles that don't belong
  to the current thread (except for DESTROY).
  
  Because of this (possibly temporary) restriction, newly created
  threads must make their own connections to the database. Handles
  can't be shared across threads.
  
  But BEWARE, some underlying database APIs (the code the DBD driver
  uses to talk to the database, often supplied by the database vendor)
  are not thread safe. If it's not thread safe, then allowing more
  than one thread to enter the code at the same time may cause
  subtle/serious problems. In some cases allowing more than
  one thread to enter the code, even if I<not> at the same time,
  can cause problems. You have been warned.
  
  Using DBI with perl threads is not yet recommended for production
  environments. For more information see
  L<http://www.perlmonks.org/index.pl?node_id=288022>
  
  Note: There is a bug in perl 5.8.2 when configured with threads
  and debugging enabled (bug #24463) which causes a DBI test to fail.
  
  =head2 Signal Handling and Canceling Operations
  
  [The following only applies to systems with unix-like signal handling.
  I'd welcome additions for other systems, especially Windows.]
  
  The first thing to say is that signal handling in Perl versions less
  than 5.8 is I<not> safe. There is always a small risk of Perl
  crashing and/or core dumping when, or after, handling a signal
  because the signal could arrive and be handled while internal data
  structures are being changed. If the signal handling code
  used those same internal data structures it could cause all manner
  of subtle and not-so-subtle problems.  The risk was reduced with
  5.4.4 but was still present in all perls up through 5.8.0.
  
  Beginning in perl 5.8.0 perl implements 'safe' signal handling if
  your system has the POSIX sigaction() routine. Now when a signal
  is delivered perl just makes a note of it but does I<not> run the
  %SIG handler. The handling is 'deferred' until a 'safe' moment.
  
  Although this change made signal handling safe, it also lead to
  a problem with signals being deferred for longer than you'd like.
  If a signal arrived while executing a system call, such as waiting
  for data on a network connection, the signal is noted and then the
  system call that was executing returns with an EINTR error code
  to indicate that it was interrupted. All fine so far.
  
  The problem comes when the code that made the system call sees the
  EINTR code and decides it's going to call it again. Perl doesn't
  do that, but database code sometimes does. If that happens then the
  signal handler doesn't get called until later. Maybe much later.
  
  Fortunately there are ways around this which we'll discuss below.
  Unfortunately they make signals unsafe again.
  
  The two most common uses of signals in relation to the DBI are for
  canceling operations when the user types Ctrl-C (interrupt), and for
  implementing a timeout using C<alarm()> and C<$SIG{ALRM}>.
  
  =over 4
  
  =item Cancel
  
  The DBI provides a C<cancel> method for statement handles. The
  C<cancel> method should abort the current operation and is designed
  to be called from a signal handler.  For example:
  
    $SIG{INT} = sub { $sth->cancel };
  
  However, few drivers implement this (the DBI provides a default
  method that just returns C<undef>) and, even if implemented, there
  is still a possibility that the statement handle, and even the
  parent database handle, will not be usable afterwards.
  
  If C<cancel> returns true, then it has successfully
  invoked the database engine's own cancel function.  If it returns false,
  then C<cancel> failed. If it returns C<undef>, then the database
  driver does not have cancel implemented - very few do.
  
  =item Timeout
  
  The traditional way to implement a timeout is to set C<$SIG{ALRM}>
  to refer to some code that will be executed when an ALRM signal
  arrives and then to call alarm($seconds) to schedule an ALRM signal
  to be delivered $seconds in the future. For example:
  
    eval {
      local $SIG{ALRM} = sub { die "TIMEOUT\n" }; # N.B. \n required
      eval {
        alarm($seconds);
        ... code to execute with timeout here (which may die) ...
      };
      alarm(0);  # cancel alarm (if code ran fast)
      die "$@\n" if $@;
    };
    if ( $@ eq "TIMEOUT\n" ) { ... }
    elsif ($@) { ... } # some other error
  
  The second (inner) eval is used to avoid the unlikey but possible
  chance that the "code to execute" dies and the alarm fires before it
  is cancelled. Without the inner eval, if this happened your program
  will die if you have no ALRM handler or a non-local alarm handler
  will be called.
  
  Unfortunately, as described above, this won't always work as expected,
  depending on your perl version and the underlying database code.
  
  With Oracle for instance (DBD::Oracle), if the system which hosts
  the database is down the DBI->connect() call will hang for several
  minutes before returning an error.
  
  =back
  
  The solution on these systems is to use the C<POSIX::sigaction()>
  routine to gain low level access to how the signal handler is installed.
  
  The code would look something like this (for the DBD-Oracle connect()):
  
     use POSIX qw(:signal_h);
  
     my $mask = POSIX::SigSet->new( SIGALRM ); # signals to mask in the handler
     my $action = POSIX::SigAction->new(
         sub { die "connect timeout\n" },        # the handler code ref
         $mask,
         # not using (perl 5.8.2 and later) 'safe' switch or sa_flags
     );
     my $oldaction = POSIX::SigAction->new();
     sigaction( SIGALRM, $action, $oldaction );
     my $dbh;
     eval {
        eval {
          alarm(5); # seconds before time out
          $dbh = DBI->connect("dbi:Oracle:$dsn" ... );
        };
        alarm(0); # cancel alarm (if connect worked fast)
        die "$@\n" if $@; # connect died
     };
     sigaction( SIGALRM, $oldaction );  # restore original signal handler
     if ( $@ ) {
       if ($@ eq "connect timeout\n") {...}
       else { # connect died }
     }
  
  See previous example for the reasoning around the double eval.
  
  Similar techniques can be used for canceling statement execution.
  
  Unfortunately, this solution is somewhat messy, and it does I<not> work with
  perl versions less than perl 5.8 where C<POSIX::sigaction()> appears to be broken.
  
  For a cleaner implementation that works across perl versions, see Lincoln Baxter's
  Sys::SigAction module at L<http://search.cpan.org/~lbaxter/Sys-SigAction/>.
  The documentation for Sys::SigAction includes an longer discussion
  of this problem, and a DBD::Oracle test script.
  
  Be sure to read all the signal handling sections of the L<perlipc> manual.
  
  And finally, two more points to keep firmly in mind. Firstly,
  remember that what we've done here is essentially revert to old
  style I<unsafe> handling of these signals. So do as little as
  possible in the handler.  Ideally just die(). Secondly, the handles
  in use at the time the signal is handled may not be safe to use
  afterwards.
  
  
  =head2 Subclassing the DBI
  
  DBI can be subclassed and extended just like any other object
  oriented module.  Before we talk about how to do that, it's important
  to be clear about the various DBI classes and how they work together.
  
  By default C<$dbh = DBI-E<gt>connect(...)> returns a $dbh blessed
  into the C<DBI::db> class.  And the C<$dbh-E<gt>prepare> method
  returns an $sth blessed into the C<DBI::st> class (actually it
  simply changes the last four characters of the calling handle class
  to be C<::st>).
  
  The leading 'C<DBI>' is known as the 'root class' and the extra
  'C<::db>' or 'C<::st>' are the 'handle type suffixes'. If you want
  to subclass the DBI you'll need to put your overriding methods into
  the appropriate classes.  For example, if you want to use a root class
  of C<MySubDBI> and override the do(), prepare() and execute() methods,
  then your do() and prepare() methods should be in the C<MySubDBI::db>
  class and the execute() method should be in the C<MySubDBI::st> class.
  
  To setup the inheritance hierarchy the @ISA variable in C<MySubDBI::db>
  should include C<DBI::db> and the @ISA variable in C<MySubDBI::st>
  should include C<DBI::st>.  The C<MySubDBI> root class itself isn't
  currently used for anything visible and so, apart from setting @ISA
  to include C<DBI>, it can be left empty.
  
  So, having put your overriding methods into the right classes, and
  setup the inheritance hierarchy, how do you get the DBI to use them?
  You have two choices, either a static method call using the name
  of your subclass:
  
    $dbh = MySubDBI->connect(...);
  
  or specifying a C<RootClass> attribute:
  
    $dbh = DBI->connect(..., { RootClass => 'MySubDBI' });
  
  If both forms are used then the attribute takes precedence.
  
  The only differences between the two are that using an explicit
  RootClass attribute will a) make the DBI automatically attempt to load
  a module by that name if the class doesn't exist, and b) won't call
  your MySubDBI::connect() method, if you have one.
  
  When subclassing is being used then, after a successful new
  connect, the DBI->connect method automatically calls:
  
    $dbh->connected($dsn, $user, $pass, \%attr);
  
  The default method does nothing. The call is made just to simplify
  any post-connection setup that your subclass may want to perform.
  The parameters are the same as passed to DBI->connect.
  If your subclass supplies a connected method, it should be part of the
  MySubDBI::db package.
  
  One more thing to note: you must let the DBI do the handle creation.  If you
  want to override the connect() method in your *::dr class then it must still
  call SUPER::connect to get a $dbh to work with. Similarly, an overridden
  prepare() method in *::db must still call SUPER::prepare to get a $sth.
  If you try to create your own handles using bless() then you'll find the DBI
  will reject them with an "is not a DBI handle (has no magic)" error.
  
  Here's a brief example of a DBI subclass.  A more thorough example
  can be found in F<t/subclass.t> in the DBI distribution.
  
    package MySubDBI;
  
    use strict;
  
    use DBI;
    use vars qw(@ISA);
    @ISA = qw(DBI);
  
    package MySubDBI::db;
    use vars qw(@ISA);
    @ISA = qw(DBI::db);
  
    sub prepare {
      my ($dbh, @args) = @_;
      my $sth = $dbh->SUPER::prepare(@args)
          or return;
      $sth->{private_mysubdbi_info} = { foo => 'bar' };
      return $sth;
    }
  
    package MySubDBI::st;
    use vars qw(@ISA);
    @ISA = qw(DBI::st);
  
    sub fetch {
      my ($sth, @args) = @_;
      my $row = $sth->SUPER::fetch(@args)
          or return;
      do_something_magical_with_row_data($row)
          or return $sth->set_err(1234, "The magic failed", undef, "fetch");
      return $row;
    }
  
  When calling a SUPER::method that returns a handle, be careful to
  check the return value before trying to do other things with it in
  your overridden method. This is especially important if you want to
  set a hash attribute on the handle, as Perl's autovivification will
  bite you by (in)conveniently creating an unblessed hashref, which your
  method will then return with usually baffling results later on like
  the error "dbih_getcom handle HASH(0xa4451a8) is not a DBI handle (has
  no magic".  It's best to check right after the call and return undef
  immediately on error, just like DBI would and just like the example
  above.
  
  If your method needs to record an error it should call the set_err()
  method with the error code and error string, as shown in the example
  above. The error code and error string will be recorded in the
  handle and available via C<$h-E<gt>err> and C<$DBI::errstr> etc.
  The set_err() method always returns an undef or empty list as
  appropriate. Since your method should nearly always return an undef
  or empty list as soon as an error is detected it's handy to simply
  return what set_err() returns, as shown in the example above.
  
  If the handle has C<RaiseError>, C<PrintError>, or C<HandleError>
  etc. set then the set_err() method will honour them. This means
  that if C<RaiseError> is set then set_err() won't return in the
  normal way but will 'throw an exception' that can be caught with
  an C<eval> block.
  
  You can stash private data into DBI handles
  via C<$h-E<gt>{private_..._*}>.  See the entry under L</ATTRIBUTES
  COMMON TO ALL HANDLES> for info and important caveats.
  
  
  =head1 TRACING
  
  The DBI has a powerful tracing mechanism built in. It enables you
  to see what's going on 'behind the scenes', both within the DBI and
  the drivers you're using.
  
  =head2 Trace Settings
  
  Which details are written to the trace output is controlled by a
  combination of a I<trace level>, an integer from 0 to 15, and a set
  of I<trace flags> that are either on or off. Together these are known
  as the I<trace settings> and are stored together in a single integer.
  For normal use you only need to set the trace level, and generally
  only to a value between 1 and 4.
  
  Each handle has it's own trace settings, and so does the DBI.
  When you call a method the DBI merges the handles settings into its
  own for the duration of the call: the trace flags of the handle are
  OR'd into the trace flags of the DBI, and if the handle has a higher
  trace level then the DBI trace level is raised to match it.
  The previous DBI trace settings are restored when the called method
  returns.
  
  =head2 Trace Levels
  
  Trace I<levels> are as follows:
  
    0 - Trace disabled.
    1 - Trace top-level DBI method calls returning with results or errors.
    2 - As above, adding tracing of top-level method entry with parameters.
    3 - As above, adding some high-level information from the driver
        and some internal information from the DBI.
    4 - As above, adding more detailed information from the driver.
        This is the first level to trace all the rows being fetched.
    5 to 15 - As above but with more and more internal information.
  
  Trace level 1 is best for a simple overview of what's happening.
  Trace levels 2 thru 4 a good choice for general purpose tracing.
  Levels 5 and above are best reserved for investigating a specific
  problem, when you need to see "inside" the driver and DBI.
  
  The trace output is detailed and typically very useful. Much of the
  trace output is formatted using the L</neat> function, so strings
  in the trace output may be edited and truncated by that function.
  
  =head2 Trace Flags
  
  Trace I<flags> are used to enable tracing of specific activities
  within the DBI and drivers. The DBI defines some trace flags and
  drivers can define others. DBI trace flag names begin with a capital
  letter and driver specific names begin with a lowercase letter, as
  usual.
  
  Currently the DBI only defines two trace flags:
  
    ALL - turn on all DBI and driver flags (not recommended)
    SQL - trace SQL statements executed
          (not yet implemented in DBI but implemented in some DBDs)
  
  The L</parse_trace_flags> and L</parse_trace_flag> methods are used
  to convert trace flag names into the corresponding integer bit flags.
  
  =head2 Enabling Trace
  
  The C<$h-E<gt>trace> method sets the trace settings for a handle
  and C<DBI-E<gt>trace> does the same for the DBI.
  
  In addition to the L</trace> method, you can enable the same trace
  information, and direct the output to a file, by setting the
  C<DBI_TRACE> environment variable before starting Perl.
  See L</DBI_TRACE> for more information.
  
  Finally, you can set, or get, the trace settings for a handle using
  the C<TraceLevel> attribute.
  
  All of those methods use parse_trace_flags() and so allow you set
  both the trace level and multiple trace flags by using a string
  containing the trace level and/or flag names separated by vertical
  bar ("C<|>") or comma ("C<,>") characters. For example:
  
    local $h->{TraceLevel} = "3|SQL|foo";
  
  =head2 Trace Output
  
  Initially trace output is written to C<STDERR>.  Both the
  C<$h-E<gt>trace> and C<DBI-E<gt>trace> methods take an optional
  $trace_file parameter, which may be either the name of a file to be
  opened by DBI in append mode, or a reference to an existing writable
  (possibly layered) filehandle. If $trace_file is a filename,
  and can be opened in append mode, or $trace_file is a writable
  filehandle, then I<all> trace output (currently including that from
  other handles) is redirected to that file. A warning is generated
  if $trace_file can't be opened or is not writable.
  
  Further calls to trace() without $trace_file do not alter where
  the trace output is sent. If $trace_file is undefined, then
  trace output is sent to C<STDERR> and, if the prior trace was opened with
  $trace_file as a filename, the previous trace file is closed; if $trace_file was
  a filehandle, the filehandle is B<not> closed.
  
  B<NOTE>: If $trace_file is specified as a filehandle, the filehandle
  should not be closed until all DBI operations are completed, or the
  application has reset the trace file via another call to
  C<trace()> that changes the trace file.
  
  =head2 Tracing to Layered Filehandles
  
  B<NOTE>:
  
  =over 4
  
  =item *
  Tied filehandles are not currently supported, as
  tie operations are not available to the PerlIO
  methods used by the DBI.
  
  =item *
  PerlIO layer support requires Perl version 5.8 or higher.
  
  =back
  
  As of version 5.8, Perl provides the ability to layer various
  "disciplines" on an open filehandle via the L<PerlIO> module.
  
  A simple example of using PerlIO layers is to use a scalar as the output:
  
      my $scalar = '';
      open( my $fh, "+>:scalar", \$scalar );
      $dbh->trace( 2, $fh );
  
  Now all trace output is simply appended to $scalar.
  
  A more complex application of tracing to a layered filehandle is the
  use of a custom layer (I<Refer to >L<Perlio::via> I<for details
  on creating custom PerlIO layers.>). Consider an application with the
  following logger module:
  
      package MyFancyLogger;
  
      sub new
      {
          my $self = {};
          my $fh;
          open $fh, '>', 'fancylog.log';
          $self->{_fh} = $fh;
          $self->{_buf} = '';
          return bless $self, shift;
      }
  
      sub log
      {
          my $self = shift;
          return unless exists $self->{_fh};
          my $fh = $self->{_fh};
          $self->{_buf} .= shift;
      #
      # DBI feeds us pieces at a time, so accumulate a complete line
      # before outputing
      #
          print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
          $self->{_buf} = ''
              if $self->{_buf}=~tr/\n//;
      }
  
      sub close {
          my $self = shift;
          return unless exists $self->{_fh};
          my $fh = $self->{_fh};
          print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and
          $self->{_buf} = ''
              if $self->{_buf};
          close $fh;
          delete $self->{_fh};
      }
  
      1;
  
  To redirect DBI traces to this logger requires creating
  a package for the layer:
  
      package PerlIO::via::MyFancyLogLayer;
  
      sub PUSHED
      {
          my ($class,$mode,$fh) = @_;
          my $logger;
          return bless \$logger,$class;
      }
  
      sub OPEN {
          my ($self, $path, $mode, $fh) = @_;
          #
          # $path is actually our logger object
          #
          $$self = $path;
          return 1;
      }
  
      sub WRITE
      {
          my ($self, $buf, $fh) = @_;
          $$self->log($buf);
          return length($buf);
      }
  
      sub CLOSE {
          my $self = shift;
          $$self->close();
          return 0;
      }
  
      1;
  
  
  The application can then cause DBI traces to be routed to the
  logger using
  
      use PerlIO::via::MyFancyLogLayer;
  
      open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new();
  
      $dbh->trace('SQL', $fh);
  
  Now all trace output will be processed by MyFancyLogger's
  log() method.
  
  =head2 Trace Content
  
  Many of the values embedded in trace output are formatted using the neat()
  utility function. This means they may be quoted, sanitized, and possibly
  truncated if longer than C<$DBI::neat_maxlen>. See L</neat> for more details.
  
  =head2 Tracing Tips
  
  You can add tracing to your own application code using the L</trace_msg> method.
  
  It can sometimes be handy to compare trace files from two different runs of the
  same script. However using a tool like C<diff> on the original log output
  doesn't work well because the trace file is full of object addresses that may
  differ on each run.
  
  The DBI includes a handy utility called dbilogstrip that can be used to
  'normalize' the log content. It can be used as a filter like this:
  
      DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
      DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
      diff -u dbitrace1.log dbitrace2.log
  
  See L<dbilogstrip> for more information.
  
  =head1 DBI ENVIRONMENT VARIABLES
  
  The DBI module recognizes a number of environment variables, but most of
  them should not be used most of the time.
  It is better to be explicit about what you are doing to avoid the need
  for environment variables, especially in a web serving system where web
  servers are stingy about which environment variables are available.
  
  =head2 DBI_DSN
  
  The DBI_DSN environment variable is used by DBI->connect if you do not
  specify a data source when you issue the connect.
  It should have a format such as "dbi:Driver:databasename".
  
  =head2 DBI_DRIVER
  
  The DBI_DRIVER environment variable is used to fill in the database
  driver name in DBI->connect if the data source string starts "dbi::"
  (thereby omitting the driver).
  If DBI_DSN omits the driver name, DBI_DRIVER can fill the gap.
  
  =head2 DBI_AUTOPROXY
  
  The DBI_AUTOPROXY environment variable takes a string value that starts
  "dbi:Proxy:" and is typically followed by "hostname=...;port=...".
  It is used to alter the behaviour of DBI->connect.
  For full details, see DBI::Proxy documentation.
  
  =head2 DBI_USER
  
  The DBI_USER environment variable takes a string value that is used as
  the user name if the DBI->connect call is given undef (as distinct from
  an empty string) as the username argument.
  Be wary of the security implications of using this.
  
  =head2 DBI_PASS
  
  The DBI_PASS environment variable takes a string value that is used as
  the password if the DBI->connect call is given undef (as distinct from
  an empty string) as the password argument.
  Be extra wary of the security implications of using this.
  
  =head2 DBI_DBNAME (obsolete)
  
  The DBI_DBNAME environment variable takes a string value that is used only when the
  obsolescent style of DBI->connect (with driver name as fourth parameter) is used, and
  when no value is provided for the first (database name) argument.
  
  =head2 DBI_TRACE
  
  The DBI_TRACE environment variable specifies the global default
  trace settings for the DBI at startup. Can also be used to direct
  trace output to a file. When the DBI is loaded it does:
  
    DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
  
  So if C<DBI_TRACE> contains an "C<=>" character then what follows
  it is used as the name of the file to append the trace to.
  
  output appended to that file. If the name begins with a number
  followed by an equal sign (C<=>), then the number and the equal sign are
  stripped off from the name, and the number is used to set the trace
  level. For example:
  
    DBI_TRACE=1=dbitrace.log perl your_test_script.pl
  
  On Unix-like systems using a Bourne-like shell, you can do this easily
  on the command line:
  
    DBI_TRACE=2 perl your_test_script.pl
  
  See L</TRACING> for more information.
  
  =head2 PERL_DBI_DEBUG (obsolete)
  
  An old variable that should no longer be used; equivalent to DBI_TRACE.
  
  =head2 DBI_PROFILE
  
  The DBI_PROFILE environment variable can be used to enable profiling
  of DBI method calls. See L<DBI::Profile> for more information.
  
  =head2 DBI_PUREPERL
  
  The DBI_PUREPERL environment variable can be used to enable the
  use of DBI::PurePerl.  See L<DBI::PurePerl> for more information.
  
  =head1 WARNING AND ERROR MESSAGES
  
  =head2 Fatal Errors
  
  =over 4
  
  =item Can't call method "prepare" without a package or object reference
  
  The C<$dbh> handle you're using to call C<prepare> is probably undefined because
  the preceding C<connect> failed. You should always check the return status of
  DBI methods, or use the L</RaiseError> attribute.
  
  =item Can't call method "execute" without a package or object reference
  
  The C<$sth> handle you're using to call C<execute> is probably undefined because
  the preceding C<prepare> failed. You should always check the return status of
  DBI methods, or use the L</RaiseError> attribute.
  
  =item DBI/DBD internal version mismatch
  
  The DBD driver module was built with a different version of DBI than
  the one currently being used.  You should rebuild the DBD module under
  the current version of DBI.
  
  (Some rare platforms require "static linking". On those platforms, there
  may be an old DBI or DBD driver version actually embedded in the Perl
  executable being used.)
  
  =item DBD driver has not implemented the AutoCommit attribute
  
  The DBD driver implementation is incomplete. Consult the author.
  
  =item Can't [sg]et %s->{%s}: unrecognised attribute
  
  You attempted to set or get an unknown attribute of a handle.  Make
  sure you have spelled the attribute name correctly; case is significant
  (e.g., "Autocommit" is not the same as "AutoCommit").
  
  =back
  
  =head1 Pure-Perl DBI
  
  A pure-perl emulation of the DBI is included in the distribution
  for people using pure-perl drivers who, for whatever reason, can't
  install the compiled DBI. See L<DBI::PurePerl>.
  
  =head1 SEE ALSO
  
  =head2 Driver and Database Documentation
  
  Refer to the documentation for the DBD driver that you are using.
  
  Refer to the SQL Language Reference Manual for the database engine that you are using.
  
  =head2 ODBC and SQL/CLI Standards Reference Information
  
  More detailed information about the semantics of certain DBI methods
  that are based on ODBC and SQL/CLI standards is available on-line
  via microsoft.com, for ODBC, and www.jtc1sc32.org for the SQL/CLI
  standard:
  
   DBI method        ODBC function     SQL/CLI Working Draft
   ----------        -------------     ---------------------
   column_info       SQLColumns        Page 124
   foreign_key_info  SQLForeignKeys    Page 163
   get_info          SQLGetInfo        Page 214
   primary_key_info  SQLPrimaryKeys    Page 254
   table_info        SQLTables         Page 294
   type_info         SQLGetTypeInfo    Page 239
   statistics_info   SQLStatistics
  
  To find documentation on the ODBC function you can use
  the MSDN search facility at:
  
      http://msdn.microsoft.com/Search
  
  and search for something like C<"SQLColumns returns">.
  
  And for SQL/CLI standard information on SQLColumns you'd read page 124 of
  the (very large) SQL/CLI Working Draft available from:
  
    http://jtc1sc32.org/doc/N0701-0750/32N0744T.pdf
  
  =head2 Standards Reference Information
  
  A hyperlinked, browsable version of the BNF syntax for SQL92 (plus
  Oracle 7 SQL and PL/SQL) is available here:
  
    http://cui.unige.ch/db-research/Enseignement/analyseinfo/SQL92/BNFindex.html
  
  A BNF syntax for SQL3 is available here:
  
    http://www.sqlstandards.org/SC32/WG3/Progression_Documents/Informal_working_drafts/iso-9075-2-1999.bnf
  
  The following links provide further useful information about SQL.
  Some of these are rather dated now but may still be useful.
  
    http://www.jcc.com/SQLPages/jccs_sql.htm
    http://www.contrib.andrew.cmu.edu/~shadow/sql.html
    http://www.altavista.com/query?q=sql+tutorial
  
  
  =head2 Books and Articles
  
  Programming the Perl DBI, by Alligator Descartes and Tim Bunce.
  L<http://books.perl.org/book/154>
  
  Programming Perl 3rd Ed. by Larry Wall, Tom Christiansen & Jon Orwant.
  L<http://books.perl.org/book/134>
  
  Learning Perl by Randal Schwartz.
  L<http://books.perl.org/book/101>
  
  Details of many other books related to perl can be found at L<http://books.perl.org>
  
  =head2 Perl Modules
  
  Index of DBI related modules available from CPAN:
  
   http://search.cpan.org/search?mode=module&query=DBIx%3A%3A
   http://search.cpan.org/search?mode=doc&query=DBI
  
  For a good comparison of RDBMS-OO mappers and some OO-RDBMS mappers
  (including Class::DBI, Alzabo, and DBIx::RecordSet in the former
  category and Tangram and SPOPS in the latter) see the Perl
  Object-Oriented Persistence project pages at:
  
   http://poop.sourceforge.net
  
  A similar page for Java toolkits can be found at:
  
   http://c2.com/cgi-bin/wiki?ObjectRelationalToolComparison
  
  =head2 Mailing List
  
  The I<dbi-users> mailing list is the primary means of communication among
  users of the DBI and its related modules. For details send email to:
  
   dbi-users-help@perl.org
  
  There are typically between 700 and 900 messages per month.  You have
  to subscribe in order to be able to post. However you can opt for a
  'post-only' subscription.
  
  Mailing list archives (of variable quality) are held at:
  
   http://groups.google.com/groups?group=perl.dbi.users
   http://www.xray.mpe.mpg.de/mailing-lists/dbi/
   http://www.mail-archive.com/dbi-users%40perl.org/
  
  =head2 Assorted Related WWW Links
  
  The DBI "Home Page":
  
   http://dbi.perl.org/
  
  Other DBI related links:
  
   http://tegan.deltanet.com/~phlip/DBUIdoc.html
   http://dc.pm.org/perl_db.html
   http://wdvl.com/Authoring/DB/Intro/toc.html
   http://www.hotwired.com/webmonkey/backend/tutorials/tutorial1.html
   http://bumppo.net/lists/macperl/1999/06/msg00197.html
   http://gmax.oltrelinux.com/dbirecipes.html
  
  Other database related links:
  
   http://www.jcc.com/sql_stnd.html
   http://cuiwww.unige.ch/OSG/info/FreeDB/FreeDB.home.html
   http://www.connectionstrings.com/
  
  Security, especially the "SQL Injection" attack:
  
   http://www.ngssoftware.com/research/papers.html
   http://www.ngssoftware.com/papers/advanced_sql_injection.pdf
   http://www.ngssoftware.com/papers/more_advanced_sql_injection.pdf
   http://www.esecurityplanet.com/trends/article.php/2243461
   http://www.spidynamics.com/papers/SQLInjectionWhitePaper.pdf
   http://www.imperva.com/application_defense_center/white_papers/blind_sql_server_injection.html
   http://online.securityfocus.com/infocus/1644
  
  Commercial and Data Warehouse Links
  
   http://www.dwinfocenter.org
   http://www.datawarehouse.com
   http://www.datamining.org
   http://www.olapcouncil.org
   http://www.idwa.org
   http://www.knowledgecenters.org/dwcenter.asp
  
  Recommended Perl Programming Links
  
   http://language.perl.com/style/
  
  
  =head2 FAQ
  
  See L<http://faq.dbi-support.com/>
  
  =head1 AUTHORS
  
  DBI by Tim Bunce, L<http://www.tim.bunce.name>
  
  This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others.
  Perl by Larry Wall and the C<perl5-porters>.
  
  =head1 COPYRIGHT
  
  The DBI module is Copyright (c) 1994-2009 Tim Bunce. Ireland.
  All rights reserved.
  
  You may distribute under the terms of either the GNU General Public
  License or the Artistic License, as specified in the Perl 5.10.0 README file.
  
  =head1 SUPPORT / WARRANTY
  
  The DBI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND.
  
  =head2 Support
  
  My consulting company, Data Plan Services, offers annual and
  multi-annual support contracts for the DBI. These provide sustained
  support for DBI development, and sustained value for you in return.
  Contact me for details.
  
  =head2 Sponsor Enhancements
  
  The DBI Roadmap is available at L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
  
  If your company would benefit from a specific new DBI feature,
  please consider sponsoring its development.  Work is performed
  rapidly, and usually on a fixed-price payment-on-delivery basis.
  Contact me for details.
  
  Using such targeted financing allows you to contribute to DBI
  development, and rapidly get something specific and valuable in return.
  
  =head1 ACKNOWLEDGEMENTS
  
  I would like to acknowledge the valuable contributions of the many
  people I have worked with on the DBI project, especially in the early
  years (1992-1994). In no particular order: Kevin Stock, Buzz Moschetti,
  Kurt Andersen, Ted Lemon, William Hails, Garth Kennedy, Michael Peppler,
  Neil S. Briscoe, Jeff Urlwin, David J. Hughes, Jeff Stander,
  Forrest D Whitcher, Larry Wall, Jeff Fried, Roy Johnson, Paul Hudson,
  Georg Rehfeld, Steve Sizemore, Ron Pool, Jon Meek, Tom Christiansen,
  Steve Baumgarten, Randal Schwartz, and a whole lot more.
  
  Then, of course, there are the poor souls who have struggled through
  untold and undocumented obstacles to actually implement DBI drivers.
  Among their ranks are Jochen Wiedmann, Alligator Descartes, Jonathan
  Leffler, Jeff Urlwin, Michael Peppler, Henrik Tougaard, Edwin Pratomo,
  Davide Migliavacca, Jan Pazdziora, Peter Haworth, Edmund Mergl, Steve
  Williams, Thomas Lowery, and Phlip Plumlee. Without them, the DBI would
  not be the practical reality it is today.  I'm also especially grateful
  to Alligator Descartes for starting work on the first edition of the
  "Programming the Perl DBI" book and letting me jump on board.
  
  The DBI and DBD::Oracle were originally developed while I was Technical
  Director (CTO) of Ingeneering in the UK (L<http://www.ig.co.uk>) (formerly known as the
  Paul Ingram Group).  So I'd especially like to thank Paul for his generosity
  and vision in supporting this work for many years.
  
  A couple of specific DBI features have been sponsored by enlightened companies:
  
  The development of the swap_inner_handle() method was sponsored by BizRate.com (L<http://BizRate.com>)
  
  The development of DBD::Gofer and related modules was sponsored by
  Shopzilla.com (L<http://Shopzilla.com>), where I currently work.
  
  
  =head1 CONTRIBUTING
  
  As you can see above, many people have contributed to the DBI and
  drivers in many ways over many years.
  
  If you'd like to help then see L<http://dbi.perl.org/contributing>
  and L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
  
  If you'd like the DBI to do something new or different then a good way
  to make that happen is to do it yourself and send me a patch to the
  source code that shows the changes. (But read "Speak before you patch"
  below.)
  
  =head2 Browsing the source code repository
  
  Use http://svn.perl.org/modules/dbi/trunk (basic)
  or  http://svn.perl.org/viewcvs/modules/ (more useful)
  
  =head2 How to create a patch using Subversion
  
  The DBI source code is maintained using Subversion (a replacement
  for CVS, see L<http://subversion.tigris.org/>). To access the source
  you'll need to install a Subversion client. Then, to get the source
  code, do:
  
    svn checkout http://svn.perl.org/modules/dbi/trunk
  
  If it prompts for a username and password use your perl.org account
  if you have one, else just 'guest' and 'guest'. The source code will
  be in a new subdirectory called C<trunk>.
  
  To keep informed about changes to the source you can send an empty email
  to svn-commit-modules-dbi-subscribe@perl.org after which you'll get an email
  with the change log message and diff of each change checked-in to the source.
  
  After making your changes you can generate a patch file, but before
  you do, make sure your source is still up to date using:
  
    svn update
  
  If you get any conflicts reported you'll need to fix them first.
  Then generate the patch file from within the C<trunk> directory using:
  
    svn diff > foo.patch
  
  Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org.
  
  =head2 How to create a patch without Subversion
  
  Unpack a fresh copy of the distribution:
  
    tar xfz DBI-1.40.tar.gz
  
  Rename the newly created top level directory:
  
    mv DBI-1.40 DBI-1.40.your_foo
  
  Edit the contents of DBI-1.40.your_foo/* till it does what you want.
  
  Test your changes and then remove all temporary files:
  
    make test && make distclean
  
  Go back to the directory you originally unpacked the distribution:
  
    cd ..
  
  Unpack I<another> copy of the original distribution you started with:
  
    tar xfz DBI-1.40.tar.gz
  
  Then create a patch file by performing a recursive C<diff> on the two
  top level directories:
  
    diff -r -u DBI-1.40 DBI-1.40.your_foo > DBI-1.40.your_foo.patch
  
  =head2 Speak before you patch
  
  For anything non-trivial or possibly controversial it's a good idea
  to discuss (on dbi-dev@perl.org) the changes you propose before
  actually spending time working on them. Otherwise you run the risk
  of them being rejected because they don't fit into some larger plans
  you may not be aware of.
  
  =head1 TRANSLATIONS
  
  A German translation of this manual (possibly slightly out of date) is
  available, thanks to O'Reilly, at:
  
    http://www.oreilly.de/catalog/perldbiger/
  
  Some other translations:
  
   http://cronopio.net/perl/                              - Spanish
   http://member.nifty.ne.jp/hippo2000/dbimemo.htm        - Japanese
  
  
  =head1 TRAINING
  
  References to DBI related training resources. No recommendation implied.
  
    http://www.treepax.co.uk/
    http://www.keller.com/dbweb/
  
  (If you offer professional DBI related training services,
  please send me your details so I can add them here.)
  
  =head1 OTHER RELATED WORK AND PERL MODULES
  
  =over 4
  
  =item Apache::DBI by E.Mergl@bawue.de
  
  To be used with the Apache daemon together with an embedded Perl
  interpreter like C<mod_perl>. Establishes a database connection which
  remains open for the lifetime of the HTTP daemon. This way the CGI
  connect and disconnect for every database access becomes superfluous.
  
  =item SQL Parser
  
  See also the L<SQL::Statement> module, SQL parser and engine.
  
  =back
  
  =cut
  
  #  LocalWords:  DBI
DARWIN-THREAD-MULTI-2LEVEL_DBI

$fatpacked{"darwin-thread-multi-2level/DBI/Changes.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_CHANGES';
  =head1 NAME
  
  DBI::Changes - List of significant changes to the DBI
  
  (As of $Date: 2010-04-29 18:35:57 +0100 (Thu, 29 Apr 2010) $ $Revision: 13936 $)
  
  =cut
  
  =head2 Changes in DBI 1.611 (svn r13935) 29th April 2010
  
    NOTE: minimum perl version is now 5.8.1 (as announced in DBI 1.607)
  
    Fixed selectcol_arrayref MaxRows attribute to count rows not values
      thanks to Vernon Lyon.
    Fixed DBI->trace(0, *STDERR); (H.Merijn Brand)
      which tried to open a file named "*main::STDERR" in perl-5.10.x
    Fixes in DBD::DBM for use under threads (Jens Rehsack)
  
    Changed "Issuing rollback() due to DESTROY without explicit disconnect"
      warning to not be issued if ReadOnly set for that dbh.
  
    Added f_lock and f_encoding support to DBD::File (H.Merijn Brand)
    Added ChildCallbacks => { ... } to Callbacks as a way to
      specify Callbacks for child handles.
      With tests added by David E. Wheeler.
    Added DBI::sql_type_cast($value, $type, $flags) to cast a string value
      to an SQL type. e.g. SQL_INTEGER effectively does $value += 0;
      Has other options plus an internal interface for drivers.
  
    Documentation changes:
    Small fixes in the documentation of DBD::DBM (H.Merijn Brand)
    Documented specification of type casting behaviour for bind_col()
      based on DBI::sql_type_cast() and two new bind_col attributes
      StrictlyTyped and DiscardString. Thanks to Martin Evans.
    Document fetchrow_hashref() behaviour for functions,
      aliases and duplicate names (H.Merijn Brand)
    Updated DBI::Profile and DBD::File docs to fix pod nits
      thanks to Frank Wiegand.
    Corrected typos in Gopher documentation reported by Jan Krynicky.
    Documented the Callbacks attribute thanks to David E. Wheeler.
    Corrected the Timeout examples as per rt 50621 (Martin J. Evans).
    Removed some internal broken links in the pod (Martin J. Evans)
    Added Note to column_info for drivers which do not
      support it (Martin J. Evans)
    Updated dbipport.h to Devel::PPPort 3.19 (H.Merijn Brand)
  
  =head2 Changes in DBI 1.609 (svn r12816) 8th June 2009
  
    Fixes to DBD::File (H.Merijn Brand)
      added f_schema attribute
      table names case sensitive when quoted, insensitive when unquoted
      workaround a bug in SQL::Statement (temporary fix) related
        to the "You passed x parameters where y required" error
  
    Added ImplementorClass and Name info to the "Issuing rollback() due to
      DESTROY without explicit disconnect" warning to identify the handle.
      Applies to compiled drivers when they are recompiled.
    Added DBI->visit_handles($coderef) method.
    Added $h->visit_child_handles($coderef) method.
    Added docs for column_info()'s COLUMN_DEF value.
    Clarified docs on stickyness of data type via bind_param().
    Clarified docs on stickyness of data type via bind_col().
  
  =head2 Changes in DBI 1.608 (svn r12742) 5th May 2009
  
    Fixes to DBD::File (H.Merijn Brand)
      bind_param () now honors the attribute argument
      added f_ext attribute
      File::Spec is always required. (CORE since 5.00405)
      Fail and set errstr on parameter count mismatch in execute ()
    Fixed two small memory leaks when running in mod_perl
      one in DBI->connect and one in DBI::Gofer::Execute.
      Both due to "local $ENV{...};" leaking memory.
    Fixed DBD_ATTRIB_DELETE macro for driver authors
      and updated DBI::DBD docs thanks to Martin J. Evans.
    Fixed 64bit issues in trace messages thanks to Charles Jardine.
    Fixed FETCH_many() method to work with drivers that incorrectly return 
      an empty list from $h->FETCH. Affected gofer.
  
    Added 'sqlite_' as registered prefix for DBD::SQLite.
    Corrected many typos in DBI docs thanks to Martin J. Evans.
    Improved DBI::DBD docs thanks to H.Merijn Brand.
  
  =head2 Changes in DBI 1.607 (svn r11571) 22nd July 2008
  
    NOTE: Perl 5.8.1 is now the minimum supported version.
    If you need support for earlier versions send me a patch.
  
    Fixed missing import of carp in DBI::Gofer::Execute.
  
    Added note to docs about effect of execute(@empty_array).
    Clarified docs for ReadOnly thanks to Martin Evans.
  
  =head2 Changes in DBI 1.605 (svn r11434) 16th June 2008
  
    Fixed broken DBIS macro with threads on big-endian machines
      with 64bit ints but 32bit pointers. Ticket #32309.
    Fixed the selectall_arrayref, selectrow_arrayref, and selectrow_array
      methods that get embedded into compiled drivers to use the
      inner sth handle when passed a $sth instead of an sql string.
      Drivers will need to be recompiled to pick up this change.
    Fixed leak in neat() for some kinds of values thanks to Rudolf Lippan.
    Fixed DBI::PurePerl neat() to behave more like XS neat().
  
    Increased default $DBI::neat_maxlen from 400 to 1000.
    Increased timeout on tests to accomodate very slow systems.
    Changed behaviour of trace levels 1..4 to show less information
      at lower levels.
    Changed the format of the key used for $h->{CachedKids}
      (which is undocumented so you shouldn't depend on it anyway)
    Changed gofer error handling to avoid duplicate error text in errstr.
    Clarified docs re ":N" style placeholders.
    Improved gofer retry-on-error logic and refactored to aid subclassing.
    Improved gofer trace output in assorted ways.
  
    Removed the beeps "\a" from Makefile.PL warnings.
    Removed check for PlRPC-modules from Makefile.PL
  
    Added sorting of ParamValues reported by ShowErrorStatement
      thanks to to Rudolf Lippan.
    Added cache miss trace message to DBD::Gofer transport class.
    Added $drh->dbixs_revision method.
    Added explicit LICENSE specification (perl) to META.yaml
  
  =head2 Changes in DBI 1.604 (svn rev 10994) 24th March 2008
  
    Fixed fetchall_arrayref with $max_rows argument broken in 1.603,
      thanks to Greg Sabino Mullane.
    Fixed a few harmless compiler warnings on cygwin.
  
  =head2 Changes in DBI 1.603
  
    Fixed pure-perl fetchall_arrayref with $max_rows argument
      to not error when fetching after all rows already fetched.
      (Was fixed for compiled drivers back in DBI 1.31.)
      Thanks to Mark Overmeer.
    Fixed C sprintf formats and casts, fixing compiler warnings.
  
    Changed dbi_profile() to accept a hash of profiles and apply to all.
    Changed gofer stream transport to improve error reporting.
    Changed gofer test timeout to avoid spurious failures on slow systems.
  
    Added options to t/85gofer.t so it's more useful for manual testing.
  
  =head2 Changes in DBI 1.602 (svn rev 10706)  8th February 2008
  
    Fixed potential coredump if stack reallocated while calling back
      into perl from XS code. Thanks to John Gardiner Myers.
    Fixed DBI::Util::CacheMemory->new to not clear the cache.
    Fixed avg in DBI::Profile as_text() thanks to Abe Ingersoll.
    Fixed DBD::DBM bug in push_names thanks to J M Davitt.
    Fixed take_imp_data for some platforms thanks to Jeffrey Klein.
    Fixed docs tie'ing CacheKids (ie LRU cache) thanks to Peter John Edwards.
  
    Expanded DBI::DBD docs for driver authors thanks to Martin Evans.
    Enhanced t/80proxy.t test script.
    Enhanced t/85gofer.t test script thanks to Stig.
    Enhanced t/10examp.t test script thanks to David Cantrell.
    Documented $DBI::stderr as the default value of err for internal errors.
  
    Gofer changes:
      track_recent now also keeps track of N most recent errors.
      The connect method is now also counted in stats.
  
  =head2 Changes in DBI 1.601 (svn rev 10103),  21st October 2007
  
    Fixed t/05thrclone.t to work with Test::More >= 0.71
      thanks to Jerry D. Hedden and Michael G Schwern.
    Fixed DBI for VMS thanks to Peter (Stig) Edwards.
  
    Added client-side caching to DBD::Gofer. Can use any cache with
      get($k)/set($k,$v) methods, including all the Cache and Cache::Cache
      distribution modules plus Cache::Memcached, Cache::FastMmap etc.
      Works for all transports. Overridable per handle.
  
    Added DBI::Util::CacheMemory for use with DBD::Gofer caching.
      It's a very fast and small strict subset of Cache::Memory.
  
  =head2 Changes in DBI 1.59 (svn rev 9874),  23rd August 2007
  
    Fixed DBI::ProfileData to unescape headers lines read from data file.
    Fixed DBI::ProfileData to not clobber $_, thanks to Alexey Tourbin.
    Fixed DBI::SQL::Nano to not clobber $_, thanks to Alexey Tourbin.
    Fixed DBI::PurePerl to return undef for ChildHandles if weaken not available.
    Fixed DBD::Proxy disconnect error thanks to Philip Dye.
    Fixed DBD::Gofer::Transport::Base bug (typo) in timeout code.
    Fixed DBD::Proxy rows method thanks to Philip Dye.
    Fixed dbiprof compile errors, thanks to Alexey Tourbin.
    Fixed t/03handle.t to skip some tests if ChildHandles not available.
  
    Added check_response_sub to DBI::Gofer::Execute
  
  =head2 Changes in DBI 1.58 (svn rev 9678),  25th June 2007
  
    Fixed code triggering fatal error in bleadperl, thanks to Steve Hay.
    Fixed compiler warning thanks to Jerry D. Hedden.
    Fixed t/40profile.t to use int(dbi_time()) for systems like Cygwin where
      time() seems to be rounded not truncated from the high resolution time.
    Removed dump_results() test from t/80proxy.t.
  
  =head2 Changes in DBI 1.57 (svn rev 9639),  13th June 2007
  
    Note: this release includes a change to the DBI::hash() function which will
    now produce different values than before *if* your perl was built with 64-bit
    'int' type (i.e. "perl -V:intsize" says intsize='8').  It's relatively rare
    for perl to be configured that way, even on 64-bit systems.
  
    Fixed XS versions of select*_*() methods to call execute()
      fetch() etc., with inner handle instead of outer.
    Fixed execute_for_fetch() to not cache errstr values
      thanks to Bart Degryse.
    Fixed unused var compiler warning thanks to JDHEDDEN.
    Fixed t/86gofer_fail tests to be less likely to fail falsely.
  
    Changed DBI::hash to return 'I32' type instead of 'int' so results are
      portable/consistent regardless of size of the int type.
    Corrected timeout example in docs thanks to Egmont Koblinger.
    Changed t/01basic.t to warn instead of failing when it detects
      a problem with Math::BigInt (some recent versions had problems).
  
    Added support for !Time and !Time~N to DBI::Profile Path. See docs.
    Added extra trace info to connect_cached thanks to Walery Studennikov.
    Added non-random (deterministic) mode to DBI_GOFER_RANDOM mechanism.
    Added DBIXS_REVISION macro that drivers can use.
    Added more docs for private_attribute_info() method.
  
    DBI::Profile changes:
      dbi_profile() now returns ref to relevant leaf node.
      Don't profile DESTROY during global destruction.
      Added as_node_path_list() and as_text() methods.
    DBI::ProfileDumper changes:
      Don't write file if there's no profile data.
      Uses full natural precision when saving data (was using %.6f)
      Optimized flush_to_disk().
      Locks the data file while writing.
      Enabled filename to be a code ref for dynamic names.
    DBI::ProfileDumper::Apache changes:
      Added Quiet=>1 to avoid write to STDERR in flush_to_disk().
      Added Dir=>... to specify a writable destination directory.
      Enabled DBI_PROFILE_APACHE_LOG_DIR for mod_perl 1 as well as 2.
      Added parent pid to default data file name.
    DBI::ProfileData changes:
      Added DeleteFiles option to rename & delete files once read.
      Locks the data files while reading.
      Added ability to sort by Path elements.
    dbiprof changes:
      Added --dumpnodes and --delete options.
    Added/updated docs for both DBI::ProfileDumper && ::Apache.
  
  =head2 Changes in DBI 1.56 (svn rev 9660),  18th June 2007
  
    Fixed printf arg warnings thanks to JDHEDDEN.
    Fixed returning driver-private sth attributes via gofer.   
  
    Changed pod docs docs to use =head3 instead of =item
      so now in html you get links to individual methods etc.
    Changed default gofer retry_limit from 2 to 0.
    Changed tests to workaround Math::BigInt broken versions.
    Changed dbi_profile_merge() to dbi_profile_merge_nodes()
      old name still works as an alias for the new one.
    Removed old DBI internal sanity check that's no longer valid
      causing "panic: DESTROY (dbih_clearcom)" when tracing enabled
  
    Added DBI_GOFER_RANDOM env var that can be use to trigger random
      failures and delays when executing gofer requests. Designed to help
      test automatic retry on failures and timeout handling.
    Added lots more docs to all the DBD::Gofer and DBI::Gofer classes.
  
  =head2 Changes in DBI 1.55 (svn rev 9504),  4th May 2007
  
    Fixed set_err() so HandleSetErr hook is executed reliably, if set.
    Fixed accuracy of profiling when perl configured to use long doubles.
    Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm Nooning.
    Fixed potential corruption in selectall_arrayref and selectrow_arrayref
      for compiled drivers, thanks to Rob Davies.
      Rebuild your compiled drivers after installing DBI.
  
    Changed some handle creation code from perl to C code,
      to reduce handle creation cost by ~20%.
    Changed internal implementation of the CachedKids attribute
      so it's a normal handle attribute (and initially undef).
    Changed connect_cached and prepare_cached to avoid a FETCH method call,
      and thereby reduced cost by ~5% and ~30% respectively.
    Changed _set_fbav to not croak when given a wrongly sized array,
      it now warns and adjusts the row buffer to match.
    Changed some internals to improve performance with threaded perls.
    Changed DBD::NullP to be slightly more useful for testing.
    Changed File::Spec prerequisite to not require a minimum version.
    Changed tests to work with other DBMs thanks to ZMAN.
    Changed ex/perl_dbi_nulls_test.pl to be more descriptive.
  
    Added more functionality to the (undocumented) Callback mechanism.
      Callbacks can now elect to provide a value to be returned, in which case
      the method won't be called. A callback for "*" is applied to all methods
      that don't have their own callback.
    Added $h->{ReadOnly} attribute.
    Added support for DBI Profile Path to contain refs to scalars
      which will be de-ref'd for each profile sample.
    Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed)
    Added details for SQLite 3.3 to NULL handling docs thanks to Alex Teslik.
    Added take_imp_data() to DBI::PurePerl.
  
    Gofer related changes:
      Fixed gofer pipeone & stream transports to avoid risk of hanging.
      Improved error handling and tracing significantly.
      Added way to generate random 1-in-N failures for methods.
      Added automatic retry-on-error mechanism to gofer transport base class.
      Added tests to show automatic retry mechanism works a treat!
      Added go_retry_hook callback hook so apps can fine-tune retry behaviour.
      Added header to request and response packets for sanity checking
        and to enable version skew between client and server.
      Added forced_single_resultset, max_cached_sth_per_dbh and max_cached_dbh_per_drh
        to gofer executor config.
      Driver-private methods installed with install_method are now proxied.
      No longer does a round-trip to the server for methods it knows
        have not been overridden by the remote driver.
      Most significant aspects of gofer behaviour are controlled by policy mechanism.
      Added policy-controlled caching of results for some methods, such as schema metadata.
      The connect_cached and prepare_cached methods cache on client and server.
      The bind_param_array and execute_array methods are now supported.
      Worked around a DBD::Sybase bind_param bug (which is fixed in DBD::Sybase 1.07)
      Added goferperf.pl utility (doesn't get installed).
      Many other assorted Gofer related bug fixes, enhancements and docs.
      The http and mod_perl transports have been remove to their own distribution.
      Client and server will need upgrading together for this release.
  
  =head2 Changes in DBI 1.54 (svn rev 9157),  23rd February 2007
  
    NOTE: This release includes the 'next big thing': DBD::Gofer.
    Take a look!
  
    WARNING: This version has some subtle changes in DBI internals.
    It's possible, though doubtful, that some may affect your code.
    I recommend some extra testing before using this release.
    Or perhaps I'm just being over cautious...
  
    Fixed type_info when called for multiple dbh thanks to Cosimo Streppone.
    Fixed compile warnings in bleadperl on freebsd-6.1-release
      and solaris 10g thanks to Philip M. Gollucci.
    Fixed to compile for perl built with -DNO_MATHOMS thanks to Jerry D. Hedden.
    Fixed to work for bleadperl (r29544) thanks to Nicholas Clark.
      Users of Perl >= 5.9.5 will require DBI >= 1.54.
    Fixed rare error when profiling access to $DBI::err etc tied variables.
    Fixed DBI::ProfileDumper to not be affected by changes to $/ and $,
      thanks to Michael Schwern.
  
    Changed t/40profile.t to skip tests for perl < 5.8.0.
    Changed setting trace file to no longer write "Trace file set" to new file.
    Changed 'handle cleared whilst still active' warning for dbh
      to only be given for dbh that have active sth or are not AutoCommit.
    Changed take_imp_data to call finish on all Active child sth.
    Changed DBI::PurePerl trace() method to be more consistent.
    Changed set_err method to effectively not append to errstr if the new errstr
      is the same as the current one.
    Changed handle factory methods, like connect, prepare, and table_info,
      to copy any error/warn/info state of the handle being returned
      up into the handle the method was called on.
    Changed row buffer handling to not alter NUM_OF_FIELDS if it's
      inconsistent with number of elements in row buffer array.
    Updated DBI::DBD docs re handling multiple result sets.
    Updated DBI::DBD docs for driver authors thanks to Ammon Riley
      and Dean Arnold.
    Updated column_info docs to note that if a table doesn't exist
      you get an sth for an empty result set and not an error.
  
    Added new DBD::Gofer 'stateless proxy' driver and framework,
      and the DBI test suite is now also executed via DBD::Gofer,
      and DBD::Gofer+DBI::PurePerl, in addition to DBI::PurePerl.
    Added ability for trace() to support filehandle argument,
      including tracing into a string, thanks to Dean Arnold.
    Added ability for drivers to implement func() method
      so proxy drivers can proxy the func method itself.
    Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5))
    Added $h->private_attribute_info method.
  
  =head2 Changes in DBI 1.53 (svn rev 7995),   31st October 2006
  
    Fixed checks for weaken to work with early 5.8.x versions
    Fixed DBD::Proxy handling of some methods, including commit and rollback.
    Fixed t/40profile.t to be more insensitive to long double precision.
    Fixed t/40profile.t to be insensitive to small negative shifts in time
      thanks to Jamie McCarthy.
    Fixed t/40profile.t to skip tests for perl < 5.8.0.
    Fixed to work with current 'bleadperl' (~5.9.5) thanks to Steve Peters.
      Users of Perl >= 5.9.5 will require DBI >= 1.53.
    Fixed to be more robust against drivers not handling multiple result
      sets properly, thanks to Gisle Aas.
  
    Added array context support to execute_array and execute_for_fetch
      methods which returns executed tuples and rows affected.
    Added Tie::Cache::LRU example to docs thanks to Brandon Black.
  
  =head2 Changes in DBI 1.52 (svn rev 6840),   30th July 2006
  
    Fixed memory leak (per handle) thanks to Nicholas Clark and Ephraim Dan.
    Fixed memory leak (16 bytes per sth) thanks to Doru Theodor Petrescu.
    Fixed execute_for_fetch/execute_array to RaiseError thanks to Martin J. Evans.
    Fixed for perl 5.9.4. Users of Perl >= 5.9.4 will require DBI >= 1.52.
  
    Updated DBD::File to 0.35 to match the latest release on CPAN.
  
    Added $dbh->statistics_info specification thanks to Brandon Black.
  
    Many changes and additions to profiling:
      Profile Path can now uses sane strings instead of obscure numbers,
      can refer to attributes, assorted magical values, and even code refs!
      Parsing of non-numeric DBI_PROFILE env var values has changed.
      Changed DBI::Profile docs extensively - many new features.
      See DBI::Profile docs for more information.
  
  =head2 Changes in DBI 1.51 (svn rev 6475),   6th June 2006
  
    Fixed $dbh->clone method 'signature' thanks to Jeffrey Klein.
    Fixed default ping() method to return false if !$dbh->{Active}.
    Fixed t/40profile.t to be insensitive to long double precision.
    Fixed for perl 5.8.0's more limited weaken() function.
    Fixed DBD::Proxy to not alter $@ in disconnect or AUTOLOADd methods.
    Fixed bind_columns() to use return set_err(...) instead of die()
      to report incorrect number of parameters, thanks to Ben Thul.
    Fixed bind_col() to ignore undef as bind location, thanks to David Wheeler.
    Fixed for perl 5.9.x for non-threaded builds thanks to Nicholas Clark.
      Users of Perl >= 5.9.x will require DBI >= 1.51.
    Fixed fetching of rows as hash refs to preserve utf8 on field names
      from $sth->{NAME} thanks to Alexey Gaidukov.
    Fixed build on Win32 (dbd_postamble) thanks to David Golden.
  
    Improved performance for thread-enabled perls thanks to Gisle Aas.
    Drivers can now use PERL_NO_GET_CONTEXT thanks to Gisle Aas.
      Driver authors please read the notes in the DBI::DBD docs.
    Changed DBI::Profile format to always include a percentage,
      if not exiting then uses time between the first and last DBI call.
    Changed DBI::ProfileData to be more forgiving of systems with
      unstable clocks (where time may go backwards occasionally).
    Clarified the 'Subclassing the DBI' docs.
    Assorted minor changes to docs from comments on annocpan.org.
    Changed Makefile.PL to avoid incompatible options for old gcc.
  
    Added 'fetch array of hash refs' example to selectall_arrayref
      docs thanks to Tom Schindl.
    Added docs for $sth->{ParamArrays} thanks to Martin J. Evans.
    Added reference to $DBI::neat_maxlen in TRACING section of docs.
    Added ability for DBI::Profile Path to include attributes
      and a summary of where the code was called from.
  
  =head2 Changes in DBI 1.50 (svn rev 2307),   13 December 2005
  
    Fixed Makefile.PL options for gcc bug introduced in 1.49.
    Fixed handle magic order to keep DBD::Oracle happy.
    Fixed selectrow_array to return empty list on error.
  
    Changed dbi_profile_merge() to be able to recurse and merge
      sub-trees of profile data.
  
    Added documentation for dbi_profile_merge(), including how to
      measure the time spent inside the DBI for an http request.
  
  =head2 Changes in DBI 1.49 (svn rev 2287),   29th November 2005
  
    Fixed assorted attribute handling bugs in DBD::Proxy.
    Fixed croak() in DBD::NullP thanks to Sergey Skvortsov.
    Fixed handling of take_imp_data() and dbi_imp_data attribute.
    Fixed bugs in DBD::DBM thanks to Jeff Zucker.
    Fixed bug in DBI::ProfileDumper thanks to Sam Tregar.
    Fixed ping in DBD::Proxy thanks to George Campbell.
    Fixed dangling ref in $sth after parent $dbh destroyed
      with thanks to il@rol.ru for the bug report #13151
    Fixed prerequisites to include Storable thanks to Michael Schwern.
    Fixed take_imp_data to be more practical.
  
    Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0.
    Changed internals to be more strictly coded thanks to Andy Lester.
    Changed warning about multiple copies of Driver.xst found in @INC
      to ignore duplicated directories thanks to Ed Avis.
    Changed Driver.xst to enable drivers to define an dbd_st_prepare_sv
      function where the statement parameter is an SV. That enables
      compiled drivers to support SQL strings that are UTF-8.
    Changed "use DBI" to only set $DBI::connect_via if not already set.
    Changed docs to clarify pre-method clearing of err values.
  
    Added ability for DBI::ProfileData to edit profile path on loading.
      This enables aggregation of different SQL statements into the same
      profile node - very handy when not using placeholders or when working
      multiple separate tables for the same thing (ie logtable_2005_11_28)
    Added $sth->{ParamTypes} specification thanks to Dean Arnold.
    Added $h->{Callbacks} attribute to enable code hooks to be invoked
      when certain methods are called. For example:
      $dbh->{Callbacks}->{prepare} = sub { ... };
      With thanks to David Wheeler for the kick start.
    Added $h->{ChildHandles} (using weakrefs) thanks to Sam Tregar
      I've recoded it in C so there's no significant performance impact.
    Added $h->{Type} docs (returns 'dr', 'db', or 'st')
    Adding trace message in DESTROY if InactiveDestroy enabled.
    Added %drhs = DBI->installed_drivers();
  
    Ported DBI::ProfileDumper::Apache to mod_perl2 RC5+
      thanks to Philip M. Golluci
  
  =head2 Changes in DBI 1.48 (svn rev 928),    14th March 2005
  
    Fixed DBI::DBD::Metadata generation of type_info_all thanks to Steffen Goeldner
      (driver authors who have used it should rerun it).
  
    Updated docs for NULL Value placeholders thanks to Brian Campbell.
    
    Added multi-keyfield nested hash fetching to fetchall_hashref()
      thanks to Zhuang (John) Li for polishing up my draft.
    Added registered driver prefixes: amzn_ for DBD::Amazon and yaswi_ for DBD::Yaswi.
  
  
  =head2 Changes in DBI 1.47 (svn rev 854),    2nd February 2005
  
    Fixed DBI::ProxyServer to not create pid files by default.
      References: Ubuntu Security Notice USN-70-1, CAN-2005-0077
      Thanks to Javier Fernndez-Sanguino Pea from the
      Debian Security Audit Project, and Jonathan Leffler.
    Fixed some tests to work with older Test::More versions.
    Fixed setting $DBI::err/errstr in DBI::PurePerl.
    Fixed potential undef warning from connect_cached().
    Fixed $DBI::lasth handling for DESTROY so lasth points to
      parent even if DESTROY called other methods.
    Fixed DBD::Proxy method calls to not alter $@.
    Fixed DBD::File problem with encoding pragma thanks to Erik Rijkers.
  
    Changed error handling so undef errstr doesn't cause warning.
    Changed DBI::DBD docs to use =head3/=head4 pod thanks to
      Jonathan Leffler. This may generate warnings for perl 5.6.
    Changed DBI::PurePerl to set autoflush on trace filehandle.
    Changed DBD::Proxy to treat Username as a local attribute
      so recent DBI version can be used with old DBI::ProxyServer.
    Changed driver handle caching in DBD::File.
    Added $GetInfoType{SQL_DATABASE_NAME} thanks to Steffen Goeldner.
  
    Updated docs to recommend some common DSN string attributes.
    Updated connect_cached() docs with issues and suggestions.
    Updated docs for NULL Value placeholders thanks to Brian Campbell.
    Updated docs for primary_key_info and primary_keys.
    Updated docs to clarify that the default fetchrow_hashref behaviour,
      of returning a ref to a new hash for each row, will not change.
    Updated err/errstr/state docs for DBD authors thanks to Steffen Goeldner.
    Updated handle/attribute docs for DBD authors thanks to Steffen Goeldner.
    Corrected and updated LongReadLen docs thanks to Bart Lateur.
    Added DBD::JDBC as a registered driver.
  
  =head2 Changes in DBI 1.46 (svn rev 584),    16th November 2004
  
    Fixed parsing bugs in DBI::SQL::Nano thanks to Jeff Zucker.
    Fixed a couple of bad links in docs thanks to Graham Barr.
    Fixed test.pl Win32 undef warning thanks to H.Merijn Brand & David Repko.
    Fixed minor issues in DBI::DBD::Metadata thanks to Steffen Goeldner.
    Fixed DBI::PurePerl neat() to use double quotes for utf8.
  
    Changed execute_array() definition, and default implementation,
      to not consider scalar values for execute tuple count. See docs.
    Changed DBD::File to enable ShowErrorStatement by default,
      which affects DBD::File subclasses such as DBD::CSV and DBD::DBM.
    Changed use DBI qw(:utils) tag to include $neat_maxlen.
    Updated Roadmap and ToDo.
  
    Added data_string_diff() data_string_desc() and data_diff()
      utility functions to help diagnose Unicode issues.
      All can be imported via the use DBI qw(:utils) tag.
  
  =head2 Changes in DBI 1.45 (svn rev 480),    6th October 2004
  
    Fixed DBI::DBD code for drivers broken in 1.44.
    Fixed "Free to wrong pool"/"Attempt to free unreferenced scalar" in FETCH.
  
  =head2 Changes in DBI 1.44 (svn rev 478),    5th October 2004
  
    Fixed build issues on VMS thanks to Jakob Snoer.
    Fixed DBD::File finish() method to return 1 thanks to Jan Dubois.
    Fixed rare core dump during global destruction thanks to Mark Jason Dominus.
    Fixed risk of utf8 flag persisting from one row to the next.
  
    Changed bind_param_array() so it doesn't require all bind arrays
      to have the same number of elements.
    Changed bind_param_array() to error if placeholder number <= 0.
    Changed execute_array() definition, and default implementation,
      to effectively NULL-pad shorter bind arrays.
    Changed execute_array() to return "0E0" for 0 as per the docs.
    Changed execute_for_fetch() definition, and default implementation,
      to return "0E0" for 0 like execute() and execute_array().
    Changed Test::More prerequisite to Test::Simple (which is also the name
      of the distribution both are packaged in) to work around ppm behaviour.
  
    Corrected docs to say that get/set of unknown attribute generates
      a warning and is no longer fatal. Thanks to Vadim.
    Corrected fetchall_arrayref() docs example thanks to Drew Broadley.
  
    Added $h1->swap_inner_handle($h2) sponsored by BizRate.com
  
  
  =head2 Changes in DBI 1.43 (svn rev 377),    2nd July 2004
  
    Fixed connect() and connect_cached() RaiseError/PrintError
      which would sometimes show "(no error string)" as the error.
    Fixed compiler warning thanks to Paul Marquess.
    Fixed "trace level set to" trace message thanks to H.Merijn Brand.
    Fixed DBD::DBM $dbh->{dbm_tables}->{...} to be keyed by the
      table name not the file name thanks to Jeff Zucker.
    Fixed last_insert_id(...) thanks to Rudy Lippan.
    Fixed propagation of scalar/list context into proxied methods.
    Fixed DBI::Profile::DESTROY to not alter $@.
    Fixed DBI::ProfileDumper new() docs thanks to Michael Schwern.
    Fixed _load_class to propagate $@ thanks to Drew Taylor.
    Fixed compile warnings on Win32 thanks to Robert Baron.
    Fixed problem building with recent versions of MakeMaker.
    Fixed DBD::Sponge not to generate warning with threads.
    Fixed DBI_AUTOPROXY to work more than once thanks to Steven Hirsch.
  
    Changed TraceLevel 1 to not show recursive/nested calls.
    Changed getting or setting an invalid attribute to no longer be
      a fatal error but generate a warning instead.
    Changed selectall_arrayref() to call finish() if
      $attr->{MaxRows} is defined.
    Changed all tests to use Test::More and enhanced the tests thanks
      to Stevan Little and Andy Lester. See http://qa.perl.org/phalanx/
    Changed Test::More minimum prerequisite version to 0.40 (2001).
    Changed DBI::Profile header to include the date and time.
  
    Added DBI->parse_dsn($dsn) method.
    Added warning if build directory path contains white space.
    Added docs for parse_trace_flags() and parse_trace_flag().
    Removed "may change" warnings from the docs for table_info(),
      primary_key_info(), and foreign_key_info() methods.
  
  =head2 Changes in DBI 1.42 (svn rev 222),    12th March 2004
  
    Fixed $sth->{NUM_OF_FIELDS} of non-executed statement handle
      to be undef as per the docs (it was 0).
    Fixed t/41prof_dump.t to work with perl5.9.1.
    Fixed DBD_ATTRIB_DELETE macro thanks to Marco Paskamp.
    Fixed DBI::PurePerl looks_like_number() and $DBI::rows.
    Fixed ref($h)->can("foo") to not croak.
  
    Changed attributes (NAME, TYPE etc) of non-executed statement
      handle to be undef instead of triggering an error.
    Changed ShowErrorStatement to apply to more $dbh methods.
    Changed DBI_TRACE env var so just does this at load time:
      DBI->trace(split '=', $ENV{DBI_TRACE}, 2);
    Improved "invalid number of parameters" error message.
    Added DBI::common as base class for DBI::db, DBD::st etc.
    Moved methods common to all handles into DBI::common.
  
    Major tracing enhancement:
  
    Added $h->parse_trace_flags("foo|SQL|7") to map a group of
      trace flags into the corresponding trace flag bits.
    Added automatic calling of parse_trace_flags() if
      setting the trace level to a non-numeric value:
      $h->{TraceLevel}="foo|SQL|7"; $h->trace("foo|SQL|7");
      DBI->connect("dbi:Driver(TraceLevel=SQL|foo):...", ...);
      Currently no trace flags have been defined.
    Added to, and reworked, the trace documentation.
    Added dbivport.h for driver authors to use.
  
    Major driver additions that Jeff Zucker and I have been working on:
  
    Added DBI::SQL::Nano a 'smaller than micro' SQL parser
      with an SQL::Statement compatible API. If SQL::Statement
      is installed then DBI::SQL::Nano becomes an empty subclass
      of SQL::Statement, unless the DBI_SQL_NANO env var is true.
    Added DBD::File, modified to use DBI::SQL::Nano.
    Added DBD::DBM, an SQL interface to DBM files using DBD::File.
  
    Documentation changes:
  
    Corrected typos in docs thanks to Steffen Goeldner.
    Corrected execute_for_fetch example thanks to Dean Arnold.
  
  =head2 Changes in DBI 1.41 (svn rev 130),    22nd February 2004
  
    Fixed execute_for_array() so tuple_status parameter is optional
      as per docs, thanks to Ed Avis.
    Fixed execute_for_array() docs to say that it returns undef if
      any of the execute() calls fail.
    Fixed take_imp_data() test on m68k reported by Christian Hammers.
    Fixed write_typeinfo_pm inconsistencies in DBI::DBD::Metadata
      thanks to Andy Hassall.
    Fixed $h->{TraceLevel} to not return DBI->trace trace level
      which it used to if DBI->trace trace level was higher.
  
    Changed set_err() to append to errstr, with a leading "\n" if it's
      not empty, so that multiple error/warning messages are recorded.
    Changed trace to limit elements dumped when an array reference is
      returned from a method to the max(40, $DBI::neat_maxlen/10)
      so that fetchall_arrayref(), for example, doesn't flood the trace.
    Changed trace level to be a four bit integer (levels 0 thru 15)
      and a set of topic flags (no topics have been assigned yet).
    Changed column_info() to check argument count.
    Extended bind_param() TYPE attribute specification to imply
      standard formating of value, eg SQL_DATE implies 'YYYY-MM-DD'.
  
    Added way for drivers to indicate 'success with info' or 'warning'
      by setting err to "0" for warning and "" for information.
      Both values are false and so don't trigger RaiseError etc.
      Thanks to Steffen Goeldner for the original idea.
    Added $h->{HandleSetErr} = sub { ... } to be called at the
      point that an error, warn, or info state is recorded.
      The code can alter the err, errstr, and state values
      (e.g., to promote an error to a warning, or the reverse).
    Added $h->{PrintWarn} attribute to enable printing of warnings
      recorded by the driver. Defaults to same value as $^W (perl -w).
    Added $h->{ErrCount} attribute, incremented whenever an error is
      recorded by the driver via set_err().
    Added $h->{Executed} attribute, set if do()/execute() called.
    Added \%attr parameter to foreign_key_info() method.
    Added ref count of inner handle to "DESTROY ignored for outer" msg.
    Added Win32 build config checks to DBI::DBD thanks to Andy Hassall.
    Added bind_col to Driver.xst so drivers can define their own.
    Added TYPE attribute to bind_col and specified the expected
      driver behaviour.
  
    Major update to signal handling docs thanks to Lincoln Baxter.
    Corrected dbiproxy usage doc thanks to Christian Hammers.
    Corrected type_info_all index hash docs thanks to Steffen Goeldner.
    Corrected type_info COLUMN_SIZE to chars not bytes thanks to Dean Arnold.
    Corrected get_info() docs to include details of DBI::Const::GetInfoType.
    Clarified that $sth->{PRECISION} is OCTET_LENGTH for char types.
  
  =head2 Changes in DBI 1.40,    7th January 2004
  
    Fixed handling of CachedKids when DESTROYing threaded handles.
    Fixed sql_user_name() in DBI::DBD::Metadata (used by write_getinfo_pm)
      to use $dbh->{Username}. Driver authors please update your code.
  
    Changed connect_cached() when running under Apache::DBI
      to route calls to Apache::DBI::connect().
  
    Added CLONE() to DBD::Sponge and DBD::ExampleP.
    Added warning when starting a new thread about any loaded driver
      which does not have a CLONE() function.
    Added new prepare_cache($sql, \%attr, 3) option to manage Active handles.
    Added SCALE and NULLABLE support to DBD::Sponge.
    Added missing execute() in fetchall_hashref docs thanks to Iain Truskett.
    Added a CONTRIBUTING section to the docs with notes on creating patches.
  
  =head2 Changes in DBI 1.39,    27th November 2003
  
    Fixed STORE to not clear error during nested DBI call, again/better,
      thanks to Tony Bowden for the report and helpful test case.
    Fixed DBI dispatch to not try to use AUTOLOAD for driver methods unless
      the method has been declared (as methods should be when using AUTOLOAD).
      This fixes a problem when the Attribute::Handlers module is loaded.
    Fixed cwd check code to use $Config{path_sep} thanks to Steve Hay.
    Fixed unqualified croak() calls thanks to Steffen Goeldner.
    Fixed DBD::ExampleP TYPE and PRECISION attributes thanks to Tom Lowery.
    Fixed tracing of methods that only get traced at high trace levels.
  
    The level 1 trace no longer includes nested method calls so it generally
      just shows the methods the application explicitly calls.
    Added line to trace log (level>=4) when err/errstr is cleared.
    Updated docs for InactiveDestroy and point out where and when the
      trace includes the process id.
    Update DBI::DBD docs thanks to Steffen Goeldner.
    Removed docs saying that the DBI->data_sources method could be
      passed a $dbh. The $dbh->data_sources method should be used instead.
    Added link to 'DBI recipes' thanks to Giuseppe Maxia:
      http://gmax.oltrelinux.com/dbirecipes.html (note that this
      is not an endorsement that the recipies are 'optimal')
  
    Note: There is a bug in perl 5.8.2 when configured with threads
    and debugging enabled (bug #24463) which causes a DBI test to fail.
  
  =head2 Changes in DBI 1.38,    21th August 2003
  
    NOTE: The DBI now requires perl version 5.6.0 or later.
    (As per notice in DBI 1.33 released 27th February 2003)
  
    Fixed spurious t/03handles failure on 64bit perls reported by H.Merijn Brand.
    Fixed spurious t/15array failure on some perl versions thanks to Ed Avis.
    Fixed build using dmake on windows thanks to Steffen Goeldner.
    Fixed build on using some shells thanks to Gurusamy Sarathy.
    Fixed ParamValues to only be appended to ShowErrorStatement if not empty.
    Fixed $dbh->{Statement} not being writable by drivers in some cases.
    Fixed occasional undef warnings on connect failures thanks to Ed Avis.
    Fixed small memory leak when using $sth->{NAME..._hash}.
    Fixed 64bit warnings thanks to Marian Jancar.
    Fixed DBD::Proxy::db::DESTROY to not alter $@ thanks to Keith Chapman.
    Fixed Makefile.PL status from WriteMakefile() thanks to Leon Brocard.
  
    Changed "Can't set ...->{Foo}: unrecognised attribute" from an error to a
      warning when running with DBI::ProxyServer to simplify upgrades.
    Changed execute_array() to no longer require ArrayTupleStatus attribute.
    Changed DBI->available_drivers to not hide DBD::Sponge.
    Updated/moved placeholder docs to a better place thanks to Johan Vromans.
    Changed dbd_db_do4 api in Driver.xst to match dbd_st_execute (return int,
      not bool), relevant only to driver authors.
    Changed neat(), and thus trace(), so strings marked as utf8 are presented
      in double quotes instead of single quotes and are not sanitized.
  
    Added $dbh->data_sources method.
    Added $dbh->last_insert_id method.
    Added $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status) method.
    Added DBI->installed_versions thanks to Jeff Zucker.
    Added $DBI::Profile::ON_DESTROY_DUMP variable.
    Added docs for DBD::Sponge thanks to Mark Stosberg.
  
  =head2 Changes in DBI 1.37,    15th May 2003
  
    Fixed "Can't get dbh->{Statement}: unrecognised attribute" error in test
      caused by change to perl internals in 5.8.0
    Fixed to build with latest development perl (5.8.1@19525).
    Fixed C code to use all ANSI declarations thanks to Steven Lembark.
  
  =head2 Changes in DBI 1.36,    11th May 2003
  
    Fixed DBI->connect to carp instead of croak on 'old-style' usage.
    Fixed connect(,,, { RootClass => $foo }) to not croak if module not found.
    Fixed code generated by DBI::DBD::Metadata thanks to DARREN@cpan.org (#2270)
    Fixed DBI::PurePerl to not reset $@ during method dispatch.
    Fixed VMS build thanks to Michael Schwern.
    Fixed Proxy disconnect thanks to Steven Hirsch.
    Fixed error in DBI::DBD docs thanks to Andy Hassall.
  
    Changed t/40profile.t to not require Time::HiRes.
    Changed DBI::ProxyServer to load DBI only on first request, which
      helps threaded server mode, thanks to Bob Showalter.
    Changed execute_array() return value from row count to executed
      tuple count, and now the ArrayTupleStatus attribute is mandatory.
      NOTE: That is an API definition change that may affect your code.
    Changed CompatMode attribute to also disable attribute 'quick FETCH'.
    Changed attribute FETCH to be slightly faster thanks to Stas Bekman.
  
    Added workaround for perl bug #17575 tied hash nested FETCH
      thanks to Silvio Wanka.
    Added Username and Password attributes to connect(..., \%attr) and so
      also embedded in DSN like "dbi:Driver(Username=user,Password=pass):..."
      Username and Password can't contain ")", ",", or "=" characters.
      The predence is DSN first, then \%attr, then $user & $pass parameters,
      and finally the DBI_USER & DBI_PASS environment variables.
      The Username attribute is stored in the $dbh but the Password is not.
    Added ProxyServer HOWTO configure restrictions docs thanks to Jochen Wiedmann.
    Added MaxRows attribute to selectcol_arrayref prompted by Wojciech Pietron.
    Added dump_handle as a method not just a DBI:: utility function.
    Added on-demand by-row data feed into execute_array() using code ref,
      or statement handle. For example, to insert from a select:
      $insert_sth->execute_array( { ArrayTupleFetch => $select_sth, ... } )
    Added warning to trace log when $h->{foo}=... is ignored due to
      invalid prefix (e.g., not 'private_').
  
  =head2 Changes in DBI 1.35,    7th March 2003
  
    Fixed memory leak in fetchrow_hashref introduced in DBI 1.33.
    Fixed various DBD::Proxy errors introduced in DBI 1.33.
    Fixed to ANSI C in dbd_dr_data_sources thanks to Jonathan Leffler.
    Fixed $h->can($method_name) to return correct code ref.
    Removed DBI::Format from distribution as it's now part of the
      separate DBI::Shell distribution by Tom Lowery.
    Updated DBI::DBD docs with a note about the CLONE method.
    Updated DBI::DBD docs thanks to Jonathan Leffler.
    Updated DBI::DBD::Metadata for perl 5.5.3 thanks to Jonathan Leffler.
    Added note to install_method docs about setup_driver() method.
  
  =head2 Changes in DBI 1.34,    28th February 2003
  
    Fixed DBI::DBD docs to refer to DBI::DBD::Metadata thanks to Jonathan Leffler.
    Fixed dbi_time() compile using BorlandC on Windows thanks to Steffen Goeldner.
    Fixed profile tests to do enough work to measure on Windows.
    Fixed disconnect_all() to not be required by drivers.
  
    Added $okay = $h->can($method_name) to check if a method exists.
    Added DBD::*::*->install_method($method_name, \%attr) so driver private
      methods can be 'installed' into the DBI dispatcher and no longer
      need to be called using $h->func(..., $method_name).
  
    Enhanced $dbh->clone() and documentation.
    Enhanced docs to note that dbi_time(), and thus profiling, is limited
      to only millisecond (seconds/1000) resolution on Windows.
    Removed old DBI::Shell from distribution and added Tom Lowery's improved
      version to the Bundle::DBI file.
    Updated minimum version numbers for modules in Bundle::DBI.
  
  =head2 Changes in DBI 1.33,    27th February 2003
  
    NOTE: Future versions of the DBI *will not* support perl 5.6.0 or earlier.
    : Perl 5.6.1 will be the minimum supported version.
  
    NOTE: The "old-style" connect: DBI->connect($database, $user, $pass, $driver);
    : has been deprecated for several years and will now generate a warning.
    : It will be removed in a later release. Please change any old connect() calls.
  
    Added $dbh2 = $dbh1->clone to make a new connection to the database
      that is identical to the original one. clone() can be called even after
      the original handle has been disconnected. See the docs for more details.
  
    Fixed merging of profile data to not sum DBIprof_FIRST_TIME values.
    Fixed unescaping of newlines in DBI::ProfileData thanks to Sam Tregar.
    Fixed Taint bug with fetchrow_hashref with help from Bradley Baetz.
    Fixed $dbh->{Active} for DBD::Proxy, reported by Bob Showalter.
    Fixed STORE to not clear error during nested DBI call,
      thanks to Tony Bowden for the report and helpful test case.
    Fixed DBI::PurePerl error clearing behaviour.
    Fixed dbi_time() and thus DBI::Profile on Windows thanks to Smejkal Petr.
    Fixed problem that meant ShowErrorStatement could show wrong statement,
     thanks to Ron Savage for the report and test case.
    Changed Apache::DBI hook to check for $ENV{MOD_PERL} instead of
      $ENV{GATEWAY_INTERFACE} thanks to Ask Bjoern Hansen.
    No longer tries to dup trace logfp when an interpreter is being cloned.
    Database handles no longer inherit shared $h->err/errstr/state storage
      from their drivers, so each $dbh has it's own $h->err etc. values
      and is no longer affected by calls made on other dbh's.
      Now when a dbh is destroyed it's err/errstr/state values are copied
      up to the driver so checking $DBI::errstr still works as expected.
  
    Build / portability fixes:
      Fixed t/40profile.t to not use Time::HiRes.
      Fixed t/06attrs.t to not be locale sensitive, reported by Christian Hammers.
      Fixed sgi compiler warnings, reported by Paul Blake.
      Fixed build using make -j4, reported by Jonathan Leffler.
      Fixed build and tests under VMS thanks to Craig A. Berry.
  
    Documentation changes:
      Documented $high_resolution_time = dbi_time() function.
      Documented that bind_col() can take an atribute hash.
      Clarified documentation for ParamValues attribute hash keys.
      Many good DBI documentation tweaks from Jonathan Leffler,
        including a major update to the DBI::DBD driver author guide.
      Clarified that execute() should itself call finish() if it's
        called on a statement handle that's still active.
      Clarified $sth->{ParamValues}. Driver authors please note.
      Removed "NEW" markers on some methods and attributes and
        added text to each giving the DBI version it was added in,
        if it was added after DBI 1.21 (Feb 2002).
  
    Changes of note for authors of all drivers:
      Added SQL_DATA_TYPE, SQL_DATETIME_SUB, NUM_PREC_RADIX, and
        INTERVAL_PRECISION fields to docs for type_info_all. There were
        already in type_info(), but type_info_all() didn't specify the
        index values.  Please check and update your type_info_all() code.
      Added DBI::DBD::Metadata module that auto-generates your drivers
        get_info and type_info_all data and code, thanks mainly to
        Jonathan Leffler and Steffen Goeldner. If you've not implemented
        get_info and type_info_all methods and your database has an ODBC
        driver available then this will do all the hard work for you!
      Drivers should no longer pass Err, Errstr, or State to _new_drh
        or _new_dbh functions.
      Please check that you support the slightly modified behaviour of
        $sth->{ParamValues}, e.g., always return hash with keys if possible.
  
    Changes of note for authors of compiled drivers:
      Added dbd_db_login6 & dbd_st_finish3 prototypes thanks to Jonathan Leffler.
      All dbd_*_*() functions implemented by drivers must have a
        corresponding #define dbd_*_* <driver_prefix>_*_* otherwise
        the driver may not work with a future release of the DBI.
  
    Changes of note for authors of drivers which use Driver.xst:
      Some new method hooks have been added are are enabled by
        defining corresponding macros:
            $drh->data_sources()      - dbd_dr_data_sources
            $dbh->do()                - dbd_db_do4
      The following methods won't be compiled into the driver unless
        the corresponding macro has been #defined:
            $drh->disconnect_all()    - dbd_discon_all
  
  
  =head2 Changes in DBI 1.32,    1st December 2002
  
    Fixed to work with 5.005_03 thanks to Tatsuhiko Miyagawa (I've not tested it).
    Reenabled taint tests (accidentally left disabled) spotted by Bradley Baetz.
    Improved docs for FetchHashKeyName attribute thanks to Ian Barwick.
    Fixed core dump if fetchrow_hashref given bad argument (name of attribute
      with a value that wasn't an array reference), spotted by Ian Barwick.
    Fixed some compiler warnings thanks to David Wheeler.
    Updated Steven Hirsch's enhanced proxy work (seems I left out a bit).
    Made t/40profile.t tests more reliable, reported by Randy, who is part of
      the excellent CPAN testers team: http://testers.cpan.org/
      (Please visit, see the valuable work they do and, ideally, join in!)
  
  =head2 Changes in DBI 1.31,    29th November 2002
  
    The fetchall_arrayref method, when called with a $maxrows parameter,
      no longer gives an error if called again after all rows have been
      fetched. This simplifies application logic when fetching in batches.
      Also added batch-fetch while() loop example to the docs.
    The proxy now supports non-lazy (synchronous) prepare, positioned
      updates (for selects containing 'for update'), PlRPC config set
      via attributes, and accurate propagation of errors, all thanks
      to Steven Hirsch (plus a minor fix from Sean McMurray and doc
      tweaks from Michael A Chase).
    The DBI_AUTOPROXY env var can now hold the full dsn of the proxy driver
      plus attributes, like "dbi:Proxy(proxy_foo=>1):host=...".
    Added TaintIn & TaintOut attributes to give finer control over
      tainting thanks to Bradley Baetz.
    The RootClass attribute no longer ignores failure to load a module,
      but also doesn't try to load a module if the class already exists,
      with thanks to James FitzGibbon.
    HandleError attribute works for connect failures thanks to David Wheeler.
    The connect() RaiseError/PrintError message now includes the username.
    Changed "last handle unknown or destroyed" warning to be a trace message.
    Removed undocumented $h->event() method.
    Further enhancements to DBD::PurePerl accuracy.
    The CursorName attribute now defaults to undef and not an error.
  
    DBI::Profile changes:
      New DBI::ProfileDumper, DBI::ProfileDumper::Apache, and
      DBI::ProfileData modules (to manage the storage and processing
      of profile data), plus dbiprof program for analyzing profile
      data - with many thanks to Sam Tregar.
      Added $DBI::err (etc) tied variable lookup time to profile.
      Added time for DESTROY method into parent handles profile (used to be ignored).
  
    Documentation changes:
      Documented $dbh = $sth->{Database} attribute.
      Documented $dbh->connected(...) post-connection call when subclassing.
      Updated some minor doc issues thanks to H.Merijn Brand.
      Updated Makefile.PL example in DBI::DBD thanks to KAWAI,Takanori.
      Fixed execute_array() example thanks to Peter van Hardenberg.
  
    Changes for driver authors, not required but strongly recommended:
      Change DBIS to DBIc_DBISTATE(imp_xxh)   [or imp_dbh, imp_sth etc]
      Change DBILOGFP to DBIc_LOGPIO(imp_xxh) [or imp_dbh, imp_sth etc]
      Any function from which all instances of DBIS and DBILOGFP are
      removed can also have dPERLINTERP removed (a good thing).
      All use of the DBIh_EVENT* macros should be removed.
      Major update to DBI::DBD docs thanks largely to Jonathan Leffler.
      Add these key values: 'Err' => \my $err, 'Errstr' => \my $errstr,
      to the hash passed to DBI::_new_dbh() in your driver source code.
      That will make each $dbh have it's own $h->err and $h->errstr
      values separate from other $dbh belonging to the same driver.
      If you have a ::db or ::st DESTROY methods that do nothing
      you can now remove them - which speeds up handle destruction.
  
  
  =head2 Changes in DBI 1.30,    18th July 2002
  
    Fixed problems with selectrow_array, selectrow_arrayref, and
      selectall_arrayref introduced in DBI 1.29.
    Fixed FETCHing a handle attribute to not clear $DBI::err etc (broken in 1.29).
    Fixed core dump at trace level 9 or above.
    Fixed compilation with perl 5.6.1 + ithreads (i.e. Windows).
    Changed definition of behaviour of selectrow_array when called in a scalar
      context to match fetchrow_array.
    Corrected selectrow_arrayref docs which showed selectrow_array thanks to Paul DuBois.
  
  =head2 Changes in DBI 1.29,    15th July 2002
  
    NOTE: This release changes the specified behaviour for the
    : fetchrow_array method when called in a scalar context:
    : The DBI spec used to say that it would return the FIRST field.
    : Which field it returns (i.e., the first or the last) is now undefined.
    : This does not affect statements that only select one column, which is
    : usually the case when fetchrow_array is called in a scalar context.
    : FYI, this change was triggered by discovering that the fetchrow_array
    : implementation in Driver.xst (used by most compiled drivers) 
    : didn't match the DBI specification. Rather than change the code
    : to match, and risk breaking existing applications, I've changed the
    : specification (that part was always of dubious value anyway).
  
    NOTE: Future versions of the DBI may not support for perl 5.5 much longer.
    : If you are still using perl 5.005_03 you should be making plans to
    : upgrade to at least perl 5.6.1, or 5.8.0. Perl 5.8.0 is due to be
    : released in the next week or so.  (Although it's a "point 0" release,
    : it is the most throughly tested release ever.)
  
    Added XS/C implementations of selectrow_array, selectrow_arrayref, and
      selectall_arrayref to Driver.xst. See DBI 1.26 Changes for more info.
    Removed support for the old (fatally flawed) "5005" threading model.
    Added support for new perl 5.8 iThreads thanks to Gerald Richter.
      (Threading support and safety should still be regarded as beta
      quality until further notice. But it's much better than it was.)
    Updated the "Threads and Thread Safety" section of the docs.
    The trace output can be sent to STDOUT instead of STDERR by using
      "STDOUT" as the name of the file, i.e., $h->trace(..., "STDOUT")
    Added pointer to perlreftut, perldsc, perllol, and perlboot manuals
      into the intro section of the docs, suggested by Brian McCain.
    Fixed DBI::Const::GetInfo::* pod docs thanks to Zack Weinberg.
    Some changes to how $dbh method calls are treated by DBI::Profile:
      Meta-data methods now clear $dbh->{Statement} on entry.
      Some $dbh methods are now profiled as if $dbh->{Statement} was empty
      (because thet're unlikely to actually relate to its contents).
    Updated dbiport.h to ppport.h from perl 5.8.0.
    Tested with perl 5.5.3 (vanilla, Solaris), 5.6.1 (vanilla, Solaris), and
      perl 5.8.0 (RC3@17527 with iThreads & Multiplicity on Solaris and FreeBSD).
  
  =head2 Changes in DBI 1.28,    14th June 2002
  
    Added $sth->{ParamValues} to return a hash of the most recent
      values bound to placeholders via bind_param() or execute().
      Individual drivers need to be updated to support it.
    Enhanced ShowErrorStatement to include ParamValues if available:
      "DBD::foo::st execute failed: errstr [for statement ``...'' with params: 1='foo']"
    Further enhancements to DBD::PurePerl accuracy.
  
  =head2 Changes in DBI 1.27,    13th June 2002
  
    Fixed missing column in C implementation of fetchall_arrayref()
      thanks to Philip Molter for the prompt reporting of the problem.
  
  =head2 Changes in DBI 1.26,    13th June 2002
  
    Fixed t/40profile.t to work on Windows thanks to Smejkal Petr.
    Fixed $h->{Profile} to return undef, not error, if not set.
    Fixed DBI->available_drivers in scalar context thanks to Michael Schwern.
  
    Added C implementations of selectrow_arrayref() and fetchall_arrayref()
      in Driver.xst.  All compiled drivers using Driver.xst will now be
      faster making those calls. Most noticable with fetchall_arrayref for
      many rows or selectrow_arrayref with a fast query. For example, using
      DBD::mysql a selectrow_arrayref for a single row using a primary key
      is ~20% faster, and fetchall_arrayref for 20000 rows is twice as fast!
      Drivers just need to be recompiled and reinstalled to enable it.
      The fetchall_arrayref speed up only applies if $slice parameter is not used.
    Added $max_rows parameter to fetchall_arrayref() to optionally limit
      the number of rows returned. Can now fetch batches of rows.
    Added MaxRows attribute to selectall_arrayref()
      which then passes it to fetchall_arrayref().
    Changed selectrow_array to make use of selectrow_arrayref.
    Trace level 1 now shows first two parameters of all methods
      (used to only for that for some, like prepare,execute,do etc)
    Trace indicator for recursive calls (first char on trace lines)
      now starts at 1 not 2.
  
    Documented that $h->func() does not trigger RaiseError etc
      so applications must explicitly check for errors.
    DBI::Profile with DBI_PROFILE now shows percentage time inside DBI.
    HandleError docs updated to show that handler can edit error message.
    HandleError subroutine interface is now regarded as stable.
  
  =head2 Changes in DBI 1.25,    5th June 2002
  
    Fixed build problem on Windows and some compiler warnings.
    Fixed $dbh->{Driver} and $sth->{Statement} for driver internals
      These are 'inner' handles as per behaviour prior to DBI 1.16.
    Further minor improvements to DBI::PurePerl accuracy.
  
  =head2 Changes in DBI 1.24,    4th June 2002
  
    Fixed reference loop causing a handle/memory leak
      that was introduced in DBI 1.16.
    Fixed DBI::Format to work with 'filehandles' from IO::Scalar
      and similar modules thanks to report by Jeff Boes.
    Fixed $h->func for DBI::PurePerl thanks to Jeff Zucker.
    Fixed $dbh->{Name} for DBI::PurePerl thanks to Dean Arnold.
  
    Added DBI method call profiling and benchmarking.
      This is a major new addition to the DBI.
      See $h->{Profile} attribute and DBI::Profile module.
      For a quick trial, set the DBI_PROFILE environment variable and
      run your favourite DBI script. Try it with DBI_PROFILE set to 1,
      then try 2, 4, 8, 10, and -10. Have fun!
  
    Added execute_array() and bind_param_array() documentation
      with thanks to Dean Arnold.
    Added notes about the DBI having not yet been tested with iThreads
      (testing and patches for SvLOCK etc welcome).
    Removed undocumented Handlers attribute (replaced by HandleError).
    Tested with 5.5.3 and 5.8.0 RC1.
  
  =head2 Changes in DBI 1.23,    25th May 2002
  
    Greatly improved DBI::PurePerl in performance and accuracy.
    Added more detail to DBI::PurePerl docs about what's not supported.
    Fixed undef warnings from t/15array.t and DBD::Sponge.
  
  =head2 Changes in DBI 1.22,    22nd May 2002
  
    Added execute_array() and bind_param_array() with special thanks
      to Dean Arnold. Not yet documented. See t/15array.t for examples.
      All drivers now automatically support these methods.
    Added DBI::PurePerl, a transparent DBI emulation for pure-perl drivers
      with special thanks to Jeff Zucker. Perldoc DBI::PurePerl for details.
    Added DBI::Const::GetInfo* modules thanks to Steffen Goeldner.
    Added write_getinfo_pm utility to DBI::DBD thanks to Steffen Goeldner.
    Added $allow_active==2 mode for prepare_cached() thanks to Stephen Clouse.
  
    Updated DBI::Format to Revision 11.4 thanks to Tom Lowery.
    Use File::Spec in Makefile.PL (helps VMS etc) thanks to Craig Berry.
    Extend $h->{Warn} to commit/rollback ineffective warning thanks to Jeff Baker.
    Extended t/preparse.t and removed "use Devel::Peek" thanks to Scott Hildreth.
    Only copy Changes to blib/lib/Changes.pm once thanks to Jonathan Leffler.
    Updated internals for modern perls thanks to Jonathan Leffler and Jeff Urlwin.
    Tested with perl 5.7.3 (just using default perl config).
  
    Documentation changes:
  
    Added 'Catalog Methods' section to docs thanks to Steffen Goeldner.
    Updated README thanks to Michael Schwern.
    Clarified that driver may choose not to start new transaction until
      next use of $dbh after commit/rollback.
    Clarified docs for finish method.
    Clarified potentials problems with prepare_cached() thanks to Stephen Clouse.
  
  
  =head2 Changes in DBI 1.21,    7th February 2002
  
    The minimum supported perl version is now 5.005_03.
  
    Fixed DBD::Proxy support for AutoCommit thanks to Jochen Wiedmann.
    Fixed DBI::ProxyServer bind_param(_inout) handing thanks to Oleg Mechtcheriakov.
    Fixed DBI::ProxyServer fetch loop thanks to nobull@mail.com.
    Fixed install_driver do-the-right-thing with $@ on error. It, and connect(),
      will leave $@ empty on success and holding the error message on error.
      Thanks to Jay Lawrence, Gavin Sherlock and others for the bug report.
    Fixed fetchrow_hashref to assign columns to the hash left-to-right
      so later fields with the same name overwrite earlier ones
      as per DBI < 1.15, thanks to Kay Roepke.
  
    Changed tables() to use quote_indentifier() if the driver returns a
      true value for $dbh->get_info(29) # SQL_IDENTIFIER_QUOTE_CHAR
    Changed ping() so it no longer triggers RaiseError/PrintError.
    Changed connect() to not call $class->install_driver unless needed.
    Changed DESTROY to catch fatal exceptions and append to $@.
  
    Added ISO SQL/CLI & ODBCv3 data type definitions thanks to Steffen Goeldner.
    Removed the definition of SQL_BIGINT data type constant as the value is
      inconsistent between standards (ODBC=-5, SQL/CLI=25).
    Added $dbh->column_info(...) thanks to Steffen Goeldner.
    Added $dbh->foreign_key_info(...) thanks to Steffen Goeldner.
    Added $dbh->quote_identifier(...) insipred by Simon Oliver.
    Added $dbh->set_err(...) for DBD authors and DBI subclasses
      (actually been there for a while, now expanded and documented).
    Added $h->{HandleError} = sub { ... } addition and/or alternative
      to RaiseError/PrintError. See the docs for more info.
    Added $h->{TraceLevel} = N attribute to set/get trace level of handle
      thus can set trace level via an (eg externally specified) DSN
      using the embedded attribute syntax:
        $dsn = 'dbi:DB2(PrintError=1,TraceLevel=2):dbname';
      Plus, you can also now do: local($h->{TraceLevel}) = N;
      (but that leaks a little memory in some versions of perl).
    Added some call tree information to trace output if trace level >= 3
      With thanks to Graham Barr for the stack walking code.
    Added experimental undocumented $dbh->preparse(), see t/preparse.t
      With thanks to Scott T. Hildreth for much of the work.
    Added Fowler/Noll/Vo hash type as an option to DBI::hash().
  
    Documentation changes:
  
    Added DBI::Changes so now you can "perldoc DBI::Changes", yeah!
    Added selectrow_arrayref & selectrow_hashref docs thanks to Doug Wilson.
    Added 'Standards Reference Information' section to docs to gather
      together all references to relevant on-line standards.
    Added link to poop.sourceforge.net into the docs thanks to Dave Rolsky.
    Added link to hyperlinked BNF for SQL92 thanks to Jeff Zucker.
    Added 'Subclassing the DBI' docs thanks to Stephen Clouse, and
      then changed some of them to reflect the new approach to subclassing.
    Added stronger wording to description of $h->{private_*} attributes.
    Added docs for DBI::hash.
  
    Driver API changes:
  
    Now a COPY of the DBI->connect() attributes is passed to the driver
      connect() method, so it can process and delete any elements it wants.
      Deleting elements reduces/avoids the explicit
        $dbh->{$_} = $attr->{$_} foreach keys %$attr;
      that DBI->connect does after the driver connect() method returns.
  
  
  =head2 Changes in DBI 1.20,    24th August 2001
  
    WARNING: This release contains two changes that may affect your code.
    : Any code using selectall_hashref(), which was added in March 2001, WILL
    : need to be changed. Any code using fetchall_arrayref() with a non-empty
    : hash slice parameter may, in a few rare cases, need to be changed.
    : See the change list below for more information about the changes.
    : See the DBI documentation for a description of current behaviour.
  
    Fixed memory leak thanks to Toni Andjelkovic.
    Changed fetchall_arrayref({ foo=>1, ...}) specification again (sorry):
      The key names of the returned hashes is identical to the letter case of
      the names in the parameter hash, regardless of the L</FetchHashKeyName>
      attribute. The letter case is ignored for matching.
    Changed fetchall_arrayref([...]) array slice syntax specification to
      clarify that the numbers in the array slice are perl index numbers
      (which start at 0) and not column numbers (which start at 1).
    Added { Columns=>... } and { Slice =>... } attributes to selectall_arrayref()
      which is passed to fetchall_arrayref() so it can fetch hashes now.
    Added a { Columns => [...] } attribute to selectcol_arrayref() so that
      the list it returns can be built from more than one column per row.
      Why? Consider my %hash = @{$dbh->selectcol_arrayref($sql,{ Columns=>[1,2]})}
      to return id-value pairs which can be used directly to build a hash.
    Added $hash_ref = $sth->fetchall_hashref( $key_field )
      which returns a ref to a hash with, typically, one element per row.
      $key_field is the name of the field to get the key for each row from.
      The value of the hash for each row is a hash returned by fetchrow_hashref.
    Changed selectall_hashref to return a hash ref (from fetchall_hashref)
      and not an array of hashes as it has since DBI 1.15 (end March 2001).
      WARNING: THIS CHANGE WILL BREAK ANY CODE USING selectall_hashref()!
      Sorry, but I think this is an important regularization of the API.
      To get previous selectall_hashref() behaviour (an array of hash refs)
      change $ary_ref = $dbh->selectall_hashref( $statement, undef, @bind);
  	to $ary_ref = $dbh->selectall_arrayref($statement, { Columns=>{} }, @bind);
    Added NAME_lc_hash, NAME_uc_hash, NAME_hash statement handle attributes.
      which return a ref to a hash of field_name => field_index (0..n-1) pairs.
    Fixed select_hash() example thanks to Doug Wilson.
    Removed (unbundled) DBD::ADO and DBD::Multiplex from the DBI distribution.
      The latest versions of those modules are available from CPAN sites.
    Added $dbh->begin_work. This method causes AutoCommit to be turned
      off just until the next commit() or rollback().
      Driver authors: if the DBIcf_BegunWork flag is set when your commit or
      rollback method is called then please turn AutoCommit on and clear the
      DBIcf_BegunWork flag. If you don't then the DBI will but it'll be much
      less efficient and won't handle error conditions very cleanly.
    Retested on perl 5.4.4, but the DBI won't support 5.4.x much longer.
    Added text to SUPPORT section of the docs:
      For direct DBI and DBD::Oracle support, enhancement, and related work
      I am available for consultancy on standard commercial terms.
    Added text to ACKNOWLEDGEMENTS section of the docs:
      Much of the DBI and DBD::Oracle was developed while I was Technical
      Director (CTO) of the Paul Ingram Group (www.ig.co.uk).  So I'd
      especially like to thank Paul for his generosity and vision in
      supporting this work for many years.
  
  =head2 Changes in DBI 1.19,    20th July 2001
  
    Made fetchall_arrayref({ foo=>1, ...}) be more strict to the specification
      in relation to wanting hash slice keys to be lowercase names.
      WARNING: If you've used fetchall_arrayref({...}) with a hash slice
      that contains keys with uppercase letters then your code will break.
      (As far as I recall the spec has always said don't do that.)
    Fixed $sth->execute() to update $dbh->{Statement} to $sth->{Statement}.
    Added row number to trace output for fetch method calls.
    Trace level 1 no longer shows fetches with row>1 (to reduce output volume).
    Added $h->{FetchHashKeyName} = 'NAME_lc' or 'NAME_uc' to alter
      behaviour of fetchrow_hashref() method. See docs.
    Added type_info quote caching to quote() method thanks to Dean Kopesky.
      Makes using quote() with second data type param much much faster.
    Added type_into_all() caching to type_info(), spotted by Dean Kopesky.
    Added new API definition for table_info() and tables(),
      driver authors please note!
    Added primary_key_info() to DBI API thanks to Steffen Goeldner.
    Added primary_key() to DBI API as simpler interface to primary_key_info().
    Indent and other fixes for DBI::DBD doc thanks to H.Merijn Brand.
    Added prepare_cached() insert_hash() example thanks to Doug Wilson.
    Removed false docs for fetchall_hashref(), use fetchall_arrayref({}).
  
  =head2 Changes in DBI 1.18,    4th June 2001
  
    Fixed that altering ShowErrorStatement also altered AutoCommit!
      Thanks to Jeff Boes for spotting that clanger.
    Fixed DBD::Proxy to handle commit() and rollback(). Long overdue, sorry.
    Fixed incompatibility with perl 5.004 (but no one's using that right? :)
    Fixed connect_cached and prepare_cached to not be affected by the order
      of elements in the attribute hash. Spotted by Mitch Helle-Morrissey.
    Fixed version number of DBI::Shell
      reported by Stuhlpfarrer Gerhard and others.
    Defined and documented table_info() attribute semantics (ODBC compatible)
      thanks to Olga Voronova, who also implemented then in DBD::Oracle.
    Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
  
  =head2 Changes in DBI 1.16,    30th May 2001
  
    Reimplemented fetchrow_hashref in C, now fetches about 25% faster!
    Changed behaviour if both PrintError and RaiseError are enabled
      to simply do both (in that order, obviously :)
    Slight reduction in DBI handle creation overhead.
    Fixed $dbh->{Driver} & $sth->{Database} to return 'outer' handles.
    Fixed execute param count check to honour RaiseError spotted by Belinda Giardie.
    Fixed build for perl5.6.1 with PERLIO thanks to H.Merijn Brand.
    Fixed client sql restrictions in ProxyServer.pm thanks to Jochen Wiedmann.
    Fixed batch mode command parsing in Shell thanks to Christian Lemburg.
    Fixed typo in selectcol_arrayref docs thanks to Jonathan Leffler.
    Fixed selectrow_hashref to be available to callers thanks to T.J.Mather.
    Fixed core dump if statement handle didn't define Statement attribute.
    Added bind_param_inout docs to DBI::DBD thanks to Jonathan Leffler.
    Added note to data_sources() method docs that some drivers may
      require a connected database handle to be supplied as an attribute.
    Trace of install_driver method now shows path of driver file loaded.
    Changed many '||' to 'or' in the docs thanks to H.Merijn Brand.
    Updated DBD::ADO again (improvements in error handling) from Tom Lowery.
    Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
    Updated email and web addresses in DBI::FAQ thanks to Michael A Chase.
  
  =head2 Changes in DBI 1.15,    28th March 2001
  
    Added selectrow_arrayref
    Added selectrow_hashref
    Added selectall_hashref thanks to Leon Brocard.
    Added DBI->connect(..., { dbi_connect_method => 'method' })
    Added $dbh->{Statement} aliased to most recent child $sth->{Statement}.
    Added $h->{ShowErrorStatement}=1 to cause the appending of the
      relevant Statement text to the RaiseError/PrintError text.
    Modified type_info to always return hash keys in uppercase and
      to not require uppercase 'DATA_TYPE' key from type_info_all.
      Thanks to Jennifer Tong and Rob Douglas.
    Added \%attr param to tables() and table_info() methods.
    Trace method uses warn() if it can't open the new file.
    Trace shows source line and filename during global destruction.
    Updated packages:
      Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee.
      Updated DBD::ADO to much improved version 0.4 from Tom Lowery.
      Updated DBD::Sponge to include $sth->{PRECISION} thanks to Tom Lowery.
      Changed DBD::ExampleP to use lstat() instead of stat().
    Documentation:
      Documented $DBI::lasth (which has been there since day 1).
      Documented SQL_* names.
      Clarified and extended docs for $h->state thanks to Masaaki Hirose.
      Clarified fetchall_arrayref({}) docs (thanks to, er, someone!).
      Clarified type_info_all re lettercase and index values.
      Updated DBI::FAQ to 0.38 thanks to Alligator Descartes.
      Added cute bind_columns example thanks to H.Merijn Brand.
      Extended docs on \%attr arg to data_sources method.
    Makefile.PL
      Removed obscure potential 'rm -rf /' (thanks to Ulrich Pfeifer).
      Removed use of glob and find (thanks to Michael A. Chase).
    Proxy:
      Removed debug messages from DBD::Proxy AUTOLOAD thanks to Brian McCauley.
      Added fix for problem using table_info thanks to Tom Lowery.
      Added better determination of where to put the pid file, and...
      Added KNOWN ISSUES section to DBD::Proxy docs thanks to Jochen Wiedmann.
    Shell:
      Updated DBI::Format to include DBI::Format::String thanks to Tom Lowery.
      Added describe command thanks to Tom Lowery.
      Added columnseparator option thanks to Tom Lowery (I think).
      Added 'raw' format thanks to, er, someone, maybe Tom again.
    Known issues:
      Perl 5.005 and 5.006 both leak memory doing local($handle->{Foo}).
      Perl 5.004 doesn't. The leak is not a DBI or driver bug.
  
  =head2 Changes in DBI 1.14,	14th June 2000
  
    NOTE: This version is the one the DBI book is based on.
    NOTE: This version requires at least Perl 5.004.
    Perl 5.6 ithreads changes with thanks to Doug MacEachern.
    Changed trace output to use PerlIO thanks to Paul Moore.
    Fixed bug in RaiseError/PrintError handling.
      (% chars in the error string could cause a core dump.)
    Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt.
    Major documentation polishing thanks to Linda Mui at O'Reilly.
    Password parameter now shown as **** in trace output.
    Added two fields to type_info and type_info_all.
    Added $dsn to PrintError/RaiseError message from DBI->connect().
    Changed prepare_cached() croak to carp if sth still Active.
    Added prepare_cached() example to the docs.
    Added further DBD::ADO enhancements from Thomas Lowery.
  
  =head2 Changes in DBI 1.13,	11th July 1999
  
    Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt.
    Fixed problems with DBD::ExampleP long_list test mode.
    Added SQL_WCHAR SQL_WVARCHAR SQL_WLONGVARCHAR and SQL_BIT
      to list of known and exportable SQL types.
    Improved data fetch performance of DBD::ADO.
    Added GetTypeInfo to DBD::ADO thanks to Thomas Lowery.
    Actually documented connect_cached thanks to Michael Schwern.
    Fixed user/key/cipher bug in ProxyServer thanks to Joshua Pincus.
  
  =head2 Changes in DBI 1.12,	29th June 1999
  
    Fixed significant DBD::ADO bug (fetch skipped first row).
    Fixed ProxyServer bug handling non-select statements.
    Fixed VMS problem with t/examp.t thanks to Craig Berry.
    Trace only shows calls to trace_msg and _set_fbav at high levels.
    Modified t/examp.t to workaround Cygwin buffering bug.
  
  =head2 Changes in DBI 1.11,	17th June 1999
  
    Fixed bind_columns argument checking to allow a single arg.
    Fixed problems with internal default_user method.
    Fixed broken DBD::ADO.
    Made default $DBI::rows more robust for some obscure cases.
  
  =head2 Changes in DBI 1.10,	14th June 1999
  
    Fixed trace_msg.al error when using Apache.
    Fixed dbd_st_finish enhancement in Driver.xst (internals).
    Enable drivers to define default username and password
      and temporarily disabled warning added in 1.09.
    Thread safety optimised for single thread case.
  
  =head2 Changes in DBI 1.09,	9th June 1999
  
    Added optional minimum trace level parameter to trace_msg().
    Added warning in Makefile.PL that DBI will require 5.004 soon.
    Added $dbh->selectcol_arrayref($statement) method.
    Fixed fetchall_arrayref hash-slice mode undef NAME problem.
    Fixed problem with tainted parameter checking and t/examp.t.
    Fixed problem with thread safety code, including 64 bit machines.
    Thread safety now enabled by default for threaded perls.
    Enhanced code for MULTIPLICITY/PERL_OBJECT from ActiveState.
    Enhanced prepare_cached() method.
    Minor changes to trace levels (less internal info at level 2).
    Trace log now shows "!! ERROR..." before the "<- method" line.
    DBI->connect() now warn's if user / password is undefined and
      DBI_USER / DBI_PASS environment variables are not defined.
    The t/proxy.t test now ignores any /etc/dbiproxy.conf file.
    Added portability fixes for MacOS from Chris Nandor.
    Updated mailing list address from fugue.com to isc.org.
  
  =head2 Changes in DBI 1.08,	12th May 1999
  
    Much improved DBD::ADO driver thanks to Phlip Plumlee and others.
    Connect now allows you to specify attribute settings within the DSN
      E.g., "dbi:Driver(RaiseError=>1,Taint=>1,AutoCommit=>0):dbname"
    The $h->{Taint} attribute now also enables taint checking of
      arguments to almost all DBI methods.
    Improved trace output in various ways.
    Fixed bug where $sth->{NAME_xx} was undef in some situations.
    Fixed code for MULTIPLICITY/PERL_OBJECT thanks to Alex Smishlajev.
    Fixed and documented DBI->connect_cached.
    Workaround for Cygwin32 build problem with help from Jong-Pork Park.
    bind_columns no longer needs undef or hash ref as first parameter.
  
  =head2 Changes in DBI 1.07,	6th May 1999
  
    Trace output now shows contents of array refs returned by DBI.
    Changed names of some result columns from type_info, type_info_all,
      tables and table_info to match ODBC 3.5 / ISO/IEC standards.
    Many fixes for DBD::Proxy and ProxyServer.
    Fixed error reporting in install_driver.
    Major enhancement to DBI::W32ODBC from Patrick Hollins.
    Added $h->{Taint} to taint fetched data if tainting (perl -T).
    Added code for MULTIPLICITY/PERL_OBJECT contributed by ActiveState.
    Added $sth->more_results (undocumented for now).
  
  =head2 Changes in DBI 1.06,	6th January 1999
  
    Fixed Win32 Makefile.PL problem in 1.04 and 1.05.
    Significant DBD::Proxy enhancements and fixes
      including support for bind_param_inout (Jochen and I)
    Added experimental DBI->connect_cached method.
    Added $sth->{NAME_uc} and $sth->{NAME_lc} attributes.
    Enhanced fetchrow_hashref to take an attribute name arg.
  
  =head2 Changes in DBI 1.05,	4th January 1999
  
    Improved DBD::ADO connect (thanks to Phlip Plumlee).
    Improved thread safety (thanks to Jochen Wiedmann).
    [Quick release prompted by truncation of copies on CPAN]
  
  =head2 Changes in DBI 1.04,	3rd January 1999
  
    Fixed error in Driver.xst. DBI build now tests Driver.xst.
    Removed unused variable compiler warnings in Driver.xst.
    DBI::DBD module now tested during DBI build.
    Further clarification in the DBI::DBD driver writers manual.
    Added optional name parameter to $sth->fetchrow_hashref.
  
  =head2 Changes in DBI 1.03,	1st January 1999
  
    Now builds with Perl>=5.005_54 (PERL_POLLUTE in DBIXS.h)
    DBI trace trims path from "at yourfile.pl line nnn".
    Trace level 1 now shows statement passed to prepare.
    Assorted improvements to the DBI manual.
    Assorted improvements to the DBI::DBD driver writers manual.
    Fixed $dbh->quote prototype to include optional $data_type.
    Fixed $dbh->prepare_cached problems.
    $dbh->selectrow_array behaves better in scalar context.
    Added a (very) experimental DBD::ADO driver for Win32 ADO.
    Added experimental thread support (perl Makefile.PL -thread).
    Updated the DBI::FAQ - thanks to Alligator Descartes.
    The following changes were implemented and/or packaged
      by Jochen Wiedmann - thanks Jochen:
    Added a Bundle for CPAN installation of DBI, the DBI proxy
      server and prerequisites (lib/Bundle/DBI.pm).
    DBI->available_drivers uses File::Spec, if available.
      This makes it work on MacOS. (DBI.pm)
    Modified type_info to work with read-only values returned
      by type_info_all. (DBI.pm)
    Added handling of magic values in $sth->execute,
      $sth->bind_param and other methods (Driver.xst)
    Added Perl's CORE directory to the linkers path on Win32,
      required by recent versions of ActiveState Perl.
    Fixed DBD::Sponge to work with empty result sets.
    Complete rewrite of DBI::ProxyServer and DBD::Proxy.
  
  =head2 Changes in DBI 1.02,	2nd September 1998
  
    Fixed DBI::Shell including @ARGV and /current.
    Added basic DBI::Shell test.
    Renamed DBI::Shell /display to /format.
  
  =head2 Changes in DBI 1.01,	2nd September 1998
  
    Many enhancements to Shell (with many contributions from
    Jochen Wiedmann, Tom Lowery and Adam Marks).
    Assorted fixes to DBD::Proxy and DBI::ProxyServer.
    Tidied up trace messages - trace(2) much cleaner now.
    Added $dbh->{RowCacheSize} and $sth->{RowsInCache}.
    Added experimental DBI::Format (mainly for DBI::Shell).
    Fixed fetchall_arrayref($slice_hash).
    DBI->connect now honours PrintError=1 if connect fails.
    Assorted clarifications to the docs.
  
  =head2 Changes in DBI 1.00,	14th August 1998
  
    The DBI is no longer 'alpha' software!
    Added $dbh->tables and $dbh->table_info.
    Documented \%attr arg to data_sources method.
    Added $sth->{TYPE}, $sth->{PRECISION} and $sth->{SCALE}.
    Added $sth->{Statement}.
    DBI::Shell now uses neat_list to print results
    It also escapes "'" chars and converts newlines to spaces.
  
  =head2 Changes in DBI 0.95,	10th August 1998
  
    WARNING: THIS IS AN EXPERIMENTAL RELEASE!
  
    Fixed 0.94 slip so it will build on pre-5.005 again.
    Added DBI_AUTOPROXY environment variable.
    Array ref returned from fetch/fetchrow_arrayref now readonly.
    Improved connect error reporting by DBD::Proxy.
    All trace/debug messages from DBI now go to trace file.
  
  =head2 Changes in DBI 0.94,	9th August 1998
  
    WARNING: THIS IS AN EXPERIMENTAL RELEASE!
  
    Added DBD::Shell and dbish interactive DBI shell. Try it!
    Any database attribs can be set via DBI->connect(,,, \%attr).
    Added _get_fbav and _set_fbav methods for Perl driver developers
      (see ExampleP driver for perl usage). Drivers which don't use
      one of these methods (either via XS or Perl) are not compliant.
    DBI trace now shows adds " at yourfile.pl line nnn"!
    PrintError and RaiseError now prepend driver and method name.
    The available_drivers method no longer returns NullP or Sponge.
    Added $dbh->{Name}.
    Added $dbh->quote($value, $data_type).
    Added more hints to install_driver failure message.
    Added DBD::Proxy and DBI::ProxyServer (from Jochen Wiedmann).
    Added $DBI::neat_maxlen to control truncation of trace output.
    Added $dbh->selectall_arrayref and $dbh->selectrow_array methods.
    Added $dbh->tables.
    Added $dbh->type_info and $dbh->type_info_all.
    Added $h->trace_msg($msg) to write to trace log.
    Added @bool = DBI::looks_like_number(@ary).
    Many assorted improvements to the DBI docs.
  
  =head2 Changes in DBI 0.93,	13th February 1998
  
    Fixed DBI::DBD::dbd_postamble bug causing 'Driver.xsi not found' errors.
    Changes to handling of 'magic' values in neatsvpv (used by trace).
    execute (in Driver.xst) stops binding after first bind error.
    This release requires drivers to be rebuilt.
  
  =head2 Changes in DBI 0.92,	3rd February 1998
  
    Fixed per-handle memory leak (with many thanks to Irving Reid).
    Added $dbh->prepare_cached() caching variant of $dbh->prepare.
    Added some attributes:
      $h->{Active}       is the handle 'Active' (vague concept) (boolean)
      $h->{Kids}         e.g. number of sth's associated with a dbh
      $h->{ActiveKids}   number of the above which are 'Active'
      $dbh->{CachedKids} ref to prepare_cached sth cache
    Added support for general-purpose 'private_' attributes.
    Added experimental support for subclassing the DBI: see t/subclass.t
    Added SQL_ALL_TYPES to exported :sql_types.
    Added dbd_dbi_dir() and dbd_dbi_arch_dir() to DBI::DBD module so that
    DBD Makefile.PLs can work with the DBI installed in non-standard locations.
    Fixed 'Undefined value' warning and &sv_no output from neatsvpv/trace.
    Fixed small 'once per interpreter' leak.
    Assorted minor documentation fixes.
  
  =head2 Changes in DBI 0.91,	10th December 1997
  
    NOTE: This fix may break some existing scripts:
    DBI->connect("dbi:...",$user,$pass) was not setting AutoCommit and PrintError!
    DBI->connect(..., { ... }) no longer sets AutoCommit or PrintError twice.
    DBI->connect(..., { RaiseError=>1 }) now croaks if connect fails.
    Fixed $fh parameter of $sth->dump_results;
    Added default statement DESTROY method which carps.
    Added default driver DESTROY method to silence AUTOLOAD/__DIE__/CGI::Carp
    Added more SQL_* types to %EXPORT_TAGS and @EXPORT_OK.
    Assorted documentation updates (mainly clarifications).
    Added workaround for perl's 'sticky lvalue' bug.
    Added better warning for bind_col(umns) where fields==0.
    Fixed to build okay with 5.004_54 with or without USE_THREADS.
    Note that the DBI has not been tested for thread safety yet.
  
  =head2 Changes in DBI 0.90,	6th September 1997
  
    Can once again be built with Perl 5.003.
    The DBI class can be subclassed more easily now.
    InactiveDestroy fixed for drivers using the *.xst template.
    Slightly faster handle creation.
    Changed prototype for dbd_*_*_attrib() to add extra param.
    Note: 0.90, 0.89 and possibly some other recent versions have
    a small memory leak. This will be fixed in the next release.
  
  =head2 Changes in DBI 0.89,	25th July 1997
  
    Minor fix to neatsvpv (mainly used for debug trace) to workaround
    bug in perl where SvPV removes IOK flag from an SV.
    Minor updates to the docs.
  
  =head2 Changes in DBI 0.88,	22nd July 1997
  
    Fixed build for perl5.003 and Win32 with Borland.
    Fixed documentation formatting.
    Fixed DBI_DSN ignored for old-style connect (with explicit driver).
    Fixed AutoCommit in DBD::ExampleP
    Fixed $h->trace.
    The DBI can now export SQL type values: use DBI ':sql_types';
    Modified Driver.xst and renamed DBDI.h to dbd_xsh.h
  
  =head2 Changes in DBI 0.87,	18th July 1997
  
    Fixed minor type clashes.
    Added more docs about placeholders and bind values.
  
  =head2 Changes in DBI 0.86,	16th July 1997
  
    Fixed failed connect causing 'unblessed ref' and other errors.
    Drivers must handle AutoCommit FETCH and STORE else DBI croaks.
    Added $h->{LongReadLen} and $h->{LongTruncOk} attributes for BLOBS.
    Added DBI_USER and DBI_PASS env vars. See connect docs for usage.
    Added DBI->trace() to set global trace level (like per-handle $h->trace).
    PERL_DBI_DEBUG env var renamed DBI_DEBUG (old name still works for now).
    Updated docs, including commit, rollback, AutoCommit and Transactions sections.
    Added bind_param method and execute(@bind_values) to docs.
    Fixed fetchall_arrayref.
  
    Since the DBIS structure has change the internal version numbers have also
    changed (DBIXS_VERSION == 9 and DBISTATE_VERSION == 9) so drivers will have
    to be recompiled. The test is also now more sensitive and the version
    mismatch error message now more clear about what to do. Old drivers are
    likely to core dump (this time) until recompiled for this DBI. In future
    DBI/DBD version mismatch will always produce a clear error message.
  
    Note that this DBI release contains and documents many new features
    that won't appear in drivers for some time. Driver writers might like
    to read perldoc DBI::DBD and comment on or apply the information given.
  
  =head2 Changes in DBI 0.85,	25th June 1997
  
    NOTE: New-style connect now defaults to AutoCommit mode unless
    { AutoCommit => 0 } specified in connect attributes. See the docs.
    AutoCommit attribute now defined and tracked by DBI core.
    Drivers should use/honour this and not implement their own.
    Added pod doc changes from Andreas and Jonathan.
    New DBI_DSN env var default for connect method. See docs.
    Documented the func method.
    Fixed "Usage: DBD::_::common::DESTROY" error.
    Fixed bug which set some attributes true when there value was fetched.
    Added new internal DBIc_set() macro for drivers to use.
  
  =head2 Changes in DBI 0.84,	20th June 1997
  
    Added $h->{PrintError} attribute which, if set true, causes all errors to
    trigger a warn().
    New-style DBI->connect call now automatically sets PrintError=1 unless
    { PrintError => 0 } specified in the connect attributes. See the docs.
    The old-style connect with a separate driver parameter is deprecated.
    Fixed fetchrow_hashref.
    Renamed $h->debug to $h->trace() and added a trace filename arg.
    Assorted other minor tidy-ups.
  
  =head2 Changes in DBI 0.83,	11th June 1997
  
    Added driver specification syntax to DBI->connect data_source
    parameter: DBI->connect('dbi:driver:...', $user, $passwd);
    The DBI->data_sources method should return data_source
    names with the appropriate 'dbi:driver:' prefix.
    DBI->connect will warn if \%attr is true but not a hash ref.
    Added the new fetchrow methods:
      @row_ary  = $sth->fetchrow_array;
      $ary_ref  = $sth->fetchrow_arrayref;
      $hash_ref = $sth->fetchrow_hashref;
    The old fetch and fetchrow methods still work.
    Driver implementors should implement the new names for
    fetchrow_array and fetchrow_arrayref ASAP (use the xs ALIAS:
    directive to define aliases for fetch and fetchrow).
    Fixed occasional problems with t/examp.t test.
    Added automatic errstr reporting to the debug trace output.
    Added the DBI FAQ from Alligator Descartes in module form for
    easy reading via "perldoc DBI::FAQ". Needs reformatting.
    Unknown driver specific attribute names no longer croak.
    Fixed problem with internal neatsvpv macro.
  
  =head2 Changes in DBI 0.82,	23rd May 1997
  
    Added $h->{RaiseError} attribute which, if set true, causes all errors to
    trigger a die(). This makes it much easier to implement robust applications
    in terms of higher level eval { ... } blocks and rollbacks.
    Added DBI->data_sources($driver) method for implementation by drivers.
    The quote method now returns the string NULL (without quotes) for undef.
    Added VMS support thanks to Dan Sugalski.
    Added a 'quick start guide' to the README.
    Added neatsvpv function pointer to DBIS structure to make it available for
    use by drivers. A macro defines neatsvpv(sv,len) as (DBIS->neatsvpv(sv,len)).
    Old XS macro SV_YES_NO changes to standard boolSV.
    Since the DBIS structure has change the internal version numbers have also
    changed (DBIXS_VERSION == 8 and DBISTATE_VERSION == 8) so drivers will have
    to be recompiled.
  
  =head2 Changes in DBI 0.81,	7th May 1997
  
    Minor fix to let DBI build using less modern perls.
    Fixed a suprious typo warning.
  
  =head2 Changes in DBI 0.80,	6th May 1997
  
    Builds with no changes on NT using perl5.003_99 (with thanks to Jeffrey Urlwin).
    Automatically supports Apache::DBI (with thanks to Edmund Mergl).
      DBI scripts no longer need to be modified to make use of Apache::DBI.
    Added a ping method and an experimental connect_test_perf method.
    Added a fetchhash and fetch_all methods.
    The func method no longer pre-clears err and errstr. 
    Added ChopBlanks attribute (currently defaults to off, that may change).
      Support for the attribute needs to be implemented by individual drivers.
    Reworked tests into standard t/*.t form.
    Added more pod text.  Fixed assorted bugs.
    
  
  =head2 Changes in DBI 0.79,	7th Apr 1997
  
    Minor release. Tidied up pod text and added some more descriptions
    (especially disconnect). Minor changes to DBI.xs to remove compiler
    warnings.
  
  =head2 Changes in DBI 0.78,	28th Mar 1997
  
    Greatly extended the pod documentation in DBI.pm, including the under
    used bind_columns method. Use 'perldoc DBI' to read after installing.
    Fixed $h->err. Fetching an attribute value no longer resets err.
    Added $h->{InactiveDestroy}, see documentation for details.
    Improved debugging of cached ('quick') attribute fetches.
    errstr will return err code value if there is no string value.
    Added DBI/W32ODBC to the distribution. This is a pure-perl experimental
    DBI emulation layer for Win32::ODBC. Note that it's unsupported, your
    mileage will vary, and bug reports without fixes will probably be ignored.
  
  =head2 Changes in DBI 0.77,	21st Feb 1997
  
    Removed erroneous $h->errstate and $h->errmsg methods from DBI.pm.
    Added $h->err, $h->errstr and $h->state default methods in DBI.xs.
    Updated informal DBI API notes in DBI.pm. Updated README slightly.
    DBIXS.h now correctly installed into INST_ARCHAUTODIR.
    (DBD authors will need to edit their Makefile.PL's to use
    -I$(INSTALLSITEARCH)/auto/DBI -I$(INSTALLSITEARCH)/DBI)
  
  
  =head2 Changes in DBI 0.76,	3rd Feb 1997
  
    Fixed a compiler type warnings (pedantic IRIX again).
  
  =head2 Changes in DBI 0.75,	27th Jan 1997
  
    Fix problem introduced by a change in Perl5.003_XX.
    Updated README and DBI.pm docs.
  
  =head2 Changes in DBI 0.74,	14th Jan 1997
  
    Dispatch now sets dbi_debug to the level of the current handle
    (this makes tracing/debugging individual handles much easier).
    The '>> DISPATCH' log line now only logged at debug >= 3 (was 2).
    The $csr->NUM_OF_FIELDS attribute can be set if not >0 already.
    You can log to a file using the env var PERL_DBI_DEBUG=/tmp/dbi.log.
    Added a type cast needed by IRIX.
    No longer sets perl_destruct_level unless debug set >= 4.
    Make compatible with PerlIO and sfio.
  
  =head2 Changes in DBI 0.73,	10th Oct 1996
  
    Fixed some compiler type warnings (IRIX).
    Fixed DBI->internal->{DebugLog} = $filename.
    Made debug log file unbuffered.
    Added experimental bind_param_inout method to interface.
    Usage: $dbh->bind_param_inout($param, \$value, $maxlen [, \%attribs ])
    (only currently used by DBD::Oracle at this time.)
  
  =head2 Changes in DBI 0.72,	23 Sep 1996
  
    Using an undefined value as a handle now gives a better
    error message (mainly useful for emulators like Oraperl).
    $dbh->do($sql, @params) now works for binding placeholders.
  
  =head2 Changes in DBI 0.71,	10 July 1996
  
    Removed spurious abort() from invalid handle check.
    Added quote method to DBI interface and added test.
  
  =head2 Changes in DBI 0.70,	16 June 1996
  
    Added extra invalid handle check (dbih_getcom)
    Fixed broken $dbh->quote method.
    Added check for old GCC in Makefile.PL
  
  =head2 Changes in DBI 0.69
  
    Fixed small memory leak.
    Clarified the behaviour of DBI->connect.
    $dbh->do now returns '0E0' instead of 'OK'.
    Fixed "Can't read $DBI::errstr, lost last handle" problem.
  
  
  =head2 Changes in DBI 0.68,	2 Mar 1996
  
    Changes to suit perl5.002 and site_lib directories.
    Detects old versions ahead of new in @INC.
  
  
  =head2 Changes in DBI 0.67,	15 Feb 1996
  
    Trivial change to test suite to fix a problem shown up by the
    Perl5.002gamma release Test::Harness.
  
  
  =head2 Changes in DBI 0.66,	29 Jan 1996
  
    Minor changes to bring the DBI into line with 5.002 mechanisms,
    specifically the xs/pm VERSION checking mechanism.
    No functionality changes. One no-last-handle bug fix (rare problem).
    Requires 5.002 (beta2 or later).
  
  
  =head2 Changes in DBI 0.65,	23 Oct 1995
  
    Added $DBI::state to hold SQL CLI / ODBC SQLSTATE value.
    SQLSTATE "00000" (success) is returned as "" (false), all else is true.
    If a driver does not explicitly initialise it (via $h->{State} or
    DBIc_STATE(imp_xxh) then $DBI::state will automatically return "" if
    $DBI::err is false otherwise "S1000" (general error).
    As always, this is a new feature and liable to change.
  
    The is *no longer* a default error handler!
    You can add your own using push(@{$h->{Handlers}}, sub { ... })
    but be aware that this interface may change (or go away).
  
    The DBI now automatically clears $DBI::err, errstr and state before
    calling most DBI methods. Previously error conditions would persist.
    Added DBIh_CLEAR_ERROR(imp_xxh) macro.
  
    DBI now EXPORT_OK's some utility functions, neat($value),
    neat_list(@values) and dump_results($sth).
  
    Slightly enhanced t/min.t minimal test script in an effort to help
    narrow down the few stray core dumps that some porters still report.
  
    Renamed readblob to blob_read (old name still works but warns).
    Added default blob_copy_to_file method.
  
    Added $sth = $dbh->tables method. This returns an $sth for a query
    which has these columns: TABLE_CATALOGUE, TABLE_OWNER, TABLE_NAME,
    TABLE_TYPE, REMARKS in that order. The TABLE_CATALOGUE column
    should be ignored for now.
  
  
  =head2 Changes in DBI 0.64,	23 Oct 1995
  
    Fixed 'disconnect invalidates 1 associated cursor(s)' problem.
    Drivers using DBIc_ACTIVE_on/off() macros should not need any changes
    other than to test for DBIc_ACTIVE_KIDS() instead of DBIc_KIDS().
    Fixed possible core dump in dbih_clearcom during global destruction.
  
  
  =head2 Changes in DBI 0.63,	1 Sep 1995
  
    Minor update. Fixed uninitialised memory bug in method
    attribute handling and streamlined processing and debugging.
    Revised usage definitions for bind_* methods and readblob.
  
  
  =head2 Changes in DBI 0.62,	26 Aug 1995
  
    Added method redirection method $h->func(..., $method_name).
    This is now the official way to call private driver methods
    that are not part of the DBI standard.  E.g.:
        @ary = $sth->func('ora_types');
    It can also be used to call existing methods. Has very low cost.
  
    $sth->bind_col columns now start from 1 (not 0) to match SQL.
    $sth->bind_columns now takes a leading attribute parameter (or undef),
    e.g., $sth->bind_columns($attribs, \$col1 [, \$col2 , ...]);
  
    Added handy DBD_ATTRIBS_CHECK macro to vet attribs in XS.
    Added handy DBD_ATTRIB_GET_SVP, DBD_ATTRIB_GET_BOOL and
    DBD_ATTRIB_GET_IV macros for handling attributes.
  
    Fixed STORE for NUM_OF_FIELDS and NUM_OF_PARAMS.
    Added FETCH for NUM_OF_FIELDS and NUM_OF_PARAMS.
  
    Dispatch no longer bothers to call _untie().
    Faster startup via install_method/_add_dispatch changes.
  
  
  =head2 Changes in DBI 0.61,	22 Aug 1995
  
    Added $sth->bind_col($column, \$var [, \%attribs ]);
  
    This method enables perl variable to be directly and automatically
    updated when a row is fetched. It requires no driver support
    (if the driver has been written to use DBIS->get_fbav).
    Currently \%attribs is unused.
  
    Added $sth->bind_columns(\$var [, \$var , ...]);
  
    This method is a short-cut for bind_col which binds all the
    columns of a query in one go (with no attributes). It also
    requires no driver support.
  
    Added $sth->bind_param($parameter, $var [, \%attribs ]);
  
    This method enables attributes to be specified when values are
    bound to placeholders. It also enables binding to occur away
    from the execute method to improve execute efficiency.
    The DBI does not provide a default implementation of this.
    See the DBD::Oracle module for a detailed example.
  
    The DBI now provides default implementations of both fetch and
    fetchrow.  Each is written in terms of the other. A driver is
    expected to implement at least one of them.
  
    More macro and assorted structure changes in DBDXS.h. Sorry!
    The old dbihcom definitions have gone. All fields have macros.
    The imp_xxh_t type is now used within the DBI as well as drivers.
    Drivers must set DBIc_NUM_FIELDS(imp_sth) and DBIc_NUM_PARAMS(imp_sth).
  
    test.pl includes a trivial test of bind_param and bind_columns.
  
  
  =head2 Changes in DBI 0.60,	17 Aug 1995
  
    This release has significant code changes but much less
    dramatic than the previous release. The new implementors data
    handling mechanism has matured significantly (don't be put off
    by all the struct typedefs in DBIXS.h, there's just to make it
    easier for drivers while keeping things type-safe).
  
    The DBI now includes two new methods:
  
    do		$dbh->do($statement)
  
    This method prepares, executes and finishes a statement. It is
    designed to be used for executing one-off non-select statements
    where there is no benefit in reusing a prepared statement handle.
  
    fetch		$array_ref = $sth->fetch;
  
    This method is the new 'lowest-level' row fetching method. The
    previous @row = $sth->fetchrow method now defaults to calling
    the fetch method and expanding the returned array reference.
  
    The DBI now provides fallback attribute FETCH and STORE functions
    which drivers should call if they don't recognise an attribute.
  
    THIS RELEASE IS A GOOD STARTING POINT FOR DRIVER DEVELOPERS!
    Study DBIXS.h from the DBI and Oracle.xs etc from DBD::Oracle.
    There will be further changes in the interface but nothing
    as dramatic as these last two releases! (I hope :-)
  
  
  =head2 Changes in DBI 0.59	15 Aug 1995
  
    NOTE: THIS IS AN UNSTABLE RELEASE!
  
    Major reworking of internal data management!
    Performance improvements and memory leaks fixed.
    Added a new NullP (empty) driver and a -m flag
    to test.pl to help check for memory leaks.
    Study DBD::Oracle version 0.21 for more details.
    (Comparing parts of v0.21 with v0.20 may be useful.)
  
  
  =head2 Changes in DBI 0.58	21 June 1995
  
    Added DBI->internal->{DebugLog} = $filename;
    Reworked internal logging.
    Added $VERSION.
    Made disconnect_all a compulsary method for drivers.
  
  
  =head1 ANCIENT HISTORY
  
  12th Oct 1994: First public release of the DBI module.
                 (for Perl 5.000-beta-3h)
  
  19th Sep 1994: DBperl project renamed to DBI.
  
  29th Sep 1992: DBperl project started.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_CHANGES

$fatpacked{"darwin-thread-multi-2level/DBI/Const/GetInfo/ANSI.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFO_ANSI';
  # $Id: ANSI.pm 8696 2007-01-24 23:12:38Z timbo $
  #
  # Copyright (c) 2002  Tim Bunce  Ireland
  #
  # Constant data describing ANSI CLI info types and return values for the
  # SQLGetInfo() method of ODBC.
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  package DBI::Const::GetInfo::ANSI;
  
  =head1 NAME
  
  DBI::Const::GetInfo::ANSI - ISO/IEC SQL/CLI Constants for GetInfo
  
  =head1 SYNOPSIS
  
    The API for this module is private and subject to change.
  
  =head1 DESCRIPTION
  
  Information requested by GetInfo().
  
  See: A.1 C header file SQLCLI.H, Page 316, 317.
  
  The API for this module is private and subject to change.
  
  =head1 REFERENCES
  
    ISO/IEC FCD 9075-3:200x Information technology - Database Languages -
    SQL - Part 3: Call-Level Interface (SQL/CLI)
  
    SC32 N00744 = WG3:VIE-005 = H2-2002-007
  
    Date: 2002-01-15
  
  =cut
  
  my
  $VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  
  
  %InfoTypes =
  (
    SQL_ALTER_TABLE                     =>      86
  , SQL_CATALOG_NAME                    =>   10003
  , SQL_COLLATING_SEQUENCE              =>   10004
  , SQL_CURSOR_COMMIT_BEHAVIOR          =>      23
  , SQL_CURSOR_SENSITIVITY              =>   10001
  , SQL_DATA_SOURCE_NAME                =>       2
  , SQL_DATA_SOURCE_READ_ONLY           =>      25
  , SQL_DBMS_NAME                       =>      17
  , SQL_DBMS_VERSION                    =>      18
  , SQL_DEFAULT_TRANSACTION_ISOLATION   =>      26
  , SQL_DESCRIBE_PARAMETER              =>   10002
  , SQL_FETCH_DIRECTION                 =>       8
  , SQL_GETDATA_EXTENSIONS              =>      81
  , SQL_IDENTIFIER_CASE                 =>      28
  , SQL_INTEGRITY                       =>      73
  , SQL_MAXIMUM_CATALOG_NAME_LENGTH     =>      34
  , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY     =>      97
  , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY     =>      99
  , SQL_MAXIMUM_COLUMNS_IN_SELECT       =>     100
  , SQL_MAXIMUM_COLUMNS_IN_TABLE        =>     101
  , SQL_MAXIMUM_COLUMN_NAME_LENGTH      =>      30
  , SQL_MAXIMUM_CONCURRENT_ACTIVITIES   =>       1
  , SQL_MAXIMUM_CURSOR_NAME_LENGTH      =>      31
  , SQL_MAXIMUM_DRIVER_CONNECTIONS      =>       0
  , SQL_MAXIMUM_IDENTIFIER_LENGTH       =>   10005
  , SQL_MAXIMUM_SCHEMA_NAME_LENGTH      =>      32
  , SQL_MAXIMUM_STMT_OCTETS             =>   20000
  , SQL_MAXIMUM_STMT_OCTETS_DATA        =>   20001
  , SQL_MAXIMUM_STMT_OCTETS_SCHEMA      =>   20002
  , SQL_MAXIMUM_TABLES_IN_SELECT        =>     106
  , SQL_MAXIMUM_TABLE_NAME_LENGTH       =>      35
  , SQL_MAXIMUM_USER_NAME_LENGTH        =>     107
  , SQL_NULL_COLLATION                  =>      85
  , SQL_ORDER_BY_COLUMNS_IN_SELECT      =>      90
  , SQL_OUTER_JOIN_CAPABILITIES         =>     115
  , SQL_SCROLL_CONCURRENCY              =>      43
  , SQL_SEARCH_PATTERN_ESCAPE           =>      14
  , SQL_SERVER_NAME                     =>      13
  , SQL_SPECIAL_CHARACTERS              =>      94
  , SQL_TRANSACTION_CAPABLE             =>      46
  , SQL_TRANSACTION_ISOLATION_OPTION    =>      72
  , SQL_USER_NAME                       =>      47
  );
  
  =head2 %ReturnTypes
  
  See: Codes and data types for implementation information (Table 28), Page 85, 86.
  
  Mapped to ODBC datatype names.
  
  =cut
  
  %ReturnTypes =                                                 #          maxlen
  (
    SQL_ALTER_TABLE                     => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_CATALOG_NAME                    => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_COLLATING_SEQUENCE              => 'SQLCHAR'             # CHARACTER (254)
  , SQL_CURSOR_COMMIT_BEHAVIOR          => 'SQLUSMALLINT'        # SMALLINT
  , SQL_CURSOR_SENSITIVITY              => 'SQLUINTEGER'         # INTEGER
  , SQL_DATA_SOURCE_NAME                => 'SQLCHAR'             # CHARACTER (128)
  , SQL_DATA_SOURCE_READ_ONLY           => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_DBMS_NAME                       => 'SQLCHAR'             # CHARACTER (254)
  , SQL_DBMS_VERSION                    => 'SQLCHAR'             # CHARACTER (254)
  , SQL_DEFAULT_TRANSACTION_ISOLATION   => 'SQLUINTEGER'         # INTEGER
  , SQL_DESCRIBE_PARAMETER              => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_FETCH_DIRECTION                 => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_GETDATA_EXTENSIONS              => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_IDENTIFIER_CASE                 => 'SQLUSMALLINT'        # SMALLINT
  , SQL_INTEGRITY                       => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_MAXIMUM_CATALOG_NAME_LENGTH     => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY     => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY     => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_COLUMNS_IN_SELECT       => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_COLUMNS_IN_TABLE        => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_COLUMN_NAME_LENGTH      => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_CONCURRENT_ACTIVITIES   => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_CURSOR_NAME_LENGTH      => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_DRIVER_CONNECTIONS      => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_IDENTIFIER_LENGTH       => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_SCHEMA_NAME_LENGTH      => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_STMT_OCTETS             => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_STMT_OCTETS_DATA        => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_STMT_OCTETS_SCHEMA      => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_TABLES_IN_SELECT        => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_TABLE_NAME_LENGTH       => 'SQLUSMALLINT'        # SMALLINT
  , SQL_MAXIMUM_USER_NAME_LENGTH        => 'SQLUSMALLINT'        # SMALLINT
  , SQL_NULL_COLLATION                  => 'SQLUSMALLINT'        # SMALLINT
  , SQL_ORDER_BY_COLUMNS_IN_SELECT      => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_OUTER_JOIN_CAPABILITIES         => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_SCROLL_CONCURRENCY              => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_SEARCH_PATTERN_ESCAPE           => 'SQLCHAR'             # CHARACTER   (1)
  , SQL_SERVER_NAME                     => 'SQLCHAR'             # CHARACTER (128)
  , SQL_SPECIAL_CHARACTERS              => 'SQLCHAR'             # CHARACTER (254)
  , SQL_TRANSACTION_CAPABLE             => 'SQLUSMALLINT'        # SMALLINT
  , SQL_TRANSACTION_ISOLATION_OPTION    => 'SQLUINTEGER bitmask' # INTEGER
  , SQL_USER_NAME                       => 'SQLCHAR'             # CHARACTER (128)
  );
  
  =head2 %ReturnValues
  
  See: A.1 C header file SQLCLI.H, Page 317, 318.
  
  =cut
  
  $ReturnValues{SQL_ALTER_TABLE} =
  {
    SQL_AT_ADD_COLUMN                         => 0x00000001
  , SQL_AT_DROP_COLUMN                        => 0x00000002
  , SQL_AT_ALTER_COLUMN                       => 0x00000004
  , SQL_AT_ADD_CONSTRAINT                     => 0x00000008
  , SQL_AT_DROP_CONSTRAINT                    => 0x00000010
  };
  $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} =
  {
    SQL_CB_DELETE                             => 0
  , SQL_CB_CLOSE                              => 1
  , SQL_CB_PRESERVE                           => 2
  };
  $ReturnValues{SQL_FETCH_DIRECTION} =
  {
    SQL_FD_FETCH_NEXT                         => 0x00000001
  , SQL_FD_FETCH_FIRST                        => 0x00000002
  , SQL_FD_FETCH_LAST                         => 0x00000004
  , SQL_FD_FETCH_PRIOR                        => 0x00000008
  , SQL_FD_FETCH_ABSOLUTE                     => 0x00000010
  , SQL_FD_FETCH_RELATIVE                     => 0x00000020
  };
  $ReturnValues{SQL_GETDATA_EXTENSIONS} =
  {
    SQL_GD_ANY_COLUMN                         => 0x00000001
  , SQL_GD_ANY_ORDER                          => 0x00000002
  };
  $ReturnValues{SQL_IDENTIFIER_CASE} =
  {
    SQL_IC_UPPER                              => 1
  , SQL_IC_LOWER                              => 2
  , SQL_IC_SENSITIVE                          => 3
  , SQL_IC_MIXED                              => 4
  };
  $ReturnValues{SQL_NULL_COLLATION} =
  {
    SQL_NC_HIGH                               => 1
  , SQL_NC_LOW                                => 2
  };
  $ReturnValues{SQL_OUTER_JOIN_CAPABILITIES} =
  {
    SQL_OUTER_JOIN_LEFT                       => 0x00000001
  , SQL_OUTER_JOIN_RIGHT                      => 0x00000002
  , SQL_OUTER_JOIN_FULL                       => 0x00000004
  , SQL_OUTER_JOIN_NESTED                     => 0x00000008
  , SQL_OUTER_JOIN_NOT_ORDERED                => 0x00000010
  , SQL_OUTER_JOIN_INNER                      => 0x00000020
  , SQL_OUTER_JOIN_ALL_COMPARISON_OPS         => 0x00000040
  };
  $ReturnValues{SQL_SCROLL_CONCURRENCY} =
  {
    SQL_SCCO_READ_ONLY                        => 0x00000001
  , SQL_SCCO_LOCK                             => 0x00000002
  , SQL_SCCO_OPT_ROWVER                       => 0x00000004
  , SQL_SCCO_OPT_VALUES                       => 0x00000008
  };
  $ReturnValues{SQL_TRANSACTION_ACCESS_MODE} =
  {
    SQL_TRANSACTION_READ_ONLY                 => 0x00000001
  , SQL_TRANSACTION_READ_WRITE                => 0x00000002
  };
  $ReturnValues{SQL_TRANSACTION_CAPABLE} =
  {
    SQL_TC_NONE                               => 0
  , SQL_TC_DML                                => 1
  , SQL_TC_ALL                                => 2
  , SQL_TC_DDL_COMMIT                         => 3
  , SQL_TC_DDL_IGNORE                         => 4
  };
  $ReturnValues{SQL_TRANSACTION_ISOLATION} =
  {
    SQL_TRANSACTION_READ_UNCOMMITTED          => 0x00000001
  , SQL_TRANSACTION_READ_COMMITTED            => 0x00000002
  , SQL_TRANSACTION_REPEATABLE_READ           => 0x00000004
  , SQL_TRANSACTION_SERIALIZABLE              => 0x00000008
  };
  
  1;
  
  =head1 TODO
  
  Corrections, e.g.:
  
    SQL_TRANSACTION_ISOLATION_OPTION vs. SQL_TRANSACTION_ISOLATION
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFO_ANSI

$fatpacked{"darwin-thread-multi-2level/DBI/Const/GetInfo/ODBC.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFO_ODBC';
  # $Id: ODBC.pm 11373 2008-06-02 19:01:33Z timbo $
  #
  # Copyright (c) 2002  Tim Bunce  Ireland
  #
  # Constant data describing Microsoft ODBC info types and return values
  # for the SQLGetInfo() method of ODBC.
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  package DBI::Const::GetInfo::ODBC;
  
  =head1 NAME
  
  DBI::Const::GetInfo::ODBC - ODBC Constants for GetInfo
  
  =head1 SYNOPSIS
  
   The API for this module is private and subject to change.
  
  =head1 DESCRIPTION
  
  Information requested by GetInfo().
  
  The API for this module is private and subject to change.   
  
  =head1 REFERENCES
  
    MDAC SDK 2.6
    ODBC version number (0x0351)
  
    sql.h
    sqlext.h
  
  =cut
  
  my
  $VERSION = sprintf("2.%06d", q$Revision: 11373 $ =~ /(\d+)/o);
  
  
  %InfoTypes =
  (
    SQL_ACCESSIBLE_PROCEDURES           =>    20
  , SQL_ACCESSIBLE_TABLES               =>    19
  , SQL_ACTIVE_CONNECTIONS              =>     0
  , SQL_ACTIVE_ENVIRONMENTS             =>   116
  , SQL_ACTIVE_STATEMENTS               =>     1
  , SQL_AGGREGATE_FUNCTIONS             =>   169
  , SQL_ALTER_DOMAIN                    =>   117
  , SQL_ALTER_TABLE                     =>    86
  , SQL_ASYNC_MODE                      => 10021
  , SQL_BATCH_ROW_COUNT                 =>   120
  , SQL_BATCH_SUPPORT                   =>   121
  , SQL_BOOKMARK_PERSISTENCE            =>    82
  , SQL_CATALOG_LOCATION                =>   114  # SQL_QUALIFIER_LOCATION
  , SQL_CATALOG_NAME                    => 10003
  , SQL_CATALOG_NAME_SEPARATOR          =>    41  # SQL_QUALIFIER_NAME_SEPARATOR
  , SQL_CATALOG_TERM                    =>    42  # SQL_QUALIFIER_TERM
  , SQL_CATALOG_USAGE                   =>    92  # SQL_QUALIFIER_USAGE
  , SQL_COLLATION_SEQ                   => 10004
  , SQL_COLUMN_ALIAS                    =>    87
  , SQL_CONCAT_NULL_BEHAVIOR            =>    22
  , SQL_CONVERT_BIGINT                  =>    53
  , SQL_CONVERT_BINARY                  =>    54
  , SQL_CONVERT_BIT                     =>    55
  , SQL_CONVERT_CHAR                    =>    56
  , SQL_CONVERT_DATE                    =>    57
  , SQL_CONVERT_DECIMAL                 =>    58
  , SQL_CONVERT_DOUBLE                  =>    59
  , SQL_CONVERT_FLOAT                   =>    60
  , SQL_CONVERT_FUNCTIONS               =>    48
  , SQL_CONVERT_GUID                    =>   173
  , SQL_CONVERT_INTEGER                 =>    61
  , SQL_CONVERT_INTERVAL_DAY_TIME       =>   123
  , SQL_CONVERT_INTERVAL_YEAR_MONTH     =>   124
  , SQL_CONVERT_LONGVARBINARY           =>    71
  , SQL_CONVERT_LONGVARCHAR             =>    62
  , SQL_CONVERT_NUMERIC                 =>    63
  , SQL_CONVERT_REAL                    =>    64
  , SQL_CONVERT_SMALLINT                =>    65
  , SQL_CONVERT_TIME                    =>    66
  , SQL_CONVERT_TIMESTAMP               =>    67
  , SQL_CONVERT_TINYINT                 =>    68
  , SQL_CONVERT_VARBINARY               =>    69
  , SQL_CONVERT_VARCHAR                 =>    70
  , SQL_CONVERT_WCHAR                   =>   122
  , SQL_CONVERT_WLONGVARCHAR            =>   125
  , SQL_CONVERT_WVARCHAR                =>   126
  , SQL_CORRELATION_NAME                =>    74
  , SQL_CREATE_ASSERTION                =>   127
  , SQL_CREATE_CHARACTER_SET            =>   128
  , SQL_CREATE_COLLATION                =>   129
  , SQL_CREATE_DOMAIN                   =>   130
  , SQL_CREATE_SCHEMA                   =>   131
  , SQL_CREATE_TABLE                    =>   132
  , SQL_CREATE_TRANSLATION              =>   133
  , SQL_CREATE_VIEW                     =>   134
  , SQL_CURSOR_COMMIT_BEHAVIOR          =>    23
  , SQL_CURSOR_ROLLBACK_BEHAVIOR        =>    24
  , SQL_CURSOR_SENSITIVITY              => 10001
  , SQL_DATA_SOURCE_NAME                =>     2
  , SQL_DATA_SOURCE_READ_ONLY           =>    25
  , SQL_DATABASE_NAME                   =>    16 
  , SQL_DATETIME_LITERALS               =>   119
  , SQL_DBMS_NAME                       =>    17
  , SQL_DBMS_VER                        =>    18
  , SQL_DDL_INDEX                       =>   170
  , SQL_DEFAULT_TXN_ISOLATION           =>    26
  , SQL_DESCRIBE_PARAMETER              => 10002
  , SQL_DM_VER                          =>   171
  , SQL_DRIVER_HDBC                     =>     3
  , SQL_DRIVER_HDESC                    =>   135
  , SQL_DRIVER_HENV                     =>     4
  , SQL_DRIVER_HLIB                     =>    76
  , SQL_DRIVER_HSTMT                    =>     5
  , SQL_DRIVER_NAME                     =>     6
  , SQL_DRIVER_ODBC_VER                 =>    77
  , SQL_DRIVER_VER                      =>     7
  , SQL_DROP_ASSERTION                  =>   136
  , SQL_DROP_CHARACTER_SET              =>   137
  , SQL_DROP_COLLATION                  =>   138
  , SQL_DROP_DOMAIN                     =>   139
  , SQL_DROP_SCHEMA                     =>   140
  , SQL_DROP_TABLE                      =>   141
  , SQL_DROP_TRANSLATION                =>   142
  , SQL_DROP_VIEW                       =>   143
  , SQL_DYNAMIC_CURSOR_ATTRIBUTES1      =>   144
  , SQL_DYNAMIC_CURSOR_ATTRIBUTES2      =>   145
  , SQL_EXPRESSIONS_IN_ORDERBY          =>    27
  , SQL_FETCH_DIRECTION                 =>     8
  , SQL_FILE_USAGE                      =>    84
  , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 =>   146
  , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 =>   147
  , SQL_GETDATA_EXTENSIONS              =>    81
  , SQL_GROUP_BY                        =>    88
  , SQL_IDENTIFIER_CASE                 =>    28
  , SQL_IDENTIFIER_QUOTE_CHAR           =>    29
  , SQL_INDEX_KEYWORDS                  =>   148
  # SQL_INFO_DRIVER_START               =>  1000
  # SQL_INFO_FIRST                      =>     0
  # SQL_INFO_LAST                       =>   114  # SQL_QUALIFIER_LOCATION
  , SQL_INFO_SCHEMA_VIEWS               =>   149
  , SQL_INSERT_STATEMENT                =>   172
  , SQL_INTEGRITY                       =>    73
  , SQL_KEYSET_CURSOR_ATTRIBUTES1       =>   150
  , SQL_KEYSET_CURSOR_ATTRIBUTES2       =>   151
  , SQL_KEYWORDS                        =>    89
  , SQL_LIKE_ESCAPE_CLAUSE              =>   113
  , SQL_LOCK_TYPES                      =>    78
  , SQL_MAXIMUM_CATALOG_NAME_LENGTH     =>    34  # SQL_MAX_CATALOG_NAME_LEN
  , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY     =>    97  # SQL_MAX_COLUMNS_IN_GROUP_BY
  , SQL_MAXIMUM_COLUMNS_IN_INDEX        =>    98  # SQL_MAX_COLUMNS_IN_INDEX
  , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY     =>    99  # SQL_MAX_COLUMNS_IN_ORDER_BY
  , SQL_MAXIMUM_COLUMNS_IN_SELECT       =>   100  # SQL_MAX_COLUMNS_IN_SELECT
  , SQL_MAXIMUM_COLUMN_NAME_LENGTH      =>    30  # SQL_MAX_COLUMN_NAME_LEN
  , SQL_MAXIMUM_CONCURRENT_ACTIVITIES   =>     1  # SQL_MAX_CONCURRENT_ACTIVITIES
  , SQL_MAXIMUM_CURSOR_NAME_LENGTH      =>    31  # SQL_MAX_CURSOR_NAME_LEN
  , SQL_MAXIMUM_DRIVER_CONNECTIONS      =>     0  # SQL_MAX_DRIVER_CONNECTIONS
  , SQL_MAXIMUM_IDENTIFIER_LENGTH       => 10005  # SQL_MAX_IDENTIFIER_LEN
  , SQL_MAXIMUM_INDEX_SIZE              =>   102  # SQL_MAX_INDEX_SIZE
  , SQL_MAXIMUM_ROW_SIZE                =>   104  # SQL_MAX_ROW_SIZE
  , SQL_MAXIMUM_SCHEMA_NAME_LENGTH      =>    32  # SQL_MAX_SCHEMA_NAME_LEN
  , SQL_MAXIMUM_STATEMENT_LENGTH        =>   105  # SQL_MAX_STATEMENT_LEN
  , SQL_MAXIMUM_TABLES_IN_SELECT        =>   106  # SQL_MAX_TABLES_IN_SELECT
  , SQL_MAXIMUM_USER_NAME_LENGTH        =>   107  # SQL_MAX_USER_NAME_LEN
  , SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 10022
  , SQL_MAX_BINARY_LITERAL_LEN          =>   112
  , SQL_MAX_CATALOG_NAME_LEN            =>    34
  , SQL_MAX_CHAR_LITERAL_LEN            =>   108
  , SQL_MAX_COLUMNS_IN_GROUP_BY         =>    97
  , SQL_MAX_COLUMNS_IN_INDEX            =>    98
  , SQL_MAX_COLUMNS_IN_ORDER_BY         =>    99
  , SQL_MAX_COLUMNS_IN_SELECT           =>   100
  , SQL_MAX_COLUMNS_IN_TABLE            =>   101
  , SQL_MAX_COLUMN_NAME_LEN             =>    30
  , SQL_MAX_CONCURRENT_ACTIVITIES       =>     1
  , SQL_MAX_CURSOR_NAME_LEN             =>    31
  , SQL_MAX_DRIVER_CONNECTIONS          =>     0
  , SQL_MAX_IDENTIFIER_LEN              => 10005
  , SQL_MAX_INDEX_SIZE                  =>   102
  , SQL_MAX_OWNER_NAME_LEN              =>    32
  , SQL_MAX_PROCEDURE_NAME_LEN          =>    33
  , SQL_MAX_QUALIFIER_NAME_LEN          =>    34
  , SQL_MAX_ROW_SIZE                    =>   104
  , SQL_MAX_ROW_SIZE_INCLUDES_LONG      =>   103
  , SQL_MAX_SCHEMA_NAME_LEN             =>    32
  , SQL_MAX_STATEMENT_LEN               =>   105
  , SQL_MAX_TABLES_IN_SELECT            =>   106
  , SQL_MAX_TABLE_NAME_LEN              =>    35
  , SQL_MAX_USER_NAME_LEN               =>   107
  , SQL_MULTIPLE_ACTIVE_TXN             =>    37
  , SQL_MULT_RESULT_SETS                =>    36
  , SQL_NEED_LONG_DATA_LEN              =>   111
  , SQL_NON_NULLABLE_COLUMNS            =>    75
  , SQL_NULL_COLLATION                  =>    85
  , SQL_NUMERIC_FUNCTIONS               =>    49
  , SQL_ODBC_API_CONFORMANCE            =>     9
  , SQL_ODBC_INTERFACE_CONFORMANCE      =>   152
  , SQL_ODBC_SAG_CLI_CONFORMANCE        =>    12
  , SQL_ODBC_SQL_CONFORMANCE            =>    15
  , SQL_ODBC_SQL_OPT_IEF                =>    73
  , SQL_ODBC_VER                        =>    10
  , SQL_OJ_CAPABILITIES                 =>   115
  , SQL_ORDER_BY_COLUMNS_IN_SELECT      =>    90
  , SQL_OUTER_JOINS                     =>    38
  , SQL_OUTER_JOIN_CAPABILITIES         =>   115  # SQL_OJ_CAPABILITIES
  , SQL_OWNER_TERM                      =>    39
  , SQL_OWNER_USAGE                     =>    91
  , SQL_PARAM_ARRAY_ROW_COUNTS          =>   153
  , SQL_PARAM_ARRAY_SELECTS             =>   154
  , SQL_POSITIONED_STATEMENTS           =>    80
  , SQL_POS_OPERATIONS                  =>    79
  , SQL_PROCEDURES                      =>    21
  , SQL_PROCEDURE_TERM                  =>    40
  , SQL_QUALIFIER_LOCATION              =>   114
  , SQL_QUALIFIER_NAME_SEPARATOR        =>    41
  , SQL_QUALIFIER_TERM                  =>    42
  , SQL_QUALIFIER_USAGE                 =>    92
  , SQL_QUOTED_IDENTIFIER_CASE          =>    93
  , SQL_ROW_UPDATES                     =>    11
  , SQL_SCHEMA_TERM                     =>    39  # SQL_OWNER_TERM
  , SQL_SCHEMA_USAGE                    =>    91  # SQL_OWNER_USAGE
  , SQL_SCROLL_CONCURRENCY              =>    43
  , SQL_SCROLL_OPTIONS                  =>    44
  , SQL_SEARCH_PATTERN_ESCAPE           =>    14
  , SQL_SERVER_NAME                     =>    13
  , SQL_SPECIAL_CHARACTERS              =>    94
  , SQL_SQL92_DATETIME_FUNCTIONS        =>   155
  , SQL_SQL92_FOREIGN_KEY_DELETE_RULE   =>   156
  , SQL_SQL92_FOREIGN_KEY_UPDATE_RULE   =>   157
  , SQL_SQL92_GRANT                     =>   158
  , SQL_SQL92_NUMERIC_VALUE_FUNCTIONS   =>   159
  , SQL_SQL92_PREDICATES                =>   160
  , SQL_SQL92_RELATIONAL_JOIN_OPERATORS =>   161
  , SQL_SQL92_REVOKE                    =>   162
  , SQL_SQL92_ROW_VALUE_CONSTRUCTOR     =>   163
  , SQL_SQL92_STRING_FUNCTIONS          =>   164
  , SQL_SQL92_VALUE_EXPRESSIONS         =>   165
  , SQL_SQL_CONFORMANCE                 =>   118
  , SQL_STANDARD_CLI_CONFORMANCE        =>   166
  , SQL_STATIC_CURSOR_ATTRIBUTES1       =>   167
  , SQL_STATIC_CURSOR_ATTRIBUTES2       =>   168
  , SQL_STATIC_SENSITIVITY              =>    83
  , SQL_STRING_FUNCTIONS                =>    50
  , SQL_SUBQUERIES                      =>    95
  , SQL_SYSTEM_FUNCTIONS                =>    51
  , SQL_TABLE_TERM                      =>    45
  , SQL_TIMEDATE_ADD_INTERVALS          =>   109
  , SQL_TIMEDATE_DIFF_INTERVALS         =>   110
  , SQL_TIMEDATE_FUNCTIONS              =>    52
  , SQL_TRANSACTION_CAPABLE             =>    46  # SQL_TXN_CAPABLE
  , SQL_TRANSACTION_ISOLATION_OPTION    =>    72  # SQL_TXN_ISOLATION_OPTION
  , SQL_TXN_CAPABLE                     =>    46
  , SQL_TXN_ISOLATION_OPTION            =>    72
  , SQL_UNION                           =>    96
  , SQL_UNION_STATEMENT                 =>    96  # SQL_UNION
  , SQL_USER_NAME                       =>    47
  , SQL_XOPEN_CLI_YEAR                  => 10000
  );
  
  =head2 %ReturnTypes
  
  See: mk:@MSITStore:X:\dm\cli\mdac\sdk26\Docs\odbc.chm::/htm/odbcsqlgetinfo.htm
  
    =>     : alias
    => !!! : edited
  
  =cut
  
  %ReturnTypes =
  (
    SQL_ACCESSIBLE_PROCEDURES           => 'SQLCHAR'             #    20
  , SQL_ACCESSIBLE_TABLES               => 'SQLCHAR'             #    19
  , SQL_ACTIVE_CONNECTIONS              => 'SQLUSMALLINT'        #     0  =>
  , SQL_ACTIVE_ENVIRONMENTS             => 'SQLUSMALLINT'        #   116
  , SQL_ACTIVE_STATEMENTS               => 'SQLUSMALLINT'        #     1  =>
  , SQL_AGGREGATE_FUNCTIONS             => 'SQLUINTEGER bitmask' #   169
  , SQL_ALTER_DOMAIN                    => 'SQLUINTEGER bitmask' #   117
  , SQL_ALTER_TABLE                     => 'SQLUINTEGER bitmask' #    86
  , SQL_ASYNC_MODE                      => 'SQLUINTEGER'         # 10021
  , SQL_BATCH_ROW_COUNT                 => 'SQLUINTEGER bitmask' #   120
  , SQL_BATCH_SUPPORT                   => 'SQLUINTEGER bitmask' #   121
  , SQL_BOOKMARK_PERSISTENCE            => 'SQLUINTEGER bitmask' #    82
  , SQL_CATALOG_LOCATION                => 'SQLUSMALLINT'        #   114
  , SQL_CATALOG_NAME                    => 'SQLCHAR'             # 10003
  , SQL_CATALOG_NAME_SEPARATOR          => 'SQLCHAR'             #    41
  , SQL_CATALOG_TERM                    => 'SQLCHAR'             #    42
  , SQL_CATALOG_USAGE                   => 'SQLUINTEGER bitmask' #    92
  , SQL_COLLATION_SEQ                   => 'SQLCHAR'             # 10004
  , SQL_COLUMN_ALIAS                    => 'SQLCHAR'             #    87
  , SQL_CONCAT_NULL_BEHAVIOR            => 'SQLUSMALLINT'        #    22
  , SQL_CONVERT_BIGINT                  => 'SQLUINTEGER bitmask' #    53
  , SQL_CONVERT_BINARY                  => 'SQLUINTEGER bitmask' #    54
  , SQL_CONVERT_BIT                     => 'SQLUINTEGER bitmask' #    55
  , SQL_CONVERT_CHAR                    => 'SQLUINTEGER bitmask' #    56
  , SQL_CONVERT_DATE                    => 'SQLUINTEGER bitmask' #    57
  , SQL_CONVERT_DECIMAL                 => 'SQLUINTEGER bitmask' #    58
  , SQL_CONVERT_DOUBLE                  => 'SQLUINTEGER bitmask' #    59
  , SQL_CONVERT_FLOAT                   => 'SQLUINTEGER bitmask' #    60
  , SQL_CONVERT_FUNCTIONS               => 'SQLUINTEGER bitmask' #    48
  , SQL_CONVERT_GUID                    => 'SQLUINTEGER bitmask' #   173
  , SQL_CONVERT_INTEGER                 => 'SQLUINTEGER bitmask' #    61
  , SQL_CONVERT_INTERVAL_DAY_TIME       => 'SQLUINTEGER bitmask' #   123
  , SQL_CONVERT_INTERVAL_YEAR_MONTH     => 'SQLUINTEGER bitmask' #   124
  , SQL_CONVERT_LONGVARBINARY           => 'SQLUINTEGER bitmask' #    71
  , SQL_CONVERT_LONGVARCHAR             => 'SQLUINTEGER bitmask' #    62
  , SQL_CONVERT_NUMERIC                 => 'SQLUINTEGER bitmask' #    63
  , SQL_CONVERT_REAL                    => 'SQLUINTEGER bitmask' #    64
  , SQL_CONVERT_SMALLINT                => 'SQLUINTEGER bitmask' #    65
  , SQL_CONVERT_TIME                    => 'SQLUINTEGER bitmask' #    66
  , SQL_CONVERT_TIMESTAMP               => 'SQLUINTEGER bitmask' #    67
  , SQL_CONVERT_TINYINT                 => 'SQLUINTEGER bitmask' #    68
  , SQL_CONVERT_VARBINARY               => 'SQLUINTEGER bitmask' #    69
  , SQL_CONVERT_VARCHAR                 => 'SQLUINTEGER bitmask' #    70
  , SQL_CONVERT_WCHAR                   => 'SQLUINTEGER bitmask' #   122  => !!!
  , SQL_CONVERT_WLONGVARCHAR            => 'SQLUINTEGER bitmask' #   125  => !!!
  , SQL_CONVERT_WVARCHAR                => 'SQLUINTEGER bitmask' #   126  => !!!
  , SQL_CORRELATION_NAME                => 'SQLUSMALLINT'        #    74
  , SQL_CREATE_ASSERTION                => 'SQLUINTEGER bitmask' #   127
  , SQL_CREATE_CHARACTER_SET            => 'SQLUINTEGER bitmask' #   128
  , SQL_CREATE_COLLATION                => 'SQLUINTEGER bitmask' #   129
  , SQL_CREATE_DOMAIN                   => 'SQLUINTEGER bitmask' #   130
  , SQL_CREATE_SCHEMA                   => 'SQLUINTEGER bitmask' #   131
  , SQL_CREATE_TABLE                    => 'SQLUINTEGER bitmask' #   132
  , SQL_CREATE_TRANSLATION              => 'SQLUINTEGER bitmask' #   133
  , SQL_CREATE_VIEW                     => 'SQLUINTEGER bitmask' #   134
  , SQL_CURSOR_COMMIT_BEHAVIOR          => 'SQLUSMALLINT'        #    23
  , SQL_CURSOR_ROLLBACK_BEHAVIOR        => 'SQLUSMALLINT'        #    24
  , SQL_CURSOR_SENSITIVITY              => 'SQLUINTEGER'         # 10001
  , SQL_DATA_SOURCE_NAME                => 'SQLCHAR'             #     2
  , SQL_DATA_SOURCE_READ_ONLY           => 'SQLCHAR'             #    25
  , SQL_DATABASE_NAME                   => 'SQLCHAR'             #    16 
  , SQL_DATETIME_LITERALS               => 'SQLUINTEGER bitmask' #   119
  , SQL_DBMS_NAME                       => 'SQLCHAR'             #    17
  , SQL_DBMS_VER                        => 'SQLCHAR'             #    18
  , SQL_DDL_INDEX                       => 'SQLUINTEGER bitmask' #   170
  , SQL_DEFAULT_TXN_ISOLATION           => 'SQLUINTEGER'         #    26
  , SQL_DESCRIBE_PARAMETER              => 'SQLCHAR'             # 10002
  , SQL_DM_VER                          => 'SQLCHAR'             #   171
  , SQL_DRIVER_HDBC                     => 'SQLUINTEGER'         #     3
  , SQL_DRIVER_HDESC                    => 'SQLUINTEGER'         #   135
  , SQL_DRIVER_HENV                     => 'SQLUINTEGER'         #     4
  , SQL_DRIVER_HLIB                     => 'SQLUINTEGER'         #    76
  , SQL_DRIVER_HSTMT                    => 'SQLUINTEGER'         #     5
  , SQL_DRIVER_NAME                     => 'SQLCHAR'             #     6
  , SQL_DRIVER_ODBC_VER                 => 'SQLCHAR'             #    77
  , SQL_DRIVER_VER                      => 'SQLCHAR'             #     7
  , SQL_DROP_ASSERTION                  => 'SQLUINTEGER bitmask' #   136
  , SQL_DROP_CHARACTER_SET              => 'SQLUINTEGER bitmask' #   137
  , SQL_DROP_COLLATION                  => 'SQLUINTEGER bitmask' #   138
  , SQL_DROP_DOMAIN                     => 'SQLUINTEGER bitmask' #   139
  , SQL_DROP_SCHEMA                     => 'SQLUINTEGER bitmask' #   140
  , SQL_DROP_TABLE                      => 'SQLUINTEGER bitmask' #   141
  , SQL_DROP_TRANSLATION                => 'SQLUINTEGER bitmask' #   142
  , SQL_DROP_VIEW                       => 'SQLUINTEGER bitmask' #   143
  , SQL_DYNAMIC_CURSOR_ATTRIBUTES1      => 'SQLUINTEGER bitmask' #   144
  , SQL_DYNAMIC_CURSOR_ATTRIBUTES2      => 'SQLUINTEGER bitmask' #   145
  , SQL_EXPRESSIONS_IN_ORDERBY          => 'SQLCHAR'             #    27
  , SQL_FETCH_DIRECTION                 => 'SQLUINTEGER bitmask' #     8  => !!!
  , SQL_FILE_USAGE                      => 'SQLUSMALLINT'        #    84
  , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' #   146
  , SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' #   147
  , SQL_GETDATA_EXTENSIONS              => 'SQLUINTEGER bitmask' #    81
  , SQL_GROUP_BY                        => 'SQLUSMALLINT'        #    88
  , SQL_IDENTIFIER_CASE                 => 'SQLUSMALLINT'        #    28
  , SQL_IDENTIFIER_QUOTE_CHAR           => 'SQLCHAR'             #    29
  , SQL_INDEX_KEYWORDS                  => 'SQLUINTEGER bitmask' #   148
  # SQL_INFO_DRIVER_START               => ''                    #  1000  =>
  # SQL_INFO_FIRST                      => 'SQLUSMALLINT'        #     0  =>
  # SQL_INFO_LAST                       => 'SQLUSMALLINT'        #   114  =>
  , SQL_INFO_SCHEMA_VIEWS               => 'SQLUINTEGER bitmask' #   149
  , SQL_INSERT_STATEMENT                => 'SQLUINTEGER bitmask' #   172
  , SQL_INTEGRITY                       => 'SQLCHAR'             #    73
  , SQL_KEYSET_CURSOR_ATTRIBUTES1       => 'SQLUINTEGER bitmask' #   150
  , SQL_KEYSET_CURSOR_ATTRIBUTES2       => 'SQLUINTEGER bitmask' #   151
  , SQL_KEYWORDS                        => 'SQLCHAR'             #    89
  , SQL_LIKE_ESCAPE_CLAUSE              => 'SQLCHAR'             #   113
  , SQL_LOCK_TYPES                      => 'SQLUINTEGER bitmask' #    78  => !!!
  , SQL_MAXIMUM_CATALOG_NAME_LENGTH     => 'SQLUSMALLINT'        #    34  =>
  , SQL_MAXIMUM_COLUMNS_IN_GROUP_BY     => 'SQLUSMALLINT'        #    97  =>
  , SQL_MAXIMUM_COLUMNS_IN_INDEX        => 'SQLUSMALLINT'        #    98  =>
  , SQL_MAXIMUM_COLUMNS_IN_ORDER_BY     => 'SQLUSMALLINT'        #    99  =>
  , SQL_MAXIMUM_COLUMNS_IN_SELECT       => 'SQLUSMALLINT'        #   100  =>
  , SQL_MAXIMUM_COLUMN_NAME_LENGTH      => 'SQLUSMALLINT'        #    30  =>
  , SQL_MAXIMUM_CONCURRENT_ACTIVITIES   => 'SQLUSMALLINT'        #     1  =>
  , SQL_MAXIMUM_CURSOR_NAME_LENGTH      => 'SQLUSMALLINT'        #    31  =>
  , SQL_MAXIMUM_DRIVER_CONNECTIONS      => 'SQLUSMALLINT'        #     0  =>
  , SQL_MAXIMUM_IDENTIFIER_LENGTH       => 'SQLUSMALLINT'        # 10005  =>
  , SQL_MAXIMUM_INDEX_SIZE              => 'SQLUINTEGER'         #   102  =>
  , SQL_MAXIMUM_ROW_SIZE                => 'SQLUINTEGER'         #   104  =>
  , SQL_MAXIMUM_SCHEMA_NAME_LENGTH      => 'SQLUSMALLINT'        #    32  =>
  , SQL_MAXIMUM_STATEMENT_LENGTH        => 'SQLUINTEGER'         #   105  =>
  , SQL_MAXIMUM_TABLES_IN_SELECT        => 'SQLUSMALLINT'        #   106  =>
  , SQL_MAXIMUM_USER_NAME_LENGTH        => 'SQLUSMALLINT'        #   107  =>
  , SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 'SQLUINTEGER'         # 10022
  , SQL_MAX_BINARY_LITERAL_LEN          => 'SQLUINTEGER'         #   112
  , SQL_MAX_CATALOG_NAME_LEN            => 'SQLUSMALLINT'        #    34
  , SQL_MAX_CHAR_LITERAL_LEN            => 'SQLUINTEGER'         #   108
  , SQL_MAX_COLUMNS_IN_GROUP_BY         => 'SQLUSMALLINT'        #    97
  , SQL_MAX_COLUMNS_IN_INDEX            => 'SQLUSMALLINT'        #    98
  , SQL_MAX_COLUMNS_IN_ORDER_BY         => 'SQLUSMALLINT'        #    99
  , SQL_MAX_COLUMNS_IN_SELECT           => 'SQLUSMALLINT'        #   100
  , SQL_MAX_COLUMNS_IN_TABLE            => 'SQLUSMALLINT'        #   101
  , SQL_MAX_COLUMN_NAME_LEN             => 'SQLUSMALLINT'        #    30
  , SQL_MAX_CONCURRENT_ACTIVITIES       => 'SQLUSMALLINT'        #     1
  , SQL_MAX_CURSOR_NAME_LEN             => 'SQLUSMALLINT'        #    31
  , SQL_MAX_DRIVER_CONNECTIONS          => 'SQLUSMALLINT'        #     0
  , SQL_MAX_IDENTIFIER_LEN              => 'SQLUSMALLINT'        # 10005
  , SQL_MAX_INDEX_SIZE                  => 'SQLUINTEGER'         #   102
  , SQL_MAX_OWNER_NAME_LEN              => 'SQLUSMALLINT'        #    32  =>
  , SQL_MAX_PROCEDURE_NAME_LEN          => 'SQLUSMALLINT'        #    33
  , SQL_MAX_QUALIFIER_NAME_LEN          => 'SQLUSMALLINT'        #    34  =>
  , SQL_MAX_ROW_SIZE                    => 'SQLUINTEGER'         #   104
  , SQL_MAX_ROW_SIZE_INCLUDES_LONG      => 'SQLCHAR'             #   103
  , SQL_MAX_SCHEMA_NAME_LEN             => 'SQLUSMALLINT'        #    32
  , SQL_MAX_STATEMENT_LEN               => 'SQLUINTEGER'         #   105
  , SQL_MAX_TABLES_IN_SELECT            => 'SQLUSMALLINT'        #   106
  , SQL_MAX_TABLE_NAME_LEN              => 'SQLUSMALLINT'        #    35
  , SQL_MAX_USER_NAME_LEN               => 'SQLUSMALLINT'        #   107
  , SQL_MULTIPLE_ACTIVE_TXN             => 'SQLCHAR'             #    37
  , SQL_MULT_RESULT_SETS                => 'SQLCHAR'             #    36
  , SQL_NEED_LONG_DATA_LEN              => 'SQLCHAR'             #   111
  , SQL_NON_NULLABLE_COLUMNS            => 'SQLUSMALLINT'        #    75
  , SQL_NULL_COLLATION                  => 'SQLUSMALLINT'        #    85
  , SQL_NUMERIC_FUNCTIONS               => 'SQLUINTEGER bitmask' #    49
  , SQL_ODBC_API_CONFORMANCE            => 'SQLUSMALLINT'        #     9  => !!!
  , SQL_ODBC_INTERFACE_CONFORMANCE      => 'SQLUINTEGER'         #   152
  , SQL_ODBC_SAG_CLI_CONFORMANCE        => 'SQLUSMALLINT'        #    12  => !!!
  , SQL_ODBC_SQL_CONFORMANCE            => 'SQLUSMALLINT'        #    15  => !!!
  , SQL_ODBC_SQL_OPT_IEF                => 'SQLCHAR'             #    73  =>
  , SQL_ODBC_VER                        => 'SQLCHAR'             #    10
  , SQL_OJ_CAPABILITIES                 => 'SQLUINTEGER bitmask' #   115
  , SQL_ORDER_BY_COLUMNS_IN_SELECT      => 'SQLCHAR'             #    90
  , SQL_OUTER_JOINS                     => 'SQLCHAR'             #    38  => !!!
  , SQL_OUTER_JOIN_CAPABILITIES         => 'SQLUINTEGER bitmask' #   115  =>
  , SQL_OWNER_TERM                      => 'SQLCHAR'             #    39  =>
  , SQL_OWNER_USAGE                     => 'SQLUINTEGER bitmask' #    91  =>
  , SQL_PARAM_ARRAY_ROW_COUNTS          => 'SQLUINTEGER'         #   153
  , SQL_PARAM_ARRAY_SELECTS             => 'SQLUINTEGER'         #   154
  , SQL_POSITIONED_STATEMENTS           => 'SQLUINTEGER bitmask' #    80  => !!!
  , SQL_POS_OPERATIONS                  => 'SQLINTEGER bitmask'  #    79
  , SQL_PROCEDURES                      => 'SQLCHAR'             #    21
  , SQL_PROCEDURE_TERM                  => 'SQLCHAR'             #    40
  , SQL_QUALIFIER_LOCATION              => 'SQLUSMALLINT'        #   114  =>
  , SQL_QUALIFIER_NAME_SEPARATOR        => 'SQLCHAR'             #    41  =>
  , SQL_QUALIFIER_TERM                  => 'SQLCHAR'             #    42  =>
  , SQL_QUALIFIER_USAGE                 => 'SQLUINTEGER bitmask' #    92  =>
  , SQL_QUOTED_IDENTIFIER_CASE          => 'SQLUSMALLINT'        #    93
  , SQL_ROW_UPDATES                     => 'SQLCHAR'             #    11
  , SQL_SCHEMA_TERM                     => 'SQLCHAR'             #    39
  , SQL_SCHEMA_USAGE                    => 'SQLUINTEGER bitmask' #    91
  , SQL_SCROLL_CONCURRENCY              => 'SQLUINTEGER bitmask' #    43  => !!!
  , SQL_SCROLL_OPTIONS                  => 'SQLUINTEGER bitmask' #    44
  , SQL_SEARCH_PATTERN_ESCAPE           => 'SQLCHAR'             #    14
  , SQL_SERVER_NAME                     => 'SQLCHAR'             #    13
  , SQL_SPECIAL_CHARACTERS              => 'SQLCHAR'             #    94
  , SQL_SQL92_DATETIME_FUNCTIONS        => 'SQLUINTEGER bitmask' #   155
  , SQL_SQL92_FOREIGN_KEY_DELETE_RULE   => 'SQLUINTEGER bitmask' #   156
  , SQL_SQL92_FOREIGN_KEY_UPDATE_RULE   => 'SQLUINTEGER bitmask' #   157
  , SQL_SQL92_GRANT                     => 'SQLUINTEGER bitmask' #   158
  , SQL_SQL92_NUMERIC_VALUE_FUNCTIONS   => 'SQLUINTEGER bitmask' #   159
  , SQL_SQL92_PREDICATES                => 'SQLUINTEGER bitmask' #   160
  , SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 'SQLUINTEGER bitmask' #   161
  , SQL_SQL92_REVOKE                    => 'SQLUINTEGER bitmask' #   162
  , SQL_SQL92_ROW_VALUE_CONSTRUCTOR     => 'SQLUINTEGER bitmask' #   163
  , SQL_SQL92_STRING_FUNCTIONS          => 'SQLUINTEGER bitmask' #   164
  , SQL_SQL92_VALUE_EXPRESSIONS         => 'SQLUINTEGER bitmask' #   165
  , SQL_SQL_CONFORMANCE                 => 'SQLUINTEGER'         #   118
  , SQL_STANDARD_CLI_CONFORMANCE        => 'SQLUINTEGER bitmask' #   166
  , SQL_STATIC_CURSOR_ATTRIBUTES1       => 'SQLUINTEGER bitmask' #   167
  , SQL_STATIC_CURSOR_ATTRIBUTES2       => 'SQLUINTEGER bitmask' #   168
  , SQL_STATIC_SENSITIVITY              => 'SQLUINTEGER bitmask' #    83  => !!!
  , SQL_STRING_FUNCTIONS                => 'SQLUINTEGER bitmask' #    50
  , SQL_SUBQUERIES                      => 'SQLUINTEGER bitmask' #    95
  , SQL_SYSTEM_FUNCTIONS                => 'SQLUINTEGER bitmask' #    51
  , SQL_TABLE_TERM                      => 'SQLCHAR'             #    45
  , SQL_TIMEDATE_ADD_INTERVALS          => 'SQLUINTEGER bitmask' #   109
  , SQL_TIMEDATE_DIFF_INTERVALS         => 'SQLUINTEGER bitmask' #   110
  , SQL_TIMEDATE_FUNCTIONS              => 'SQLUINTEGER bitmask' #    52
  , SQL_TRANSACTION_CAPABLE             => 'SQLUSMALLINT'        #    46  =>
  , SQL_TRANSACTION_ISOLATION_OPTION    => 'SQLUINTEGER bitmask' #    72  =>
  , SQL_TXN_CAPABLE                     => 'SQLUSMALLINT'        #    46
  , SQL_TXN_ISOLATION_OPTION            => 'SQLUINTEGER bitmask' #    72
  , SQL_UNION                           => 'SQLUINTEGER bitmask' #    96
  , SQL_UNION_STATEMENT                 => 'SQLUINTEGER bitmask' #    96  =>
  , SQL_USER_NAME                       => 'SQLCHAR'             #    47
  , SQL_XOPEN_CLI_YEAR                  => 'SQLCHAR'             # 10000
  );
  
  =head2 %ReturnValues
  
  See: sql.h, sqlext.h
  Edited:
    SQL_TXN_ISOLATION_OPTION
  
  =cut
  
  $ReturnValues{SQL_AGGREGATE_FUNCTIONS} =
  {
    SQL_AF_AVG                                => 0x00000001
  , SQL_AF_COUNT                              => 0x00000002
  , SQL_AF_MAX                                => 0x00000004
  , SQL_AF_MIN                                => 0x00000008
  , SQL_AF_SUM                                => 0x00000010
  , SQL_AF_DISTINCT                           => 0x00000020
  , SQL_AF_ALL                                => 0x00000040
  };
  $ReturnValues{SQL_ALTER_DOMAIN} =
  {
    SQL_AD_CONSTRAINT_NAME_DEFINITION         => 0x00000001
  , SQL_AD_ADD_DOMAIN_CONSTRAINT              => 0x00000002
  , SQL_AD_DROP_DOMAIN_CONSTRAINT             => 0x00000004
  , SQL_AD_ADD_DOMAIN_DEFAULT                 => 0x00000008
  , SQL_AD_DROP_DOMAIN_DEFAULT                => 0x00000010
  , SQL_AD_ADD_CONSTRAINT_INITIALLY_DEFERRED  => 0x00000020
  , SQL_AD_ADD_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040
  , SQL_AD_ADD_CONSTRAINT_DEFERRABLE          => 0x00000080
  , SQL_AD_ADD_CONSTRAINT_NON_DEFERRABLE      => 0x00000100
  };
  $ReturnValues{SQL_ALTER_TABLE} =
  {
    SQL_AT_ADD_COLUMN                         => 0x00000001
  , SQL_AT_DROP_COLUMN                        => 0x00000002
  , SQL_AT_ADD_CONSTRAINT                     => 0x00000008
  , SQL_AT_ADD_COLUMN_SINGLE                  => 0x00000020
  , SQL_AT_ADD_COLUMN_DEFAULT                 => 0x00000040
  , SQL_AT_ADD_COLUMN_COLLATION               => 0x00000080
  , SQL_AT_SET_COLUMN_DEFAULT                 => 0x00000100
  , SQL_AT_DROP_COLUMN_DEFAULT                => 0x00000200
  , SQL_AT_DROP_COLUMN_CASCADE                => 0x00000400
  , SQL_AT_DROP_COLUMN_RESTRICT               => 0x00000800
  , SQL_AT_ADD_TABLE_CONSTRAINT               => 0x00001000
  , SQL_AT_DROP_TABLE_CONSTRAINT_CASCADE      => 0x00002000
  , SQL_AT_DROP_TABLE_CONSTRAINT_RESTRICT     => 0x00004000
  , SQL_AT_CONSTRAINT_NAME_DEFINITION         => 0x00008000
  , SQL_AT_CONSTRAINT_INITIALLY_DEFERRED      => 0x00010000
  , SQL_AT_CONSTRAINT_INITIALLY_IMMEDIATE     => 0x00020000
  , SQL_AT_CONSTRAINT_DEFERRABLE              => 0x00040000
  , SQL_AT_CONSTRAINT_NON_DEFERRABLE          => 0x00080000
  };
  $ReturnValues{SQL_ASYNC_MODE} =
  {
    SQL_AM_NONE                               => 0
  , SQL_AM_CONNECTION                         => 1
  , SQL_AM_STATEMENT                          => 2
  };
  $ReturnValues{SQL_ATTR_MAX_ROWS} =
  {
    SQL_CA2_MAX_ROWS_SELECT                   => 0x00000080
  , SQL_CA2_MAX_ROWS_INSERT                   => 0x00000100
  , SQL_CA2_MAX_ROWS_DELETE                   => 0x00000200
  , SQL_CA2_MAX_ROWS_UPDATE                   => 0x00000400
  , SQL_CA2_MAX_ROWS_CATALOG                  => 0x00000800
  # SQL_CA2_MAX_ROWS_AFFECTS_ALL              =>
  };
  $ReturnValues{SQL_ATTR_SCROLL_CONCURRENCY} =
  {
    SQL_CA2_READ_ONLY_CONCURRENCY             => 0x00000001
  , SQL_CA2_LOCK_CONCURRENCY                  => 0x00000002
  , SQL_CA2_OPT_ROWVER_CONCURRENCY            => 0x00000004
  , SQL_CA2_OPT_VALUES_CONCURRENCY            => 0x00000008
  , SQL_CA2_SENSITIVITY_ADDITIONS             => 0x00000010
  , SQL_CA2_SENSITIVITY_DELETIONS             => 0x00000020
  , SQL_CA2_SENSITIVITY_UPDATES               => 0x00000040
  };
  $ReturnValues{SQL_BATCH_ROW_COUNT} =
  {
    SQL_BRC_PROCEDURES                        => 0x0000001
  , SQL_BRC_EXPLICIT                          => 0x0000002
  , SQL_BRC_ROLLED_UP                         => 0x0000004
  };
  $ReturnValues{SQL_BATCH_SUPPORT} =
  {
    SQL_BS_SELECT_EXPLICIT                    => 0x00000001
  , SQL_BS_ROW_COUNT_EXPLICIT                 => 0x00000002
  , SQL_BS_SELECT_PROC                        => 0x00000004
  , SQL_BS_ROW_COUNT_PROC                     => 0x00000008
  };
  $ReturnValues{SQL_BOOKMARK_PERSISTENCE} =
  {
    SQL_BP_CLOSE                              => 0x00000001
  , SQL_BP_DELETE                             => 0x00000002
  , SQL_BP_DROP                               => 0x00000004
  , SQL_BP_TRANSACTION                        => 0x00000008
  , SQL_BP_UPDATE                             => 0x00000010
  , SQL_BP_OTHER_HSTMT                        => 0x00000020
  , SQL_BP_SCROLL                             => 0x00000040
  };
  $ReturnValues{SQL_CATALOG_LOCATION} =
  {
    SQL_CL_START                              => 0x0001  # SQL_QL_START
  , SQL_CL_END                                => 0x0002  # SQL_QL_END
  };
  $ReturnValues{SQL_CATALOG_USAGE} =
  {
    SQL_CU_DML_STATEMENTS                     => 0x00000001  # SQL_QU_DML_STATEMENTS
  , SQL_CU_PROCEDURE_INVOCATION               => 0x00000002  # SQL_QU_PROCEDURE_INVOCATION
  , SQL_CU_TABLE_DEFINITION                   => 0x00000004  # SQL_QU_TABLE_DEFINITION
  , SQL_CU_INDEX_DEFINITION                   => 0x00000008  # SQL_QU_INDEX_DEFINITION
  , SQL_CU_PRIVILEGE_DEFINITION               => 0x00000010  # SQL_QU_PRIVILEGE_DEFINITION
  };
  $ReturnValues{SQL_CONCAT_NULL_BEHAVIOR} =
  {
    SQL_CB_NULL                               => 0x0000
  , SQL_CB_NON_NULL                           => 0x0001
  };
  $ReturnValues{SQL_CONVERT_} =
  {
    SQL_CVT_CHAR                              => 0x00000001
  , SQL_CVT_NUMERIC                           => 0x00000002
  , SQL_CVT_DECIMAL                           => 0x00000004
  , SQL_CVT_INTEGER                           => 0x00000008
  , SQL_CVT_SMALLINT                          => 0x00000010
  , SQL_CVT_FLOAT                             => 0x00000020
  , SQL_CVT_REAL                              => 0x00000040
  , SQL_CVT_DOUBLE                            => 0x00000080
  , SQL_CVT_VARCHAR                           => 0x00000100
  , SQL_CVT_LONGVARCHAR                       => 0x00000200
  , SQL_CVT_BINARY                            => 0x00000400
  , SQL_CVT_VARBINARY                         => 0x00000800
  , SQL_CVT_BIT                               => 0x00001000
  , SQL_CVT_TINYINT                           => 0x00002000
  , SQL_CVT_BIGINT                            => 0x00004000
  , SQL_CVT_DATE                              => 0x00008000
  , SQL_CVT_TIME                              => 0x00010000
  , SQL_CVT_TIMESTAMP                         => 0x00020000
  , SQL_CVT_LONGVARBINARY                     => 0x00040000
  , SQL_CVT_INTERVAL_YEAR_MONTH               => 0x00080000
  , SQL_CVT_INTERVAL_DAY_TIME                 => 0x00100000
  , SQL_CVT_WCHAR                             => 0x00200000
  , SQL_CVT_WLONGVARCHAR                      => 0x00400000
  , SQL_CVT_WVARCHAR                          => 0x00800000
  , SQL_CVT_GUID                              => 0x01000000
  };
  $ReturnValues{SQL_CONVERT_BIGINT             } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_BINARY             } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_BIT                } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_CHAR               } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_DATE               } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_DECIMAL            } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_DOUBLE             } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_FLOAT              } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_GUID               } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_INTEGER            } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_INTERVAL_DAY_TIME  } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_INTERVAL_YEAR_MONTH} = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_LONGVARBINARY      } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_LONGVARCHAR        } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_NUMERIC            } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_REAL               } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_SMALLINT           } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_TIME               } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_TIMESTAMP          } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_TINYINT            } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_VARBINARY          } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_VARCHAR            } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_WCHAR              } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_WLONGVARCHAR       } = $ReturnValues{SQL_CONVERT_};
  $ReturnValues{SQL_CONVERT_WVARCHAR           } = $ReturnValues{SQL_CONVERT_};
  
  $ReturnValues{SQL_CONVERT_FUNCTIONS} =
  {
    SQL_FN_CVT_CONVERT                        => 0x00000001
  , SQL_FN_CVT_CAST                           => 0x00000002
  };
  $ReturnValues{SQL_CORRELATION_NAME} =
  {
    SQL_CN_NONE                               => 0x0000
  , SQL_CN_DIFFERENT                          => 0x0001
  , SQL_CN_ANY                                => 0x0002
  };
  $ReturnValues{SQL_CREATE_ASSERTION} =
  {
    SQL_CA_CREATE_ASSERTION                   => 0x00000001
  , SQL_CA_CONSTRAINT_INITIALLY_DEFERRED      => 0x00000010
  , SQL_CA_CONSTRAINT_INITIALLY_IMMEDIATE     => 0x00000020
  , SQL_CA_CONSTRAINT_DEFERRABLE              => 0x00000040
  , SQL_CA_CONSTRAINT_NON_DEFERRABLE          => 0x00000080
  };
  $ReturnValues{SQL_CREATE_CHARACTER_SET} =
  {
    SQL_CCS_CREATE_CHARACTER_SET              => 0x00000001
  , SQL_CCS_COLLATE_CLAUSE                    => 0x00000002
  , SQL_CCS_LIMITED_COLLATION                 => 0x00000004
  };
  $ReturnValues{SQL_CREATE_COLLATION} =
  {
    SQL_CCOL_CREATE_COLLATION                 => 0x00000001
  };
  $ReturnValues{SQL_CREATE_DOMAIN} =
  {
    SQL_CDO_CREATE_DOMAIN                     => 0x00000001
  , SQL_CDO_DEFAULT                           => 0x00000002
  , SQL_CDO_CONSTRAINT                        => 0x00000004
  , SQL_CDO_COLLATION                         => 0x00000008
  , SQL_CDO_CONSTRAINT_NAME_DEFINITION        => 0x00000010
  , SQL_CDO_CONSTRAINT_INITIALLY_DEFERRED     => 0x00000020
  , SQL_CDO_CONSTRAINT_INITIALLY_IMMEDIATE    => 0x00000040
  , SQL_CDO_CONSTRAINT_DEFERRABLE             => 0x00000080
  , SQL_CDO_CONSTRAINT_NON_DEFERRABLE         => 0x00000100
  };
  $ReturnValues{SQL_CREATE_SCHEMA} =
  {
    SQL_CS_CREATE_SCHEMA                      => 0x00000001
  , SQL_CS_AUTHORIZATION                      => 0x00000002
  , SQL_CS_DEFAULT_CHARACTER_SET              => 0x00000004
  };
  $ReturnValues{SQL_CREATE_TABLE} =
  {
    SQL_CT_CREATE_TABLE                       => 0x00000001
  , SQL_CT_COMMIT_PRESERVE                    => 0x00000002
  , SQL_CT_COMMIT_DELETE                      => 0x00000004
  , SQL_CT_GLOBAL_TEMPORARY                   => 0x00000008
  , SQL_CT_LOCAL_TEMPORARY                    => 0x00000010
  , SQL_CT_CONSTRAINT_INITIALLY_DEFERRED      => 0x00000020
  , SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE     => 0x00000040
  , SQL_CT_CONSTRAINT_DEFERRABLE              => 0x00000080
  , SQL_CT_CONSTRAINT_NON_DEFERRABLE          => 0x00000100
  , SQL_CT_COLUMN_CONSTRAINT                  => 0x00000200
  , SQL_CT_COLUMN_DEFAULT                     => 0x00000400
  , SQL_CT_COLUMN_COLLATION                   => 0x00000800
  , SQL_CT_TABLE_CONSTRAINT                   => 0x00001000
  , SQL_CT_CONSTRAINT_NAME_DEFINITION         => 0x00002000
  };
  $ReturnValues{SQL_CREATE_TRANSLATION} =
  {
    SQL_CTR_CREATE_TRANSLATION                => 0x00000001
  };
  $ReturnValues{SQL_CREATE_VIEW} =
  {
    SQL_CV_CREATE_VIEW                        => 0x00000001
  , SQL_CV_CHECK_OPTION                       => 0x00000002
  , SQL_CV_CASCADED                           => 0x00000004
  , SQL_CV_LOCAL                              => 0x00000008
  };
  $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} =
  {
    SQL_CB_DELETE                             => 0
  , SQL_CB_CLOSE                              => 1
  , SQL_CB_PRESERVE                           => 2
  };
  $ReturnValues{SQL_CURSOR_ROLLBACK_BEHAVIOR} = $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR};
  
  $ReturnValues{SQL_CURSOR_SENSITIVITY} =
  {
    SQL_UNSPECIFIED                           => 0
  , SQL_INSENSITIVE                           => 1
  , SQL_SENSITIVE                             => 2
  };
  $ReturnValues{SQL_DATETIME_LITERALS} =
  {
    SQL_DL_SQL92_DATE                         => 0x00000001
  , SQL_DL_SQL92_TIME                         => 0x00000002
  , SQL_DL_SQL92_TIMESTAMP                    => 0x00000004
  , SQL_DL_SQL92_INTERVAL_YEAR                => 0x00000008
  , SQL_DL_SQL92_INTERVAL_MONTH               => 0x00000010
  , SQL_DL_SQL92_INTERVAL_DAY                 => 0x00000020
  , SQL_DL_SQL92_INTERVAL_HOUR                => 0x00000040
  , SQL_DL_SQL92_INTERVAL_MINUTE              => 0x00000080
  , SQL_DL_SQL92_INTERVAL_SECOND              => 0x00000100
  , SQL_DL_SQL92_INTERVAL_YEAR_TO_MONTH       => 0x00000200
  , SQL_DL_SQL92_INTERVAL_DAY_TO_HOUR         => 0x00000400
  , SQL_DL_SQL92_INTERVAL_DAY_TO_MINUTE       => 0x00000800
  , SQL_DL_SQL92_INTERVAL_DAY_TO_SECOND       => 0x00001000
  , SQL_DL_SQL92_INTERVAL_HOUR_TO_MINUTE      => 0x00002000
  , SQL_DL_SQL92_INTERVAL_HOUR_TO_SECOND      => 0x00004000
  , SQL_DL_SQL92_INTERVAL_MINUTE_TO_SECOND    => 0x00008000
  };
  $ReturnValues{SQL_DDL_INDEX} =
  {
    SQL_DI_CREATE_INDEX                       => 0x00000001
  , SQL_DI_DROP_INDEX                         => 0x00000002
  };
  $ReturnValues{SQL_DIAG_CURSOR_ROW_COUNT} =
  {
    SQL_CA2_CRC_EXACT                         => 0x00001000
  , SQL_CA2_CRC_APPROXIMATE                   => 0x00002000
  , SQL_CA2_SIMULATE_NON_UNIQUE               => 0x00004000
  , SQL_CA2_SIMULATE_TRY_UNIQUE               => 0x00008000
  , SQL_CA2_SIMULATE_UNIQUE                   => 0x00010000
  };
  $ReturnValues{SQL_DROP_ASSERTION} =
  {
    SQL_DA_DROP_ASSERTION                     => 0x00000001
  };
  $ReturnValues{SQL_DROP_CHARACTER_SET} =
  {
    SQL_DCS_DROP_CHARACTER_SET                => 0x00000001
  };
  $ReturnValues{SQL_DROP_COLLATION} =
  {
    SQL_DC_DROP_COLLATION                     => 0x00000001
  };
  $ReturnValues{SQL_DROP_DOMAIN} =
  {
    SQL_DD_DROP_DOMAIN                        => 0x00000001
  , SQL_DD_RESTRICT                           => 0x00000002
  , SQL_DD_CASCADE                            => 0x00000004
  };
  $ReturnValues{SQL_DROP_SCHEMA} =
  {
    SQL_DS_DROP_SCHEMA                        => 0x00000001
  , SQL_DS_RESTRICT                           => 0x00000002
  , SQL_DS_CASCADE                            => 0x00000004
  };
  $ReturnValues{SQL_DROP_TABLE} =
  {
    SQL_DT_DROP_TABLE                         => 0x00000001
  , SQL_DT_RESTRICT                           => 0x00000002
  , SQL_DT_CASCADE                            => 0x00000004
  };
  $ReturnValues{SQL_DROP_TRANSLATION} =
  {
    SQL_DTR_DROP_TRANSLATION                  => 0x00000001
  };
  $ReturnValues{SQL_DROP_VIEW} =
  {
    SQL_DV_DROP_VIEW                          => 0x00000001
  , SQL_DV_RESTRICT                           => 0x00000002
  , SQL_DV_CASCADE                            => 0x00000004
  };
  $ReturnValues{SQL_CURSOR_ATTRIBUTES1} =
  {
    SQL_CA1_NEXT                              => 0x00000001
  , SQL_CA1_ABSOLUTE                          => 0x00000002
  , SQL_CA1_RELATIVE                          => 0x00000004
  , SQL_CA1_BOOKMARK                          => 0x00000008
  , SQL_CA1_LOCK_NO_CHANGE                    => 0x00000040
  , SQL_CA1_LOCK_EXCLUSIVE                    => 0x00000080
  , SQL_CA1_LOCK_UNLOCK                       => 0x00000100
  , SQL_CA1_POS_POSITION                      => 0x00000200
  , SQL_CA1_POS_UPDATE                        => 0x00000400
  , SQL_CA1_POS_DELETE                        => 0x00000800
  , SQL_CA1_POS_REFRESH                       => 0x00001000
  , SQL_CA1_POSITIONED_UPDATE                 => 0x00002000
  , SQL_CA1_POSITIONED_DELETE                 => 0x00004000
  , SQL_CA1_SELECT_FOR_UPDATE                 => 0x00008000
  , SQL_CA1_BULK_ADD                          => 0x00010000
  , SQL_CA1_BULK_UPDATE_BY_BOOKMARK           => 0x00020000
  , SQL_CA1_BULK_DELETE_BY_BOOKMARK           => 0x00040000
  , SQL_CA1_BULK_FETCH_BY_BOOKMARK            => 0x00080000
  };
  $ReturnValues{     SQL_DYNAMIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
  $ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
  $ReturnValues{      SQL_KEYSET_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
  $ReturnValues{      SQL_STATIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1};
  
  $ReturnValues{SQL_CURSOR_ATTRIBUTES2} =
  {
    SQL_CA2_READ_ONLY_CONCURRENCY             => 0x00000001
  , SQL_CA2_LOCK_CONCURRENCY                  => 0x00000002
  , SQL_CA2_OPT_ROWVER_CONCURRENCY            => 0x00000004
  , SQL_CA2_OPT_VALUES_CONCURRENCY            => 0x00000008
  , SQL_CA2_SENSITIVITY_ADDITIONS             => 0x00000010
  , SQL_CA2_SENSITIVITY_DELETIONS             => 0x00000020
  , SQL_CA2_SENSITIVITY_UPDATES               => 0x00000040
  , SQL_CA2_MAX_ROWS_SELECT                   => 0x00000080
  , SQL_CA2_MAX_ROWS_INSERT                   => 0x00000100
  , SQL_CA2_MAX_ROWS_DELETE                   => 0x00000200
  , SQL_CA2_MAX_ROWS_UPDATE                   => 0x00000400
  , SQL_CA2_MAX_ROWS_CATALOG                  => 0x00000800
  , SQL_CA2_CRC_EXACT                         => 0x00001000
  , SQL_CA2_CRC_APPROXIMATE                   => 0x00002000
  , SQL_CA2_SIMULATE_NON_UNIQUE               => 0x00004000
  , SQL_CA2_SIMULATE_TRY_UNIQUE               => 0x00008000
  , SQL_CA2_SIMULATE_UNIQUE                   => 0x00010000
  };
  $ReturnValues{     SQL_DYNAMIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
  $ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
  $ReturnValues{      SQL_KEYSET_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
  $ReturnValues{      SQL_STATIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2};
  
  $ReturnValues{SQL_FETCH_DIRECTION} =
  {
    SQL_FD_FETCH_NEXT                         => 0x00000001
  , SQL_FD_FETCH_FIRST                        => 0x00000002
  , SQL_FD_FETCH_LAST                         => 0x00000004
  , SQL_FD_FETCH_PRIOR                        => 0x00000008
  , SQL_FD_FETCH_ABSOLUTE                     => 0x00000010
  , SQL_FD_FETCH_RELATIVE                     => 0x00000020
  , SQL_FD_FETCH_RESUME                       => 0x00000040
  , SQL_FD_FETCH_BOOKMARK                     => 0x00000080
  };
  $ReturnValues{SQL_FILE_USAGE} =
  {
    SQL_FILE_NOT_SUPPORTED                    => 0x0000
  , SQL_FILE_TABLE                            => 0x0001
  , SQL_FILE_QUALIFIER                        => 0x0002
  , SQL_FILE_CATALOG                          => 0x0002  # SQL_FILE_QUALIFIER
  };
  $ReturnValues{SQL_GETDATA_EXTENSIONS} =
  {
    SQL_GD_ANY_COLUMN                         => 0x00000001
  , SQL_GD_ANY_ORDER                          => 0x00000002
  , SQL_GD_BLOCK                              => 0x00000004
  , SQL_GD_BOUND                              => 0x00000008
  };
  $ReturnValues{SQL_GROUP_BY} =
  {
    SQL_GB_NOT_SUPPORTED                      => 0x0000
  , SQL_GB_GROUP_BY_EQUALS_SELECT             => 0x0001
  , SQL_GB_GROUP_BY_CONTAINS_SELECT           => 0x0002
  , SQL_GB_NO_RELATION                        => 0x0003
  , SQL_GB_COLLATE                            => 0x0004
  };
  $ReturnValues{SQL_IDENTIFIER_CASE} =
  {
    SQL_IC_UPPER                              => 1
  , SQL_IC_LOWER                              => 2
  , SQL_IC_SENSITIVE                          => 3
  , SQL_IC_MIXED                              => 4
  };
  $ReturnValues{SQL_INDEX_KEYWORDS} =
  {
    SQL_IK_NONE                               => 0x00000000
  , SQL_IK_ASC                                => 0x00000001
  , SQL_IK_DESC                               => 0x00000002
  # SQL_IK_ALL                                =>
  };
  $ReturnValues{SQL_INFO_SCHEMA_VIEWS} =
  {
    SQL_ISV_ASSERTIONS                        => 0x00000001
  , SQL_ISV_CHARACTER_SETS                    => 0x00000002
  , SQL_ISV_CHECK_CONSTRAINTS                 => 0x00000004
  , SQL_ISV_COLLATIONS                        => 0x00000008
  , SQL_ISV_COLUMN_DOMAIN_USAGE               => 0x00000010
  , SQL_ISV_COLUMN_PRIVILEGES                 => 0x00000020
  , SQL_ISV_COLUMNS                           => 0x00000040
  , SQL_ISV_CONSTRAINT_COLUMN_USAGE           => 0x00000080
  , SQL_ISV_CONSTRAINT_TABLE_USAGE            => 0x00000100
  , SQL_ISV_DOMAIN_CONSTRAINTS                => 0x00000200
  , SQL_ISV_DOMAINS                           => 0x00000400
  , SQL_ISV_KEY_COLUMN_USAGE                  => 0x00000800
  , SQL_ISV_REFERENTIAL_CONSTRAINTS           => 0x00001000
  , SQL_ISV_SCHEMATA                          => 0x00002000
  , SQL_ISV_SQL_LANGUAGES                     => 0x00004000
  , SQL_ISV_TABLE_CONSTRAINTS                 => 0x00008000
  , SQL_ISV_TABLE_PRIVILEGES                  => 0x00010000
  , SQL_ISV_TABLES                            => 0x00020000
  , SQL_ISV_TRANSLATIONS                      => 0x00040000
  , SQL_ISV_USAGE_PRIVILEGES                  => 0x00080000
  , SQL_ISV_VIEW_COLUMN_USAGE                 => 0x00100000
  , SQL_ISV_VIEW_TABLE_USAGE                  => 0x00200000
  , SQL_ISV_VIEWS                             => 0x00400000
  };
  $ReturnValues{SQL_INSERT_STATEMENT} =
  {
    SQL_IS_INSERT_LITERALS                    => 0x00000001
  , SQL_IS_INSERT_SEARCHED                    => 0x00000002
  , SQL_IS_SELECT_INTO                        => 0x00000004
  };
  $ReturnValues{SQL_LOCK_TYPES} =
  {
    SQL_LCK_NO_CHANGE                         => 0x00000001
  , SQL_LCK_EXCLUSIVE                         => 0x00000002
  , SQL_LCK_UNLOCK                            => 0x00000004
  };
  $ReturnValues{SQL_NON_NULLABLE_COLUMNS} =
  {
    SQL_NNC_NULL                              => 0x0000
  , SQL_NNC_NON_NULL                          => 0x0001
  };
  $ReturnValues{SQL_NULL_COLLATION} =
  {
    SQL_NC_HIGH                               => 0
  , SQL_NC_LOW                                => 1
  , SQL_NC_START                              => 0x0002
  , SQL_NC_END                                => 0x0004
  };
  $ReturnValues{SQL_NUMERIC_FUNCTIONS} =
  {
    SQL_FN_NUM_ABS                            => 0x00000001
  , SQL_FN_NUM_ACOS                           => 0x00000002
  , SQL_FN_NUM_ASIN                           => 0x00000004
  , SQL_FN_NUM_ATAN                           => 0x00000008
  , SQL_FN_NUM_ATAN2                          => 0x00000010
  , SQL_FN_NUM_CEILING                        => 0x00000020
  , SQL_FN_NUM_COS                            => 0x00000040
  , SQL_FN_NUM_COT                            => 0x00000080
  , SQL_FN_NUM_EXP                            => 0x00000100
  , SQL_FN_NUM_FLOOR                          => 0x00000200
  , SQL_FN_NUM_LOG                            => 0x00000400
  , SQL_FN_NUM_MOD                            => 0x00000800
  , SQL_FN_NUM_SIGN                           => 0x00001000
  , SQL_FN_NUM_SIN                            => 0x00002000
  , SQL_FN_NUM_SQRT                           => 0x00004000
  , SQL_FN_NUM_TAN                            => 0x00008000
  , SQL_FN_NUM_PI                             => 0x00010000
  , SQL_FN_NUM_RAND                           => 0x00020000
  , SQL_FN_NUM_DEGREES                        => 0x00040000
  , SQL_FN_NUM_LOG10                          => 0x00080000
  , SQL_FN_NUM_POWER                          => 0x00100000
  , SQL_FN_NUM_RADIANS                        => 0x00200000
  , SQL_FN_NUM_ROUND                          => 0x00400000
  , SQL_FN_NUM_TRUNCATE                       => 0x00800000
  };
  $ReturnValues{SQL_ODBC_API_CONFORMANCE} =
  {
    SQL_OAC_NONE                              => 0x0000
  , SQL_OAC_LEVEL1                            => 0x0001
  , SQL_OAC_LEVEL2                            => 0x0002
  };
  $ReturnValues{SQL_ODBC_INTERFACE_CONFORMANCE} =
  {
    SQL_OIC_CORE                              => 1
  , SQL_OIC_LEVEL1                            => 2
  , SQL_OIC_LEVEL2                            => 3
  };
  $ReturnValues{SQL_ODBC_SAG_CLI_CONFORMANCE} =
  {
    SQL_OSCC_NOT_COMPLIANT                    => 0x0000
  , SQL_OSCC_COMPLIANT                        => 0x0001
  };
  $ReturnValues{SQL_ODBC_SQL_CONFORMANCE} =
  {
    SQL_OSC_MINIMUM                           => 0x0000
  , SQL_OSC_CORE                              => 0x0001
  , SQL_OSC_EXTENDED                          => 0x0002
  };
  $ReturnValues{SQL_OJ_CAPABILITIES} =
  {
    SQL_OJ_LEFT                               => 0x00000001
  , SQL_OJ_RIGHT                              => 0x00000002
  , SQL_OJ_FULL                               => 0x00000004
  , SQL_OJ_NESTED                             => 0x00000008
  , SQL_OJ_NOT_ORDERED                        => 0x00000010
  , SQL_OJ_INNER                              => 0x00000020
  , SQL_OJ_ALL_COMPARISON_OPS                 => 0x00000040
  };
  $ReturnValues{SQL_OWNER_USAGE} =
  {
    SQL_OU_DML_STATEMENTS                     => 0x00000001
  , SQL_OU_PROCEDURE_INVOCATION               => 0x00000002
  , SQL_OU_TABLE_DEFINITION                   => 0x00000004
  , SQL_OU_INDEX_DEFINITION                   => 0x00000008
  , SQL_OU_PRIVILEGE_DEFINITION               => 0x00000010
  };
  $ReturnValues{SQL_PARAM_ARRAY_ROW_COUNTS} =
  {
    SQL_PARC_BATCH                            => 1
  , SQL_PARC_NO_BATCH                         => 2
  };
  $ReturnValues{SQL_PARAM_ARRAY_SELECTS} =
  {
    SQL_PAS_BATCH                             => 1
  , SQL_PAS_NO_BATCH                          => 2
  , SQL_PAS_NO_SELECT                         => 3
  };
  $ReturnValues{SQL_POSITIONED_STATEMENTS} =
  {
    SQL_PS_POSITIONED_DELETE                  => 0x00000001
  , SQL_PS_POSITIONED_UPDATE                  => 0x00000002
  , SQL_PS_SELECT_FOR_UPDATE                  => 0x00000004
  };
  $ReturnValues{SQL_POS_OPERATIONS} =
  {
    SQL_POS_POSITION                          => 0x00000001
  , SQL_POS_REFRESH                           => 0x00000002
  , SQL_POS_UPDATE                            => 0x00000004
  , SQL_POS_DELETE                            => 0x00000008
  , SQL_POS_ADD                               => 0x00000010
  };
  $ReturnValues{SQL_QUALIFIER_LOCATION} =
  {
    SQL_QL_START                              => 0x0001
  , SQL_QL_END                                => 0x0002
  };
  $ReturnValues{SQL_QUALIFIER_USAGE} =
  {
    SQL_QU_DML_STATEMENTS                     => 0x00000001
  , SQL_QU_PROCEDURE_INVOCATION               => 0x00000002
  , SQL_QU_TABLE_DEFINITION                   => 0x00000004
  , SQL_QU_INDEX_DEFINITION                   => 0x00000008
  , SQL_QU_PRIVILEGE_DEFINITION               => 0x00000010
  };
  $ReturnValues{SQL_QUOTED_IDENTIFIER_CASE}   = $ReturnValues{SQL_IDENTIFIER_CASE};
  
  $ReturnValues{SQL_SCHEMA_USAGE} =
  {
    SQL_SU_DML_STATEMENTS                     => 0x00000001  # SQL_OU_DML_STATEMENTS
  , SQL_SU_PROCEDURE_INVOCATION               => 0x00000002  # SQL_OU_PROCEDURE_INVOCATION
  , SQL_SU_TABLE_DEFINITION                   => 0x00000004  # SQL_OU_TABLE_DEFINITION
  , SQL_SU_INDEX_DEFINITION                   => 0x00000008  # SQL_OU_INDEX_DEFINITION
  , SQL_SU_PRIVILEGE_DEFINITION               => 0x00000010  # SQL_OU_PRIVILEGE_DEFINITION
  };
  $ReturnValues{SQL_SCROLL_CONCURRENCY} =
  {
    SQL_SCCO_READ_ONLY                        => 0x00000001
  , SQL_SCCO_LOCK                             => 0x00000002
  , SQL_SCCO_OPT_ROWVER                       => 0x00000004
  , SQL_SCCO_OPT_VALUES                       => 0x00000008
  };
  $ReturnValues{SQL_SCROLL_OPTIONS} =
  {
    SQL_SO_FORWARD_ONLY                       => 0x00000001
  , SQL_SO_KEYSET_DRIVEN                      => 0x00000002
  , SQL_SO_DYNAMIC                            => 0x00000004
  , SQL_SO_MIXED                              => 0x00000008
  , SQL_SO_STATIC                             => 0x00000010
  };
  $ReturnValues{SQL_SQL92_DATETIME_FUNCTIONS} =
  {
    SQL_SDF_CURRENT_DATE                      => 0x00000001
  , SQL_SDF_CURRENT_TIME                      => 0x00000002
  , SQL_SDF_CURRENT_TIMESTAMP                 => 0x00000004
  };
  $ReturnValues{SQL_SQL92_FOREIGN_KEY_DELETE_RULE} =
  {
    SQL_SFKD_CASCADE                          => 0x00000001
  , SQL_SFKD_NO_ACTION                        => 0x00000002
  , SQL_SFKD_SET_DEFAULT                      => 0x00000004
  , SQL_SFKD_SET_NULL                         => 0x00000008
  };
  $ReturnValues{SQL_SQL92_FOREIGN_KEY_UPDATE_RULE} =
  {
    SQL_SFKU_CASCADE                          => 0x00000001
  , SQL_SFKU_NO_ACTION                        => 0x00000002
  , SQL_SFKU_SET_DEFAULT                      => 0x00000004
  , SQL_SFKU_SET_NULL                         => 0x00000008
  };
  $ReturnValues{SQL_SQL92_GRANT} =
  {
    SQL_SG_USAGE_ON_DOMAIN                    => 0x00000001
  , SQL_SG_USAGE_ON_CHARACTER_SET             => 0x00000002
  , SQL_SG_USAGE_ON_COLLATION                 => 0x00000004
  , SQL_SG_USAGE_ON_TRANSLATION               => 0x00000008
  , SQL_SG_WITH_GRANT_OPTION                  => 0x00000010
  , SQL_SG_DELETE_TABLE                       => 0x00000020
  , SQL_SG_INSERT_TABLE                       => 0x00000040
  , SQL_SG_INSERT_COLUMN                      => 0x00000080
  , SQL_SG_REFERENCES_TABLE                   => 0x00000100
  , SQL_SG_REFERENCES_COLUMN                  => 0x00000200
  , SQL_SG_SELECT_TABLE                       => 0x00000400
  , SQL_SG_UPDATE_TABLE                       => 0x00000800
  , SQL_SG_UPDATE_COLUMN                      => 0x00001000
  };
  $ReturnValues{SQL_SQL92_NUMERIC_VALUE_FUNCTIONS} =
  {
    SQL_SNVF_BIT_LENGTH                       => 0x00000001
  , SQL_SNVF_CHAR_LENGTH                      => 0x00000002
  , SQL_SNVF_CHARACTER_LENGTH                 => 0x00000004
  , SQL_SNVF_EXTRACT                          => 0x00000008
  , SQL_SNVF_OCTET_LENGTH                     => 0x00000010
  , SQL_SNVF_POSITION                         => 0x00000020
  };
  $ReturnValues{SQL_SQL92_PREDICATES} =
  {
    SQL_SP_EXISTS                             => 0x00000001
  , SQL_SP_ISNOTNULL                          => 0x00000002
  , SQL_SP_ISNULL                             => 0x00000004
  , SQL_SP_MATCH_FULL                         => 0x00000008
  , SQL_SP_MATCH_PARTIAL                      => 0x00000010
  , SQL_SP_MATCH_UNIQUE_FULL                  => 0x00000020
  , SQL_SP_MATCH_UNIQUE_PARTIAL               => 0x00000040
  , SQL_SP_OVERLAPS                           => 0x00000080
  , SQL_SP_UNIQUE                             => 0x00000100
  , SQL_SP_LIKE                               => 0x00000200
  , SQL_SP_IN                                 => 0x00000400
  , SQL_SP_BETWEEN                            => 0x00000800
  , SQL_SP_COMPARISON                         => 0x00001000
  , SQL_SP_QUANTIFIED_COMPARISON              => 0x00002000
  };
  $ReturnValues{SQL_SQL92_RELATIONAL_JOIN_OPERATORS} =
  {
    SQL_SRJO_CORRESPONDING_CLAUSE             => 0x00000001
  , SQL_SRJO_CROSS_JOIN                       => 0x00000002
  , SQL_SRJO_EXCEPT_JOIN                      => 0x00000004
  , SQL_SRJO_FULL_OUTER_JOIN                  => 0x00000008
  , SQL_SRJO_INNER_JOIN                       => 0x00000010
  , SQL_SRJO_INTERSECT_JOIN                   => 0x00000020
  , SQL_SRJO_LEFT_OUTER_JOIN                  => 0x00000040
  , SQL_SRJO_NATURAL_JOIN                     => 0x00000080
  , SQL_SRJO_RIGHT_OUTER_JOIN                 => 0x00000100
  , SQL_SRJO_UNION_JOIN                       => 0x00000200
  };
  $ReturnValues{SQL_SQL92_REVOKE} =
  {
    SQL_SR_USAGE_ON_DOMAIN                    => 0x00000001
  , SQL_SR_USAGE_ON_CHARACTER_SET             => 0x00000002
  , SQL_SR_USAGE_ON_COLLATION                 => 0x00000004
  , SQL_SR_USAGE_ON_TRANSLATION               => 0x00000008
  , SQL_SR_GRANT_OPTION_FOR                   => 0x00000010
  , SQL_SR_CASCADE                            => 0x00000020
  , SQL_SR_RESTRICT                           => 0x00000040
  , SQL_SR_DELETE_TABLE                       => 0x00000080
  , SQL_SR_INSERT_TABLE                       => 0x00000100
  , SQL_SR_INSERT_COLUMN                      => 0x00000200
  , SQL_SR_REFERENCES_TABLE                   => 0x00000400
  , SQL_SR_REFERENCES_COLUMN                  => 0x00000800
  , SQL_SR_SELECT_TABLE                       => 0x00001000
  , SQL_SR_UPDATE_TABLE                       => 0x00002000
  , SQL_SR_UPDATE_COLUMN                      => 0x00004000
  };
  $ReturnValues{SQL_SQL92_ROW_VALUE_CONSTRUCTOR} =
  {
    SQL_SRVC_VALUE_EXPRESSION                 => 0x00000001
  , SQL_SRVC_NULL                             => 0x00000002
  , SQL_SRVC_DEFAULT                          => 0x00000004
  , SQL_SRVC_ROW_SUBQUERY                     => 0x00000008
  };
  $ReturnValues{SQL_SQL92_STRING_FUNCTIONS} =
  {
    SQL_SSF_CONVERT                           => 0x00000001
  , SQL_SSF_LOWER                             => 0x00000002
  , SQL_SSF_UPPER                             => 0x00000004
  , SQL_SSF_SUBSTRING                         => 0x00000008
  , SQL_SSF_TRANSLATE                         => 0x00000010
  , SQL_SSF_TRIM_BOTH                         => 0x00000020
  , SQL_SSF_TRIM_LEADING                      => 0x00000040
  , SQL_SSF_TRIM_TRAILING                     => 0x00000080
  };
  $ReturnValues{SQL_SQL92_VALUE_EXPRESSIONS} =
  {
    SQL_SVE_CASE                              => 0x00000001
  , SQL_SVE_CAST                              => 0x00000002
  , SQL_SVE_COALESCE                          => 0x00000004
  , SQL_SVE_NULLIF                            => 0x00000008
  };
  $ReturnValues{SQL_SQL_CONFORMANCE} =
  {
    SQL_SC_SQL92_ENTRY                        => 0x00000001
  , SQL_SC_FIPS127_2_TRANSITIONAL             => 0x00000002
  , SQL_SC_SQL92_INTERMEDIATE                 => 0x00000004
  , SQL_SC_SQL92_FULL                         => 0x00000008
  };
  $ReturnValues{SQL_STANDARD_CLI_CONFORMANCE} =
  {
    SQL_SCC_XOPEN_CLI_VERSION1                => 0x00000001
  , SQL_SCC_ISO92_CLI                         => 0x00000002
  };
  $ReturnValues{SQL_STATIC_SENSITIVITY} =
  {
    SQL_SS_ADDITIONS                          => 0x00000001
  , SQL_SS_DELETIONS                          => 0x00000002
  , SQL_SS_UPDATES                            => 0x00000004
  };
  $ReturnValues{SQL_STRING_FUNCTIONS} =
  {
    SQL_FN_STR_CONCAT                         => 0x00000001
  , SQL_FN_STR_INSERT                         => 0x00000002
  , SQL_FN_STR_LEFT                           => 0x00000004
  , SQL_FN_STR_LTRIM                          => 0x00000008
  , SQL_FN_STR_LENGTH                         => 0x00000010
  , SQL_FN_STR_LOCATE                         => 0x00000020
  , SQL_FN_STR_LCASE                          => 0x00000040
  , SQL_FN_STR_REPEAT                         => 0x00000080
  , SQL_FN_STR_REPLACE                        => 0x00000100
  , SQL_FN_STR_RIGHT                          => 0x00000200
  , SQL_FN_STR_RTRIM                          => 0x00000400
  , SQL_FN_STR_SUBSTRING                      => 0x00000800
  , SQL_FN_STR_UCASE                          => 0x00001000
  , SQL_FN_STR_ASCII                          => 0x00002000
  , SQL_FN_STR_CHAR                           => 0x00004000
  , SQL_FN_STR_DIFFERENCE                     => 0x00008000
  , SQL_FN_STR_LOCATE_2                       => 0x00010000
  , SQL_FN_STR_SOUNDEX                        => 0x00020000
  , SQL_FN_STR_SPACE                          => 0x00040000
  , SQL_FN_STR_BIT_LENGTH                     => 0x00080000
  , SQL_FN_STR_CHAR_LENGTH                    => 0x00100000
  , SQL_FN_STR_CHARACTER_LENGTH               => 0x00200000
  , SQL_FN_STR_OCTET_LENGTH                   => 0x00400000
  , SQL_FN_STR_POSITION                       => 0x00800000
  };
  $ReturnValues{SQL_SUBQUERIES} =
  {
    SQL_SQ_COMPARISON                         => 0x00000001
  , SQL_SQ_EXISTS                             => 0x00000002
  , SQL_SQ_IN                                 => 0x00000004
  , SQL_SQ_QUANTIFIED                         => 0x00000008
  , SQL_SQ_CORRELATED_SUBQUERIES              => 0x00000010
  };
  $ReturnValues{SQL_SYSTEM_FUNCTIONS} =
  {
    SQL_FN_SYS_USERNAME                       => 0x00000001
  , SQL_FN_SYS_DBNAME                         => 0x00000002
  , SQL_FN_SYS_IFNULL                         => 0x00000004
  };
  $ReturnValues{SQL_TIMEDATE_ADD_INTERVALS} =
  {
    SQL_FN_TSI_FRAC_SECOND                    => 0x00000001
  , SQL_FN_TSI_SECOND                         => 0x00000002
  , SQL_FN_TSI_MINUTE                         => 0x00000004
  , SQL_FN_TSI_HOUR                           => 0x00000008
  , SQL_FN_TSI_DAY                            => 0x00000010
  , SQL_FN_TSI_WEEK                           => 0x00000020
  , SQL_FN_TSI_MONTH                          => 0x00000040
  , SQL_FN_TSI_QUARTER                        => 0x00000080
  , SQL_FN_TSI_YEAR                           => 0x00000100
  };
  $ReturnValues{SQL_TIMEDATE_FUNCTIONS} =
  {
    SQL_FN_TD_NOW                             => 0x00000001
  , SQL_FN_TD_CURDATE                         => 0x00000002
  , SQL_FN_TD_DAYOFMONTH                      => 0x00000004
  , SQL_FN_TD_DAYOFWEEK                       => 0x00000008
  , SQL_FN_TD_DAYOFYEAR                       => 0x00000010
  , SQL_FN_TD_MONTH                           => 0x00000020
  , SQL_FN_TD_QUARTER                         => 0x00000040
  , SQL_FN_TD_WEEK                            => 0x00000080
  , SQL_FN_TD_YEAR                            => 0x00000100
  , SQL_FN_TD_CURTIME                         => 0x00000200
  , SQL_FN_TD_HOUR                            => 0x00000400
  , SQL_FN_TD_MINUTE                          => 0x00000800
  , SQL_FN_TD_SECOND                          => 0x00001000
  , SQL_FN_TD_TIMESTAMPADD                    => 0x00002000
  , SQL_FN_TD_TIMESTAMPDIFF                   => 0x00004000
  , SQL_FN_TD_DAYNAME                         => 0x00008000
  , SQL_FN_TD_MONTHNAME                       => 0x00010000
  , SQL_FN_TD_CURRENT_DATE                    => 0x00020000
  , SQL_FN_TD_CURRENT_TIME                    => 0x00040000
  , SQL_FN_TD_CURRENT_TIMESTAMP               => 0x00080000
  , SQL_FN_TD_EXTRACT                         => 0x00100000
  };
  $ReturnValues{SQL_TXN_CAPABLE} =
  {
    SQL_TC_NONE                               => 0
  , SQL_TC_DML                                => 1
  , SQL_TC_ALL                                => 2
  , SQL_TC_DDL_COMMIT                         => 3
  , SQL_TC_DDL_IGNORE                         => 4
  };
  $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION} =
  {
    SQL_TRANSACTION_READ_UNCOMMITTED          => 0x00000001  # SQL_TXN_READ_UNCOMMITTED
  , SQL_TRANSACTION_READ_COMMITTED            => 0x00000002  # SQL_TXN_READ_COMMITTED
  , SQL_TRANSACTION_REPEATABLE_READ           => 0x00000004  # SQL_TXN_REPEATABLE_READ
  , SQL_TRANSACTION_SERIALIZABLE              => 0x00000008  # SQL_TXN_SERIALIZABLE
  };
  $ReturnValues{SQL_DEFAULT_TRANSACTION_ISOLATION} = $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION};
  
  $ReturnValues{SQL_TXN_ISOLATION_OPTION} =
  {
    SQL_TXN_READ_UNCOMMITTED                  => 0x00000001
  , SQL_TXN_READ_COMMITTED                    => 0x00000002
  , SQL_TXN_REPEATABLE_READ                   => 0x00000004
  , SQL_TXN_SERIALIZABLE                      => 0x00000008
  };
  $ReturnValues{SQL_DEFAULT_TXN_ISOLATION} = $ReturnValues{SQL_TXN_ISOLATION_OPTION};
  
  $ReturnValues{SQL_TXN_VERSIONING} =
  {
    SQL_TXN_VERSIONING                        => 0x00000010
  };
  $ReturnValues{SQL_UNION} =
  {
    SQL_U_UNION                               => 0x00000001
  , SQL_U_UNION_ALL                           => 0x00000002
  };
  $ReturnValues{SQL_UNION_STATEMENT} =
  {
    SQL_US_UNION                              => 0x00000001  # SQL_U_UNION
  , SQL_US_UNION_ALL                          => 0x00000002  # SQL_U_UNION_ALL
  };
  
  1;
  
  =head1 TODO
  
    Corrections?
    SQL_NULL_COLLATION: ODBC vs ANSI
    Unique values for $ReturnValues{...}?, e.g. SQL_FILE_USAGE
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFO_ODBC

$fatpacked{"darwin-thread-multi-2level/DBI/Const/GetInfoReturn.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFORETURN';
  # $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z timbo $
  #
  # Copyright (c) 2002  Tim Bunce  Ireland
  #
  # Constant data describing return values from the DBI getinfo function.
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  package DBI::Const::GetInfoReturn;
  
  use strict;
  
  use Exporter ();
  
  use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoReturnTypes %GetInfoReturnValues);
  
  @ISA = qw(Exporter);
  @EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues);
  
  my
  $VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  
  
  =head1 NAME
  
  DBI::Const::GetInfoReturn - Data and functions for describing GetInfo results
  
  =head1 SYNOPSIS
  
  The interface to this module is undocumented and liable to change.
  
  =head1 DESCRIPTION
  
  Data and functions for describing GetInfo results
  
  =cut
  
  use DBI::Const::GetInfoType;
  
  use DBI::Const::GetInfo::ANSI ();
  use DBI::Const::GetInfo::ODBC ();
  
  %GetInfoReturnTypes =
  (
    %DBI::Const::GetInfo::ANSI::ReturnTypes
  , %DBI::Const::GetInfo::ODBC::ReturnTypes
  );
  
  %GetInfoReturnValues = ();
  {
    my $A = \%DBI::Const::GetInfo::ANSI::ReturnValues;
    my $O = \%DBI::Const::GetInfo::ODBC::ReturnValues;
    while ( my ($k, $v) = each %$A ) {
      my %h = ( exists $O->{$k} ) ? ( %$v, %{$O->{$k}} ) : %$v;
      $GetInfoReturnValues{$k} = \%h;
    }
    while ( my ($k, $v) = each %$O ) {
      next if exists $A->{$k};
      my %h = %$v;
      $GetInfoReturnValues{$k} = \%h;
    }
  }
  
  # -----------------------------------------------------------------------------
  
  sub Format {
    my $InfoType = shift;
    my $Value    = shift;
  
    return '' unless defined $Value;
  
    my $ReturnType = $GetInfoReturnTypes{$InfoType};
  
    return sprintf '0x%08X', $Value if $ReturnType eq 'SQLUINTEGER bitmask';
    return sprintf '0x%08X', $Value if $ReturnType eq 'SQLINTEGER bitmask';
  # return '"' . $Value . '"'       if $ReturnType eq 'SQLCHAR';
    return $Value;
  }
  
  
  sub Explain {
    my $InfoType = shift;
    my $Value    = shift;
  
    return '' unless defined $Value;
    return '' unless exists $GetInfoReturnValues{$InfoType};
  
    $Value = int $Value;
    my $ReturnType = $GetInfoReturnTypes{$InfoType};
    my %h = reverse %{$GetInfoReturnValues{$InfoType}};
  
    if ( $ReturnType eq 'SQLUINTEGER bitmask'|| $ReturnType eq 'SQLINTEGER bitmask') {
      my @a = ();
      for my $k ( sort { $a <=> $b } keys %h ) {
        push @a, $h{$k} if $Value & $k;
      }
      return wantarray ? @a : join(' ', @a );
    }
    else {
      return $h{$Value} ||'?';
    }
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFORETURN

$fatpacked{"darwin-thread-multi-2level/DBI/Const/GetInfoType.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFOTYPE';
  # $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z timbo $
  #
  # Copyright (c) 2002  Tim Bunce  Ireland
  #
  # Constant data describing info type codes for the DBI getinfo function.
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  package DBI::Const::GetInfoType;
  
  use strict;
  
  use Exporter ();
  
  use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoType);
  
  @ISA = qw(Exporter);
  @EXPORT = qw(%GetInfoType);
  
  my
  $VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  
  
  =head1 NAME
  
  DBI::Const::GetInfoType - Data describing GetInfo type codes
  
  =head1 SYNOPSIS
  
    use DBI::Const::GetInfoType;
  
  =head1 DESCRIPTION
  
  Imports a %GetInfoType hash which maps names for GetInfo Type Codes
  into their corresponding numeric values. For example:
  
    $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
  
  The interface to this module is new and nothing beyond what is
  written here is guaranteed.
  
  =cut
  
  use DBI::Const::GetInfo::ANSI ();	# liable to change
  use DBI::Const::GetInfo::ODBC ();	# liable to change
  
  %GetInfoType =
  (
    %DBI::Const::GetInfo::ANSI::InfoTypes	# liable to change
  , %DBI::Const::GetInfo::ODBC::InfoTypes	# liable to change
  );
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_CONST_GETINFOTYPE

$fatpacked{"darwin-thread-multi-2level/DBI/DBD.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_DBD';
  package DBI::DBD;
  # vim:ts=8:sw=4
  
  use vars qw($VERSION);	# set $VERSION early so we don't confuse PAUSE/CPAN etc
  
  # don't use Revision here because that's not in svn:keywords so that the
  # examples that use it below won't be messed up
  $VERSION = sprintf("12.%06d", q$Id: DBD.pm 13612 2009-11-27 11:34:26Z mjevans $ =~ /(\d+)/o);
  
  
  # $Id: DBD.pm 13612 2009-11-27 11:34:26Z mjevans $
  #
  # Copyright (c) 1997-2006 Jonathan Leffler, Jochen Wiedmann, Steffen
  # Goeldner and Tim Bunce
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  =head1 NAME
  
  DBI::DBD - Perl DBI Database Driver Writer's Guide
  
  =head1 SYNOPSIS
  
    perldoc DBI::DBD
  
  =head2 Version and volatility
  
  This document is I<still> a minimal draft which is in need of further work.
  
  The changes will occur both because the B<DBI> specification is changing
  and hence the requirements on B<DBD> drivers change, and because feedback
  from people reading this document will suggest improvements to it.
  
  Please read the B<DBI> documentation first and fully, including the B<DBI> FAQ.
  Then reread the B<DBI> specification again as you're reading this. It'll help.
  
  This document is a patchwork of contributions from various authors.
  More contributions (preferably as patches) are very welcome.
  
  =head1 DESCRIPTION
  
  This document is primarily intended to help people writing new
  database drivers for the Perl Database Interface (Perl DBI).
  It may also help others interested in discovering why the internals of
  a B<DBD> driver are written the way they are.
  
  This is a guide.  Few (if any) of the statements in it are completely
  authoritative under all possible circumstances.  This means you will
  need to use judgement in applying the guidelines in this document.
  If in I<any> doubt at all, please do contact the I<dbi-dev> mailing list
  (details given below) where Tim Bunce and other driver authors can help.
  
  =head1 CREATING A NEW DRIVER
  
  The first rule for creating a new database driver for the Perl DBI is
  very simple: B<DON'T!>
  
  There is usually a driver already available for the database you want
  to use, almost regardless of which database you choose. Very often, the
  database will provide an ODBC driver interface, so you can often use
  B<DBD::ODBC> to access the database. This is typically less convenient
  on a Unix box than on a Microsoft Windows box, but there are numerous
  options for ODBC driver managers on Unix too, and very often the ODBC
  driver is provided by the database supplier.
  
  Before deciding that you need to write a driver, do your homework to
  ensure that you are not wasting your energies.
  
  [As of December 2002, the consensus is that if you need an ODBC driver
  manager on Unix, then the unixODBC driver (available from
  L<http://www.unixodbc.org/>) is the way to go.]
  
  The second rule for creating a new database driver for the Perl DBI is
  also very simple: B<Don't -- get someone else to do it for you!>
  
  Nevertheless, there are occasions when it is necessary to write a new
  driver, often to use a proprietary language or API to access the
  database more swiftly, or more comprehensively, than an ODBC driver can.
  Then you should read this document very carefully, but with a suitably
  sceptical eye.
  
  If there is something in here that does not make any sense, question it.
  You might be right that the information is bogus, but don't come to that
  conclusion too quickly.
  
  =head2 URLs and mailing lists
  
  The primary web-site for locating B<DBI> software and information is
  
    http://dbi.perl.org/
  
  There are two main and one auxiliary mailing lists for people working
  with B<DBI>.  The primary lists are I<dbi-users@perl.org> for general users
  of B<DBI> and B<DBD> drivers, and I<dbi-dev@perl.org> mainly for B<DBD> driver
  writers (don't join the I<dbi-dev> list unless you have a good reason).
  The auxiliary list is I<dbi-announce@perl.org> for announcing new
  releases of B<DBI> or B<DBD> drivers.
  
  You can join these lists by accessing the web-site L<http://dbi.perl.org/>.
  The lists are closed so you cannot send email to any of the lists
  unless you join the list first.
  
  You should also consider monitoring the I<comp.lang.perl.*> newsgroups,
  especially I<comp.lang.perl.modules>.
  
  =head2 The Cheetah book
  
  The definitive book on Perl DBI is the Cheetah book, so called because
  of the picture on the cover. Its proper title is 'I<Programming the
  Perl DBI: Database programming with Perl>' by Alligator Descartes
  and Tim Bunce, published by O'Reilly Associates, February 2000, ISBN
  1-56592-699-4. Buy it now if you have not already done so, and read it.
  
  =head2 Locating drivers
  
  Before writing a new driver, it is in your interests to find out
  whether there already is a driver for your database.  If there is such
  a driver, it would be much easier to make use of it than to write your
  own!
  
  The primary web-site for locating Perl software is
  L<http://search.cpan.org/>.  You should look under the various
  modules listings for the software you are after. For example:
  
    http://search.cpan.org/modlist/Database_Interfaces
  
  Follow the B<DBD::> and B<DBIx::> links at the top to see those subsets.
  
  See the B<DBI> docs for information on B<DBI> web sites and mailing lists.
  
  =head2 Registering a new driver
  
  Before going through any official registration process, you will need
  to establish that there is no driver already in the works. You'll do
  that by asking the B<DBI> mailing lists whether there is such a driver
  available, or whether anybody is working on one.
  
  When you get the go ahead, you will need to establish the name of the
  driver and a prefix for the driver. Typically, the name is based on the
  name of the database software it uses, and the prefix is a contraction
  of that. Hence, B<DBD::Oracle> has the name I<Oracle> and the prefix
  'I<ora_>'. The prefix must be lowercase and contain no underscores other
  than the one at the end.
  
  This information will be recorded in the B<DBI> module. Apart from
  documentation purposes, registration is a prerequisite for
  L<installing private methods|DBI/install_method>.
  
  If you are writing a driver which will not be distributed on CPAN, then
  you should choose a prefix beginning with 'I<x_>', to avoid potential
  prefix collisions with drivers registered in the future. Thus, if you
  wrote a non-CPAN distributed driver called B<DBD::CustomDB>, the prefix
  might be 'I<x_cdb_>'.
  
  This document assumes you are writing a driver called B<DBD::Driver>, and
  that the prefix 'I<drv_>' is assigned to the driver.
  
  =head2 Two styles of database driver
  
  There are two distinct styles of database driver that can be written to
  work with the Perl DBI.
  
  Your driver can be written in pure Perl, requiring no C compiler.
  When feasible, this is the best solution, but most databases are not
  written in such a way that this can be done. Some examples of pure
  Perl drivers are B<DBD::File> and B<DBD::CSV>.
  
  Alternatively, and most commonly, your driver will need to use some C
  code to gain access to the database. This will be classified as a C/XS
  driver.
  
  =head2 What code will you write?
  
  There are a number of files that need to be written for either a pure
  Perl driver or a C/XS driver. There are no extra files needed only by
  a pure Perl driver, but there are several extra files needed only by a
  C/XS driver.
  
  =head3 Files common to pure Perl and C/XS drivers
  
  Assuming that your driver is called B<DBD::Driver>, these files are:
  
  =over 4
  
  =item * F<Makefile.PL>
  
  =item * F<META.yml>
  
  =item * F<README>
  
  =item * F<MANIFEST>
  
  =item * F<Driver.pm>
  
  =item * F<lib/Bundle/DBD/Driver.pm>
  
  =item * F<lib/DBD/Driver/Summary.pm>
  
  =item * F<t/*.t>
  
  =back
  
  The first four files are mandatory. F<Makefile.PL> is used to control
  how the driver is built and installed. The F<README> file tells people
  who download the file about how to build the module and any prerequisite
  software that must be installed. The F<MANIFEST> file is used by the
  standard Perl module distribution mechanism. It lists all the source
  files that need to be distributed with your module. F<Driver.pm> is what
  is loaded by the B<DBI> code; it contains the methods peculiar to your
  driver.
  
  Although the F<META.yml> file is not B<required> you are advised to
  create one. Of particular importance are the I<build_requires> and
  I<configure_requires> attributes which newer CPAN modules understand.
  You use these to tell the CPAN module (and CPANPLUS) that your build
  and configure mechanisms require DBI. The best reference for META.yml
  (at the time of writing) is
  L<http://module-build.sourceforge.net/META-spec-v1.4.html>. You can find
  a reasonable example of a F<META.yml> in DBD::ODBC.
  
  The F<lib/Bundle/DBD/Driver.pm> file allows you to specify other Perl
  modules on which yours depends in a format that allows someone to type a
  simple command and ensure that all the pre-requisites are in place as
  well as building your driver.
  
  The F<lib/DBD/Driver/Summary.pm> file contains (an updated version of) the
  information that was included - or that would have been included - in
  the appendices of the Cheetah book as a summary of the abilities of your
  driver and the associated database.
  
  The files in the F<t> subdirectory are unit tests for your driver.
  You should write your tests as stringently as possible, while taking
  into account the diversity of installations that you can encounter:
  
  =over 4
  
  =item *
  
  Your tests should not casually modify operational databases.
  
  =item *
  
  You should never damage existing tables in a database.
  
  =item *
  
  You should code your tests to use a constrained name space within the
  database. For example, the tables (and all other named objects) that are
  created could all begin with 'I<dbd_drv_>'.
  
  =item *
  
  At the end of a test run, there should be no testing objects left behind
  in the database.
  
  =item *
  
  If you create any databases, you should remove them.
  
  =item *
  
  If your database supports temporary tables that are automatically
  removed at the end of a session, then exploit them as often as possible.
  
  =item *
  
  Try to make your tests independent of each other. If you have a
  test F<t/t11dowhat.t> that depends upon the successful running
  of F<t/t10thingamy.t>, people cannot run the single test case
  F<t/t11dowhat.t>. Further, running F<t/t11dowhat.t> twice in a row is
  likely to fail (at least, if F<t/t11dowhat.t> modifies the database at
  all) because the database at the start of the second run is not what you
  saw at the start of the first run.
  
  =item *
  
  Document in your F<README> file what you do, and what privileges people
  need to do it.
  
  =item *
  
  You can, and probably should, sequence your tests by including a test
  number before an abbreviated version of the test name; the tests are run
  in the order in which the names are expanded by shell-style globbing.
  
  =item *
  
  It is in your interests to ensure that your tests work as widely
  as possible.
  
  =back
  
  Many drivers also install sub-modules B<DBD::Driver::SubModule>
  for any of a variety of different reasons, such as to support
  the metadata methods (see the discussion of L</METADATA METHODS>
  below). Such sub-modules are conventionally stored in the directory
  F<lib/DBD/Driver>. The module itself would usually be in a file
  F<SubModule.pm>. All such sub-modules should themselves be version
  stamped (see the discussions far below).
  
  =head3 Extra files needed by C/XS drivers
  
  The software for a C/XS driver will typically contain at least four
  extra files that are not relevant to a pure Perl driver.
  
  =over 4
  
  =item * F<Driver.xs>
  
  =item * F<Driver.h>
  
  =item * F<dbdimp.h>
  
  =item * F<dbdimp.c>
  
  =back
  
  The F<Driver.xs> file is used to generate C code that Perl can call to gain
  access to the C functions you write that will, in turn, call down onto
  your database software.
  
  The F<Driver.h> header is a stylized header that ensures you can access the
  necessary Perl and B<DBI> macros, types, and function declarations.
  
  The F<dbdimp.h> is used to specify which functions have been implemented by
  your driver.
  
  The F<dbdimp.c> file is where you write the C code that does the real work
  of translating between Perl-ish data types and what the database expects
  to use and return.
  
  There are some (mainly small, but very important) differences between
  the contents of F<Makefile.PL> and F<Driver.pm> for pure Perl and C/XS
  drivers, so those files are described both in the section on creating a
  pure Perl driver and in the section on creating a C/XS driver.
  
  Obviously, you can add extra source code files to the list.
  
  =head2 Requirements on a driver and driver writer
  
  To be remotely useful, your driver must be implemented in a format that
  allows it to be distributed via CPAN, the Comprehensive Perl Archive
  Network (L<http://www.cpan.org/> and L<http://search.cpan.org>).
  Of course, it is easier if you do not have to meet this criterion, but
  you will not be able to ask for much help if you do not do so, and
  no-one is likely to want to install your module if they have to learn a
  new installation mechanism.
  
  =head1 CREATING A PURE PERL DRIVER
  
  Writing a pure Perl driver is surprisingly simple. However, there are
  some problems you should be aware of. The best option is of course
  picking up an existing driver and carefully modifying one method
  after the other.
  
  Also look carefully at B<DBD::AnyData> and B<DBD::Template>.
  
  As an example we take a look at the B<DBD::File> driver, a driver for
  accessing plain files as tables, which is part of the B<DBD::CSV> package.
  
  The minimal set of files we have to implement are F<Makefile.PL>,
  F<README>, F<MANIFEST> and F<Driver.pm>.
  
  =head2 Pure Perl version of Makefile.PL
  
  You typically start with writing F<Makefile.PL>, a Makefile
  generator. The contents of this file are described in detail in
  the L<ExtUtils::MakeMaker> man pages. It is definitely a good idea
  if you start reading them. At least you should know about the
  variables I<CONFIGURE>, I<DEFINED>, I<PM>, I<DIR>, I<EXE_FILES>,
  I<INC>, I<LIBS>, I<LINKTYPE>, I<NAME>, I<OPTIMIZE>, I<PL_FILES>,
  I<VERSION>, I<VERSION_FROM>, I<clean>, I<depend>, I<realclean> from
  the L<ExtUtils::MakeMaker> man page: these are used in almost any
  F<Makefile.PL>.
  
  Additionally read the section on I<Overriding MakeMaker Methods> and the
  descriptions of the I<distcheck>, I<disttest> and I<dist> targets: They
  will definitely be useful for you.
  
  Of special importance for B<DBI> drivers is the I<postamble> method from
  the L<ExtUtils::MM_Unix> man page.
  
  For Emacs users, I recommend the I<libscan> method, which removes
  Emacs backup files (file names which end with a tilde '~') from lists of
  files.
  
  Now an example, I use the word C<Driver> wherever you should insert
  your driver's name:
  
    # -*- perl -*-
  
    use ExtUtils::MakeMaker;
  
    WriteMakefile(
        dbd_edit_mm_attribs( {
            'NAME'         => 'DBD::Driver',
            'VERSION_FROM' => 'Driver.pm',
            'INC'          => '',
            'dist'         => { 'SUFFIX'   => '.gz',
                                'COMPRESS' => 'gzip -9f' },
            'realclean'    => { FILES => '*.xsi' },
            'PREREQ_PM'    => '1.03',
            'CONFIGURE'    => sub {
                eval {require DBI::DBD;};
                if ($@) {
                    warn $@;
                    exit 0;
                }
                my $dbi_arch_dir = dbd_dbi_arch_dir();
                if (exists($opts{INC})) {
                    return {INC => "$opts{INC} -I$dbi_arch_dir"};
                } else {
                    return {INC => "-I$dbi_arch_dir"};
                }
            }
        },
        { create_pp_tests => 1})
    );
  
    package MY;
    sub postamble { return main::dbd_postamble(@_); }
    sub libscan {
        my ($self, $path) = @_;
        ($path =~ m/\~$/) ? undef : $path;
    }
  
  Note the calls to C<dbd_edit_mm_attribs()> and C<dbd_postamble()>.
  
  The second hash reference in the call to C<dbd_edit_mm_attribs()>
  (containing C<create_pp_tests()>) is optional; you should not use it
  unless your driver is a pure Perl driver (that is, it does not use C and
  XS code). Therefore, the call to C<dbd_edit_mm_attribs()> is not
  relevant for C/XS drivers and may be omitted; simply use the (single)
  hash reference containing NAME etc as the only argument to C<WriteMakefile()>.
  
  Note that the C<dbd_edit_mm_attribs()> code will fail if you do not have a
  F<t> sub-directory containing at least one test case.
  
  I<PREREQ_PM> tells MakeMaker that DBI (version 1.03 in this case) is
  required for this module. This will issue a warning that DBI 1.03 is
  missing if someone attempts to install your DBD without DBI 1.03. See
  I<CONFIGURE> below for why this does not work reliably in stopping cpan
  testers failing your module if DBI is not installed.
  
  I<CONFIGURE> is a subroutine called by MakeMaker during
  C<WriteMakefile>.  By putting the C<require DBI::DBD> in this section
  we can attempt to load DBI::DBD but if it is missing we exit with
  success. As we exit successfully without creating a Makefile when
  DBI::DBD is missing cpan testers will not report a failure. This may
  seem at odds with I<PREREQ_PM> but I<PREREQ_PM> does not cause
  C<WriteMakefile> to fail (unless you also specify PREREQ_FATAL which
  is strongly discouraged by MakeMaker) so C<WriteMakefile> would
  continue to call C<dbd_dbi_arch_dir> and fail.
  
  All drivers must use C<dbd_postamble()> or risk running into problems.
  
  Note the specification of I<VERSION_FROM>; the named file
  (F<Driver.pm>) will be scanned for the first line that looks like an
  assignment to I<$VERSION>, and the subsequent text will be used to
  determine the version number.  Note the commentary in
  L<ExtUtils::MakeMaker> on the subject of correctly formatted version
  numbers.
  
  If your driver depends upon external software (it usually will), you
  will need to add code to ensure that your environment is workable
  before the call to C<WriteMakefile()>. If you need to check for the
  existence of an external library and perhaps modify I<INC> to include
  the paths to where the external library header files are located and
  you cannot find the library or header files make sure you output a
  message saying they cannot be found but C<exit 0> (success) B<before>
  calling C<WriteMakefile> or CPAN testers will fail your module if the
  external library is not found.
  
  A full-fledged I<Makefile.PL> can be quite large (for example, the
  files for B<DBD::Oracle> and B<DBD::Informix> are both over 1000 lines
  long, and the Informix one uses - and creates - auxiliary modules
  too).
  
  See also L<ExtUtils::MakeMaker> and L<ExtUtils::MM_Unix>. Consider using
  L<CPAN::MakeMaker> in place of I<ExtUtils::MakeMaker>.
  
  =head2 README
  
  The L<README> file should describe what the driver is for, the
  pre-requisites for the build process, the actual build process, how to
  report errors, and who to report them to.
  
  Users will find ways of breaking the driver build and test process
  which you would never even have dreamed to be possible in your worst
  nightmares. Therefore, you need to write this document defensively,
  precisely and concisely.
  
  As always, use the F<README> from one of the established drivers as a basis
  for your own; the version in B<DBD::Informix> is worth a look as it has
  been quite successful in heading off problems.
  
  =over 4
  
  =item *
  
  Note that users will have versions of Perl and B<DBI> that are both older
  and newer than you expected, but this will seldom cause much trouble.
  When it does, it will be because you are using features of B<DBI> that are
  not supported in the version they are using.
  
  =item *
  
  Note that users will have versions of the database software that are
  both older and newer than you expected. You will save yourself time in
  the long run if you can identify the range of versions which have been
  tested and warn about versions which are not known to be OK.
  
  =item *
  
  Note that many people trying to install your driver will not be experts
  in the database software.
  
  =item *
  
  Note that many people trying to install your driver will not be experts
  in C or Perl.
  
  =back
  
  =head2 MANIFEST
  
  The F<MANIFEST> will be used by the Makefile's dist target to build the
  distribution tar file that is uploaded to CPAN. It should list every
  file that you want to include in your distribution, one per line.
  
  =head2 lib/Bundle/DBD/Driver.pm
  
  The CPAN module provides an extremely powerful bundle mechanism that
  allows you to specify pre-requisites for your driver.
  
  The primary pre-requisite is B<Bundle::DBI>; you may want or need to add
  some more. With the bundle set up correctly, the user can type:
  
          perl -MCPAN -e 'install Bundle::DBD::Driver'
  
  and Perl will download, compile, test and install all the Perl modules
  needed to build your driver.
  
  The prerequisite modules are listed in the C<CONTENTS> section, with the
  official name of the module followed by a dash and an informal name or
  description.
  
  =over 4
  
  =item *
  
  Listing B<Bundle::DBI> as the main pre-requisite simplifies life.
  
  =item *
  
  Don't forget to list your driver.
  
  =item *
  
  Note that unless the DBMS is itself a Perl module, you cannot list it as
  a pre-requisite in this file.
  
  =item *
  
  You should keep the version of the bundle the same as the version of
  your driver.
  
  =item *
  
  You should add configuration management, copyright, and licencing
  information at the top.
  
  =back
  
  A suitable skeleton for this file is shown below.
  
    package Bundle::DBD::Driver;
  
    $VERSION = '0.01';
  
    1;
  
    __END__
  
    =head1 NAME
  
    Bundle::DBD::Driver - A bundle to install all DBD::Driver related modules
  
    =head1 SYNOPSIS
  
    C<perl -MCPAN -e 'install Bundle::DBD::Driver'>
  
    =head1 CONTENTS
  
    Bundle::DBI  - Bundle for DBI by TIMB (Tim Bunce)
  
    DBD::Driver  - DBD::Driver by YOU (Your Name)
  
    =head1 DESCRIPTION
  
    This bundle includes all the modules used by the Perl Database
    Interface (DBI) driver for Driver (DBD::Driver), assuming the
    use of DBI version 1.13 or later, created by Tim Bunce.
  
    If you've not previously used the CPAN module to install any
    bundles, you will be interrogated during its setup phase.
    But when you've done it once, it remembers what you told it.
    You could start by running:
  
      C<perl -MCPAN -e 'install Bundle::CPAN'>
  
    =head1 SEE ALSO
  
    Bundle::DBI
  
    =head1 AUTHOR
  
    Your Name E<lt>F<you@yourdomain.com>E<gt>
  
    =head1 THANKS
  
    This bundle was created by ripping off Bundle::libnet created by
    Graham Barr E<lt>F<gbarr@ti.com>E<gt>, and radically simplified
    with some information from Jochen Wiedmann E<lt>F<joe@ispsoft.de>E<gt>.
    The template was then included in the DBI::DBD documentation by
    Jonathan Leffler E<lt>F<jleffler@informix.com>E<gt>.
  
    =cut
  
  =head2 lib/DBD/Driver/Summary.pm
  
  There is no substitute for taking the summary file from a driver that
  was documented in the Perl book (such as B<DBD::Oracle> or B<DBD::Informix> or
  B<DBD::ODBC>, to name but three), and adapting it to describe the
  facilities available via B<DBD::Driver> when accessing the Driver database.
  
  =head2 Pure Perl version of Driver.pm
  
  The F<Driver.pm> file defines the Perl module B<DBD::Driver> for your driver.
  It will define a package B<DBD::Driver> along with some version information,
  some variable definitions, and a function C<driver()> which will have a more
  or less standard structure.
  
  It will also define three sub-packages of B<DBD::Driver>:
  
  =over 4
  
  =item DBD::Driver::dr
  
  with methods C<connect()>, C<data_sources()> and C<disconnect_all()>;
  
  =item DBD::Driver::db
  
  with methods such as C<prepare()>;
  
  =item DBD::Driver::st
  
  with methods such as C<execute()> and C<fetch()>.
  
  =back
  
  The F<Driver.pm> file will also contain the documentation specific to
  B<DBD::Driver> in the format used by perldoc.
  
  In a pure Perl driver, the F<Driver.pm> file is the core of the
  implementation. You will need to provide all the key methods needed by B<DBI>.
  
  Now let's take a closer look at an excerpt of F<File.pm> as an example.
  We ignore things that are common to any module (even non-DBI modules)
  or really specific to the B<DBD::File> package.
  
  =head3 The DBD::Driver package
  
  =head4 The header
  
    package DBD::File;
  
    use strict;
    use vars qw($VERSION $drh);
  
    $VERSION = "1.23.00"  # Version number of DBD::File
  
  This is where the version number of your driver is specified, and is
  where F<Makefile.PL> looks for this information. Please ensure that any
  other modules added with your driver are also version stamped so that
  CPAN does not get confused.
  
  It is recommended that you use a two-part (1.23) or three-part (1.23.45)
  version number. Also consider the CPAN system, which gets confused and
  considers version 1.10 to precede version 1.9, so that using a raw CVS,
  RCS or SCCS version number is probably not appropriate (despite being
  very common).
  
  For Subversion you could use:
  
    $VERSION = sprintf("12.%06d", q$Revision: 12345 $ =~ /(\d+)/o);
  
  (use lots of leading zeros on the second portion so if you move the code to a
  shared repository like svn.perl.org the much larger revision numbers won't
  cause a problem, at least not for a few years).  For RCS or CVS you can use:
  
    $VERSION = sprintf "%d.%02d", '$Revision: 11.21 $ ' =~ /(\d+)\.(\d+)/;
  
  which pads out the fractional part with leading zeros so all is well
  (so long as you don't go past x.99)
  
    $drh = undef;         # holds driver handle once initialized
  
  This is where the driver handle will be stored, once created.
  Note that you may assume there is only one handle for your driver.
  
  =head4 The driver constructor
  
  The C<driver()> method is the driver handle constructor. Note that
  the C<driver()> method is in the B<DBD::Driver> package, not in
  one of the sub-packages B<DBD::Driver::dr>, B<DBD::Driver::db>, or
  B<DBD::Driver::db>.
  
    sub driver
    {
        return $drh if $drh;      # already created - return same one
        my ($class, $attr) = @_;
  
        $class .= "::dr";
  
        DBD::Driver::db->install_method('drv_example_dbh_method');
        DBD::Driver::st->install_method('drv_example_sth_method');
  
        # not a 'my' since we use it above to prevent multiple drivers
        $drh = DBI::_new_drh($class, {
                'Name'        => 'File',
                'Version'     => $VERSION,
                'Attribution' => 'DBD::File by Jochen Wiedmann',
            })
            or return undef;
  
        return $drh;
    }
  
  This is a reasonable example of how B<DBI> implements its handles. There
  are three kinds: B<driver handles> (typically stored in I<$drh>; from
  now on called I<drh> or I<$drh>), B<database handles> (from now on
  called I<dbh> or I<$dbh>) and B<statement handles> (from now on called
  I<sth> or I<$sth>).
  
  The prototype of C<DBI::_new_drh()> is
  
    $drh = DBI::_new_drh($class, $public_attrs, $private_attrs);
  
  with the following arguments:
  
  =over 4
  
  =item I<$class>
  
  is typically the class for your driver, (for example, "DBD::File::dr"),
  passed as the first argument to the C<driver()> method.
  
  =item I<$public_attrs>
  
  is a hash ref to attributes like I<Name>, I<Version>, and I<Attribution>.
  These are processed and used by B<DBI>. You had better not make any
  assumptions about them nor should you add private attributes here.
  
  =item I<$private_attrs>
  
  This is another (optional) hash ref with your private attributes.
  B<DBI> will store them and otherwise leave them alone.
  
  =back
  
  The C<DBI::_new_drh()> method and the C<driver()> method both return C<undef>
  for failure (in which case you must look at I<$DBI::err> and I<$DBI::errstr>
  for the failure information, because you have no driver handle to use).
  
  
  =head4 Using install_method() to expose driver-private methods
  
      DBD::Foo::db->install_method($method_name, \%attr);
  
  Installs the driver-private method named by $method_name into the
  DBI method dispatcher so it can be called directly, avoiding the
  need to use the func() method.
  
  It is called as a static method on the driver class to which the
  method belongs. The method name must begin with the corresponding
  registered driver-private prefix. For example, for DBD::Oracle
  $method_name must being with 'C<ora_>', and for DBD::AnyData it
  must begin with 'C<ad_>'.
  
  The attributes can be used to provide fine control over how the DBI
  dispatcher handles the dispatching of the method. However, at this
  point, it's undocumented and very liable to change. (Volunteers to
  polish up and document the interface are very welcome to get in
  touch via dbi-dev@perl.org)
  
  Methods installed using install_method default to the standard error
  handling behaviour for DBI methods: clearing err and errstr before
  calling the method, and checking for errors to trigger RaiseError 
  etc. on return. This differs from the default behaviour of func(). 
  
  Note for driver authors: The DBD::Foo::xx->install_method call won't
  work until the class-hierarchy has been setup. Normally the DBI
  looks after that just after the driver is loaded. This means
  install_method() can't be called at the time the driver is loaded
  unless the class-hierarchy is set up first. The way to do that is
  to call the setup_driver() method:
  
      DBI->setup_driver('DBD::Foo');
  
  before using install_method().
  
  
  =head4 The CLONE special subroutine
  
  Also needed here, in the B<DBD::Driver> package, is a C<CLONE()> method
  that will be called by perl when an interpreter is cloned. All your
  C<CLONE()> method needs to do, currently, is clear the cached I<$drh> so
  the new interpreter won't start using the cached I<$drh> from the old
  interpreter:
  
    sub CLONE {
      undef $drh;
    }
  
  See L<http://search.cpan.org/dist/perl/pod/perlmod.pod#Making_your_module_threadsafe>
  for details.
  
  =head3 The DBD::Driver::dr package
  
  The next lines of code look as follows:
  
    package DBD::Driver::dr; # ====== DRIVER ======
  
    $DBD::Driver::dr::imp_data_size = 0;
  
  Note that no I<@ISA> is needed here, or for the other B<DBD::Driver::*>
  classes, because the B<DBI> takes care of that for you when the driver is
  loaded.
  
   *FIX ME* Explain what the imp_data_size is, so that implementors aren't
   practicing cargo-cult programming.
  
  =head4 The database handle constructor
  
  The database handle constructor is the driver's (hence the changed
  namespace) C<connect()> method:
  
    sub connect
    {
        my ($drh, $dr_dsn, $user, $auth, $attr) = @_;
  
        # Some database specific verifications, default settings
        # and the like can go here. This should only include
        # syntax checks or similar stuff where it's legal to
        # 'die' in case of errors.
        # For example, many database packages requires specific
        # environment variables to be set; this could be where you
        # validate that they are set, or default them if they are not set.
  
        my $driver_prefix = "drv_"; # the assigned prefix for this driver
  
        # Process attributes from the DSN; we assume ODBC syntax
        # here, that is, the DSN looks like var1=val1;...;varN=valN
        foreach my $var ( split /;/, $dr_dsn ) {
            my ($attr_name, $attr_value) = split '=', $var, 2;
  	  return $drh->set_err($DBI::stderr, "Can't parse DSN part '$var'")
                unless defined $attr_value;
  
            # add driver prefix to attribute name if it doesn't have it already
            $attr_name = $driver_prefix.$attr_name
                unless $attr_name =~ /^$driver_prefix/o;
  
  	  # Store attribute into %$attr, replacing any existing value.
            # The DBI will STORE() these into $dbh after we've connected
  	  $attr->{$attr_name} = $attr_value;
        }
  
        # Get the attributes we'll use to connect.
        # We use delete here because these no need to STORE them
        my $db = delete $attr->{drv_database} || delete $attr->{drv_db}
            or return $drh->set_err($DBI::stderr, "No database name given in DSN '$dr_dsn'");
        my $host = delete $attr->{drv_host} || 'localhost';
        my $port = delete $attr->{drv_port} || 123456;
  
        # Assume you can attach to your database via drv_connect:
        my $connection = drv_connect($db, $host, $port, $user, $auth)
            or return $drh->set_err($DBI::stderr, "Can't connect to $dr_dsn: ...");
  
        # create a 'blank' dbh (call superclass constructor)
        my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dr_dsn });
  
        $dbh->STORE('Active', 1 );
        $dbh->{drv_connection} = $connection;
  
        return $outer;
    }
  
  This is mostly the same as in the I<driver handle constructor> above.
  The arguments are described in L<DBI>.
  
  The constructor C<DBI::_new_dbh()> is called, returning a database handle.
  The constructor's prototype is:
  
    ($outer, $inner) = DBI::_new_dbh($drh, $public_attr, $private_attr);
  
  with similar arguments to those in the I<driver handle constructor>,
  except that the I<$class> is replaced by I<$drh>. The I<Name> attribute
  is a standard B<DBI> attribute (see L<DBI/Database Handle Attributes>).
  
  In scalar context, only the outer handle is returned.
  
  Note the use of the C<STORE()> method for setting the I<dbh> attributes.
  That's because within the driver code, the handle object you have is
  the 'inner' handle of a tied hash, not the outer handle that the
  users of your driver have.
  
  Because you have the inner handle, tie magic doesn't get invoked
  when you get or set values in the hash. This is often very handy for
  speed when you want to get or set simple non-special driver-specific
  attributes.
  
  However, some attribute values, such as those handled by the B<DBI> like
  I<PrintError>, don't actually exist in the hash and must be read via
  C<$h-E<gt>FETCH($attrib)> and set via C<$h-E<gt>STORE($attrib, $value)>.
  If in any doubt, use these methods.
  
  =head4 The data_sources() method
  
  The C<data_sources()> method must populate and return a list of valid data
  sources, prefixed with the "I<dbi:Driver>" incantation that allows them to
  be used in the first argument of the C<DBI-E<gt>connect()> method.
  An example of this might be scanning the F<$HOME/.odbcini> file on Unix
  for ODBC data sources (DSNs).
  
  As a trivial example, consider a fixed list of data sources:
  
    sub data_sources
    {
        my($drh, $attr) = @_;
        my(@list) = ();
        # You need more sophisticated code than this to set @list...
        push @list, "dbi:Driver:abc";
        push @list, "dbi:Driver:def";
        push @list, "dbi:Driver:ghi";
        # End of code to set @list
        return @list;
    }
  
  =head4 The disconnect_all() method
  
  If you need to release any resources when the driver is unloaded, you
  can provide a disconnect_all method.
  
  =head4 Other driver handle methods
  
  If you need any other driver handle methods, they can follow here.
  
  =head4 Error handling
  
  It is quite likely that something fails in the connect method.
  With B<DBD::File> for example, you might catch an error when setting the
  current directory to something not existent by using the
  (driver-specific) I<f_dir> attribute.
  
  To report an error, you use the C<set_err()> method:
  
    $h->set_err($err, $errmsg, $state);
  
  This will ensure that the error is recorded correctly and that
  I<RaiseError> and I<PrintError> etc are handled correctly.
  
  Typically you'll always use the method instance, aka your method's first
  argument.
  
  As C<set_err()> always returns C<undef> your error handling code can
  usually be simplified to something like this:
  
    return $h->set_err($err, $errmsg, $state) if ...;
  
  =head3 The DBD::Driver::db package
  
    package DBD::Driver::db; # ====== DATABASE ======
  
    $DBD::Driver::db::imp_data_size = 0;
  
  =head4 The statement handle constructor
  
  There's nothing much new in the statement handle constructor, which
  is the C<prepare()> method:
  
    sub prepare
    {
        my ($dbh, $statement, @attribs) = @_;
  
        # create a 'blank' sth
        my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement });
  
        $sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//));
  
        $sth->{drv_params} = [];
  
        return $outer;
    }
  
  This is still the same -- check the arguments and call the super class
  constructor C<DBI::_new_sth()>. Again, in scalar context, only the outer
  handle is returned. The I<Statement> attribute should be cached as
  shown.
  
  Note the prefix I<drv_> in the attribute names: it is required that
  all your private attributes use a lowercase prefix unique to your driver.
  As mentioned earlier in this document, the B<DBI> contains a registry of
  known driver prefixes and may one day warn about unknown attributes
  that don't have a registered prefix.
  
  Note that we parse the statement here in order to set the attribute
  I<NUM_OF_PARAMS>. The technique illustrated is not very reliable; it can
  be confused by question marks appearing in quoted strings, delimited
  identifiers or in SQL comments that are part of the SQL statement. We
  could set I<NUM_OF_PARAMS> in the C<execute()> method instead because
  the B<DBI> specification explicitly allows a driver to defer this, but then
  the user could not call C<bind_param()>.
  
  =head4 Transaction handling
  
  Pure Perl drivers will rarely support transactions. Thus your C<commit()>
  and C<rollback()> methods will typically be quite simple:
  
    sub commit
    {
        my ($dbh) = @_;
        if ($dbh->FETCH('Warn')) {
            warn("Commit ineffective while AutoCommit is on");
        }
        0;
    }
  
    sub rollback {
        my ($dbh) = @_;
        if ($dbh->FETCH('Warn')) {
            warn("Rollback ineffective while AutoCommit is on");
        }
        0;
    }
  
  Or even simpler, just use the default methods provided by the B<DBI> that
  do nothing except return C<undef>.
  
  The B<DBI>'s default C<begin_work()> method can be used by inheritance.
  
  =head4 The STORE() and FETCH() methods
  
  These methods (that we have already used, see above) are called for
  you, whenever the user does a:
  
    $dbh->{$attr} = $val;
  
  or, respectively,
  
    $val = $dbh->{$attr};
  
  See L<perltie> for details on tied hash refs to understand why these
  methods are required.
  
  The B<DBI> will handle most attributes for you, in particular attributes
  like I<RaiseError> or I<PrintError>. All you have to do is handle your
  driver's private attributes and any attributes, like I<AutoCommit> and
  I<ChopBlanks>, that the B<DBI> can't handle for you.
  
  A good example might look like this:
  
    sub STORE
    {
        my ($dbh, $attr, $val) = @_;
        if ($attr eq 'AutoCommit') {
            # AutoCommit is currently the only standard attribute we have
            # to consider.
            if (!$val) { die "Can't disable AutoCommit"; }
            return 1;
        }
        if ($attr =~ m/^drv_/) {
            # Handle only our private attributes here
            # Note that we could trigger arbitrary actions.
            # Ideally we should warn about unknown attributes.
            $dbh->{$attr} = $val; # Yes, we are allowed to do this,
            return 1;             # but only for our private attributes
        }
        # Else pass up to DBI to handle for us
        $dbh->SUPER::STORE($attr, $val);
    }
  
    sub FETCH
    {
        my ($dbh, $attr) = @_;
        if ($attr eq 'AutoCommit') { return 1; }
        if ($attr =~ m/^drv_/) {
            # Handle only our private attributes here
            # Note that we could trigger arbitrary actions.
            return $dbh->{$attr}; # Yes, we are allowed to do this,
                                  # but only for our private attributes
        }
        # Else pass up to DBI to handle
        $dbh->SUPER::FETCH($attr);
    }
  
  The B<DBI> will actually store and fetch driver-specific attributes (with all
  lowercase names) without warning or error, so there's actually no need to
  implement driver-specific any code in your C<FETCH()> and C<STORE()>
  methods unless you need extra logic/checks, beyond getting or setting
  the value.
  
  Unless your driver documentation indicates otherwise, the return value of
  the C<STORE()> method is unspecified and the caller shouldn't use that value.
  
  =head4 Other database handle methods
  
  As with the driver package, other database handle methods may follow here.
  In particular you should consider a (possibly empty) C<disconnect()>
  method and possibly a C<quote()> method if B<DBI>'s default isn't correct for
  you. You may also need the C<type_info_all()> and C<get_info()> methods,
  as described elsewhere in this document.
  
  Where reasonable use C<$h-E<gt>SUPER::foo()> to call the B<DBI>'s method in
  some or all cases and just wrap your custom behavior around that.
  
  If you want to use private trace flags you'll probably want to be
  able to set them by name. To do that you'll need to define a
  C<parse_trace_flag()> method (note that's "parse_trace_flag", singular,
  not "parse_trace_flags", plural).
  
    sub parse_trace_flag {
        my ($h, $name) = @_;
        return 0x01000000 if $name eq 'foo';
        return 0x02000000 if $name eq 'bar';
        return 0x04000000 if $name eq 'baz';
        return 0x08000000 if $name eq 'boo';
        return 0x10000000 if $name eq 'bop';
        return $h->SUPER::parse_trace_flag($name);
    }
  
  All private flag names must be lowercase, and all private flags
  must be in the top 8 of the 32 bits.
  
  =head3 The DBD::Driver::st package
  
  This package follows the same pattern the others do:
  
    package DBD::Driver::st;
  
    $DBD::Driver::st::imp_data_size = 0;
  
  =head4 The execute() and bind_param() methods
  
  This is perhaps the most difficult method because we have to consider
  parameter bindings here. In addition to that, there are a number of
  statement attributes which must be set for inherited B<DBI> methods to
  function correctly (see L</Statement attributes> below).
  
  We present a simplified implementation by using the I<drv_params>
  attribute from above:
  
    sub bind_param
    {
        my ($sth, $pNum, $val, $attr) = @_;
        my $type = (ref $attr) ? $attr->{TYPE} : $attr;
        if ($type) {
            my $dbh = $sth->{Database};
            $val = $dbh->quote($sth, $type);
        }
        my $params = $sth->{drv_params};
        $params->[$pNum-1] = $val;
        1;
    }
  
    sub execute
    {
        my ($sth, @bind_values) = @_;
  
        # start of by finishing any previous execution if still active
        $sth->finish if $sth->FETCH('Active');
  
        my $params = (@bind_values) ?
            \@bind_values : $sth->{drv_params};
        my $numParam = $sth->FETCH('NUM_OF_PARAMS');
        return $sth->set_err($DBI::stderr, "Wrong number of parameters")
            if @$params != $numParam;
        my $statement = $sth->{'Statement'};
        for (my $i = 0;  $i < $numParam;  $i++) {
            $statement =~ s/?/$params->[$i]/; # XXX doesn't deal with quoting etc!
        }
        # Do anything ... we assume that an array ref of rows is
        # created and store it:
        $sth->{'drv_data'} = $data;
        $sth->{'drv_rows'} = @$data; # number of rows
        $sth->STORE('NUM_OF_FIELDS') = $numFields;
        $sth->{Active} = 1;
        @$data || '0E0';
    }
  
  There are a number of things you should note here.
  
  We initialize the I<NUM_OF_FIELDS> and I<Active> attributes here,
  because they are essential for C<bind_columns()> to work.
  
  We use attribute C<$sth-E<gt>{Statement}> which we created
  within C<prepare()>. The attribute C<$sth-E<gt>{Database}>, which is
  nothing else than the I<dbh>, was automatically created by B<DBI>.
  
  Finally, note that (as specified in the B<DBI> specification) we return the
  string C<'0E0'> instead of the number 0, so that the result tests true but
  equal to zero.
  
    $sth->execute() or die $sth->errstr;
  
  =head4 The execute_array(), execute_for_fetch() and bind_param_array() methods
  
  In general, DBD's only need to implement C<execute_for_fetch()> and
  C<bind_param_array>. DBI's default C<execute_array()> will invoke the
  DBD's C<execute_for_fetch()> as needed.
  
  The following sequence describes the interaction between
  DBI C<execute_array> and a DBD's C<execute_for_fetch>:
  
  =over
  
  =item 1
  
  App calls C<$sth-E<gt>execute_array(\%attrs, @array_of_arrays)>
  
  =item 2
  
  If C<@array_of_arrays> was specified, DBI processes C<@array_of_arrays> by calling
  DBD's C<bind_param_array()>. Alternately, App may have directly called
  C<bind_param_array()>
  
  =item 3
  
  DBD validates and binds each array
  
  =item 4
  
  DBI retrieves the validated param arrays from DBD's ParamArray attribute
  
  =item 5
  
  DBI calls DBD's C<execute_for_fetch($fetch_tuple_sub, \@tuple_status)>,
  where C<&$fetch_tuple_sub> is a closure to iterate over the
  returned ParamArray values, and C<\@tuple_status> is an array to receive
  the disposition status of each tuple.
  
  =item 6
  
  DBD iteratively calls C<&$fetch_tuple_sub> to retrieve parameter tuples
  to be added to its bulk database operation/request.
  
  =item 7
  
  when DBD reaches the limit of tuples it can handle in a single database
  operation/request, or the C<&$fetch_tuple_sub> indicates no more
  tuples by returning undef, the DBD executes the bulk operation, and
  reports the disposition of each tuple in \@tuple_status.
  
  =item 8
  
  DBD repeats steps 6 and 7 until all tuples are processed.
  
  =back
  
  E.g., here's the essence of L<DBD::Oracle>'s execute_for_fetch:
  
         while (1) {
             my @tuple_batch;
             for (my $i = 0; $i < $batch_size; $i++) {
                  push @tuple_batch, [ @{$fetch_tuple_sub->() || last} ];
             }
             last unless @tuple_batch;
             my $res = ora_execute_array($sth, \@tuple_batch,
                scalar(@tuple_batch), $tuple_batch_status);
             push @$tuple_status, @$tuple_batch_status;
         }
  
  Note that DBI's default execute_array()/execute_for_fetch() implementation
  requires the use of positional (i.e., '?') placeholders. Drivers
  which B<require> named placeholders must either emulate positional
  placeholders (e.g., see L<DBD::Oracle>), or must implement their own
  execute_array()/execute_for_fetch() methods to properly sequence bound
  parameter arrays.
  
  =head4 Fetching data
  
  Only one method needs to be written for fetching data, C<fetchrow_arrayref()>.
  The other methods, C<fetchrow_array()>, C<fetchall_arrayref()>, etc, as well
  as the database handle's C<select*> methods are part of B<DBI>, and call
  C<fetchrow_arrayref()> as necessary.
  
    sub fetchrow_arrayref
    {
        my ($sth) = @_;
        my $data = $sth->{drv_data};
        my $row = shift @$data;
        if (!$row) {
            $sth->STORE(Active => 0); # mark as no longer active
            return undef;
        }
        if ($sth->FETCH('ChopBlanks')) {
            map { $_ =~ s/\s+$//; } @$row;
        }
        return $sth->_set_fbav($row);
    }
    *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref
  
  Note the use of the method C<_set_fbav()> -- this is required so that
  C<bind_col()> and C<bind_columns()> work.
  
  If an error occurs which leaves the I<$sth> in a state where remaining rows
  can't be fetched then I<Active> should be turned off before the method returns.
  
  The C<rows()> method for this driver can be implemented like this:
  
    sub rows { shift->{drv_rows} }
  
  because it knows in advance how many rows it has fetched.
  Alternatively you could delete that method and so fallback
  to the B<DBI>'s own method which does the right thing based
  on the number of calls to C<_set_fbav()>.
  
  =head4 The more_results method
  
  If your driver doesn't support multiple result sets, then don't even implement this method.
  
  Otherwise, this method needs to get the statement handle ready to fetch results
  from the next result set, if there is one. Typically you'd start with:
  
      $sth->finish;
  
  then you should delete all the attributes from the attribute cache that may no
  longer be relevant for the new result set:
  
      delete $sth->{$_}
          for qw(NAME TYPE PRECISION SCALE ...);
  
  for drivers written in C use:
  
      hv_delete((HV*)SvRV(sth), "NAME", 4, G_DISCARD);
      hv_delete((HV*)SvRV(sth), "NULLABLE", 8, G_DISCARD);
      hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD);
      hv_delete((HV*)SvRV(sth), "PRECISION", 9, G_DISCARD);
      hv_delete((HV*)SvRV(sth), "SCALE", 5, G_DISCARD);
      hv_delete((HV*)SvRV(sth), "TYPE", 4, G_DISCARD);
  
  Don't forget to also delete, or update, any driver-private attributes that may
  not be correct for the next resultset.
  
  The NUM_OF_FIELDS attribute is a special case. It should be set using STORE:
  
      $sth->STORE(NUM_OF_FIELDS => 0); /* for DBI <= 1.53 */
      $sth->STORE(NUM_OF_FIELDS => $new_value);
  
  for drivers written in C use this incantation:
  
      /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */
      DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */
      DBIc_STATE(imp_xxh)->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS",13)), 0,
          sv_2mortal(newSViv(mysql_num_fields(imp_sth->result)))
      );
  
  For DBI versions prior to 1.54 you'll also need to explicitly adjust the
  number of elements in the row buffer array (C<DBIc_FIELDS_AV(imp_sth)>)
  to match the new result set. Fill any new values with newSV(0) not &sv_undef.
  Alternatively you could free DBIc_FIELDS_AV(imp_sth) and set it to null,
  but that would mean bind_columns() wouldn't work across result sets.
  
  
  =head4 Statement attributes
  
  The main difference between I<dbh> and I<sth> attributes is, that you
  should implement a lot of attributes here that are required by
  the B<DBI>, such as I<NAME>, I<NULLABLE>, I<TYPE>, etc. See
  L<DBI/Statement Handle Attributes> for a complete list.
  
  Pay attention to attributes which are marked as read only, such as
  I<NUM_OF_PARAMS>. These attributes can only be set the first time
  a statement is executed. If a statement is prepared, then executed
  multiple times, warnings may be generated.
  
  You can protect against these warnings, and prevent the recalculation
  of attributes which might be expensive to calculate (such as the
  I<NAME> and I<NAME_*> attributes):
  
      my $storedNumParams = $sth->FETCH('NUM_OF_PARAMS');
      if (!defined $storedNumParams or $storedNumFields < 0) {
          $sth->STORE('NUM_OF_PARAMS') = $numParams;
  
          # Set other useful attributes that only need to be set once
          # for a statement, like $sth->{NAME} and $sth->{TYPE}
      }
  
  One particularly important attribute to set correctly (mentioned in
  L<DBI/ATTRIBUTES COMMON TO ALL HANDLES> is I<Active>. Many B<DBI> methods,
  including C<bind_columns()>, depend on this attribute.
  
  Besides that the C<STORE()> and C<FETCH()> methods are mainly the same
  as above for I<dbh>'s.
  
  =head4 Other statement methods
  
  A trivial C<finish()> method to discard stored data, reset any attributes
  (such as I<Active>) and do C<$sth-E<gt>SUPER::finish()>.
  
  If you've defined a C<parse_trace_flag()> method in B<::db> you'll also want
  it in B<::st>, so just alias it in:
  
    *parse_trace_flag = \&DBD::foo:db::parse_trace_flag;
  
  And perhaps some other methods that are not part of the B<DBI>
  specification, in particular to make metadata available.
  Remember that they must have names that begin with your drivers
  registered prefix so they can be installed using C<install_method()>.
  
  If C<DESTROY()> is called on a statement handle that's still active
  (C<$sth-E<gt>{Active}> is true) then it should effectively call C<finish()>.
  
      sub DESTROY {
          my $sth = shift;
          $sth->finish if $sth->FETCH('Active');
      }
  
  =head2 Tests
  
  The test process should conform as closely as possibly to the Perl
  standard test harness.
  
  In particular, most (all) of the tests should be run in the F<t> sub-directory,
  and should simply produce an C<ok> when run under C<make test>.
  For details on how this is done, see the Camel book and the section in
  Chapter 7, "The Standard Perl Library" on L<Test::Harness>.
  
  The tests may need to adapt to the type of database which is being used
  for testing, and to the privileges of the user testing the driver. For
  example, the B<DBD::Informix> test code has to adapt in a number of
  places to the type of database to which it is connected as different
  Informix databases have different capabilities: some of the tests are
  for databases without transaction logs; others are for databases with a
  transaction log; some versions of the server have support for blobs, or
  stored procedures, or user-defined data types, and others do not.
  
  When a complete file of tests must be skipped, you can provide a reason
  in a pseudo-comment:
  
      if ($no_transactions_available)
      {
          print "1..0 # Skip: No transactions available\n";
          exit 0;
      }
  
  Consider downloading the B<DBD::Informix> code and look at the code in
  F<DBD/Informix/TestHarness.pm> which is used throughout the
  B<DBD::Informix> tests in the F<t> sub-directory.
  
  =head1 CREATING A C/XS DRIVER
  
  Please also see the section under L<CREATING A PURE PERL DRIVER>
  regarding the creation of the F<Makefile.PL>.
  
  Creating a new C/XS driver from scratch will always be a daunting task.
  You can and should greatly simplify your task by taking a good
  reference driver implementation and modifying that to match the
  database product for which you are writing a driver.
  
  The de facto reference driver has been the one for B<DBD::Oracle> written
  by Tim Bunce, who is also the author of the B<DBI> package. The B<DBD::Oracle>
  module is a good example of a driver implemented around a C-level API.
  
  Nowadays it it seems better to base on B<DBD::ODBC>, another driver
  maintained by Tim and Jeff Urlwin, because it offers a lot of metadata
  and seems to become the guideline for the future development. (Also as
  B<DBD::Oracle> digs deeper into the Oracle 8 OCI interface it'll get even
  more hairy than it is now.)
  
  The B<DBD::Informix> driver is one driver implemented using embedded SQL
  instead of a function-based API.
  B<DBD::Ingres> may also be worth a look.
  
  =head2 C/XS version of Driver.pm
  
  A lot of the code in the F<Driver.pm> file is very similar to the code for pure Perl modules
  - see above.  However,
  there are also some subtle (and not so subtle) differences, including:
  
  =over 8
  
  =item *
  
  The variables I<$DBD::Driver::{dr|db|st}::imp_data_size> are not defined
  here, but in the XS code, because they declare the size of certain
  C structures.
  
  =item *
  
  Some methods are typically moved to the XS code, in particular
  C<prepare()>, C<execute()>, C<disconnect()>, C<disconnect_all()> and the
  C<STORE()> and C<FETCH()> methods.
  
  =item *
  
  Other methods are still part of F<Driver.pm>, but have callbacks to
  the XS code.
  
  =item *
  
  If the driver-specific parts of the I<imp_drh_t> structure need to be
  formally initialized (which does not seem to be a common requirement),
  then you need to add a call to an appropriate XS function in the driver
  method of C<DBD::Driver::driver()>, and you define the corresponding function
  in F<Driver.xs>, and you define the C code in F<dbdimp.c> and the prototype in
  F<dbdimp.h>.
  
  For example, B<DBD::Informix> has such a requirement, and adds the
  following call after the call to C<_new_drh()> in F<Informix.pm>:
  
    DBD::Informix::dr::driver_init($drh);
  
  and the following code in F<Informix.xs>:
  
    # Initialize the DBD::Informix driver data structure
    void
    driver_init(drh)
        SV *drh
        CODE:
        ST(0) = dbd_ix_dr_driver_init(drh) ? &sv_yes : &sv_no;
  
  and the code in F<dbdimp.h> declares:
  
    extern int dbd_ix_dr_driver_init(SV *drh);
  
  and the code in F<dbdimp.ec> (equivalent to F<dbdimp.c>) defines:
  
    /* Formally initialize the DBD::Informix driver structure */
    int
    dbd_ix_dr_driver(SV *drh)
    {
        D_imp_drh(drh);
        imp_drh->n_connections = 0;       /* No active connections */
        imp_drh->current_connection = 0;  /* No current connection */
        imp_drh->multipleconnections = (ESQLC_VERSION >= 600) ? True : False;
        dbd_ix_link_newhead(&imp_drh->head);  /* Empty linked list of connections */
        return 1;
    }
  
  B<DBD::Oracle> has a similar requirement but gets around it by checking
  whether the private data part of the driver handle is all zeroed out,
  rather than add extra functions.
  
  =back
  
  Now let's take a closer look at an excerpt from F<Oracle.pm> (revised
  heavily to remove idiosyncrasies) as an example, ignoring things that
  were already discussed for pure Perl drivers.
  
  =head3 The connect method
  
  The connect method is the database handle constructor.
  You could write either of two versions of this method: either one which
  takes connection attributes (new code) and one which ignores them (old
  code only).
  
  If you ignore the connection attributes, then you omit all mention of
  the I<$auth> variable (which is a reference to a hash of attributes), and
  the XS system manages the differences for you.
  
    sub connect
    {
        my ($drh, $dbname, $user, $auth, $attr) = @_;
  
        # Some database specific verifications, default settings
        # and the like following here. This should only include
        # syntax checks or similar stuff where it's legal to
        # 'die' in case of errors.
  
        my $dbh = DBI::_new_dbh($drh, {
                'Name'   => $dbname,
            })
            or return undef;
  
        # Call the driver-specific function _login in Driver.xs file which
        # calls the DBMS-specific function(s) to connect to the database,
        # and populate internal handle data.
        DBD::Driver::db::_login($dbh, $dbname, $user, $auth, $attr)
            or return undef;
  
        $dbh;
    }
  
  This is mostly the same as in the pure Perl case, the exception being
  the use of the private C<_login()> callback, which is the function
  that will really connect to the database. It is implemented in
  F<Driver.xst> (you should not implement it) and calls
  C<dbd_db_login6()> or C<dbd_db_login6_sv> from F<dbdimp.c>. See below
  for details.
  
  If your driver has driver-specific attributes which may be passed in the
  connect method and hence end up in C<$attr> in C<dbd_db_login6> then it
  is best to delete any you process so DBI does not send them again
  via STORE after connect. You can do this in C like this:
  
    DBD_ATTRIB_DELETE(attr, "my_attribute_name",
                      strlen("my_attribute_name"));
  
  However, prior to DBI subversion version 11605 (and fixed post 1.607)
  DBD_ATTRIB_DELETE segfaulted so if you cannot guarantee the DBI version
  will be post 1.607 you need to use:
  
    hv_delete((HV*)SvRV(attr), "my_attribute_name",
                       strlen("my_attribute_name"), G_DISCARD);
  
   *FIX ME* Discuss removing attributes in Perl code.
  
  =head3 The disconnect_all method
  
   *FIX ME* T.B.S
  
  =head3 The data_sources method
  
  If your C<data_sources()> method can be implemented in pure Perl, then do
  so because it is easier than doing it in XS code (see the section above
  for pure Perl drivers).
  
  If your C<data_sources()> method must call onto compiled functions, then
  you will need to define I<dbd_dr_data_sources> in your F<dbdimp.h> file, which
  will trigger F<Driver.xst> (in B<DBI> v1.33 or greater) to generate the XS
  code that calls your actual C function (see the discussion below for
  details) and you do not code anything in F<Driver.pm> to handle it.
  
  =head3 The prepare method
  
  The prepare method is the statement handle constructor, and most of it
  is not new. Like the C<connect()> method, it now has a C callback:
  
    package DBD::Driver::db; # ====== DATABASE ======
    use strict;
  
    sub prepare
    {
        my ($dbh, $statement, $attribs) = @_;
  
        # create a 'blank' sth
        my $sth = DBI::_new_sth($dbh, {
            'Statement' => $statement,
            })
            or return undef;
  
        # Call the driver-specific function _prepare in Driver.xs file
        # which calls the DBMS-specific function(s) to prepare a statement
        # and populate internal handle data.
        DBD::Driver::st::_prepare($sth, $statement, $attribs)
            or return undef;
        $sth;
    }
  
  =head3 The execute method
  
   *FIX ME* T.B.S
  
  =head3 The fetchrow_arrayref method
  
   *FIX ME* T.B.S
  
  =head3 Other methods?
  
   *FIX ME* T.B.S
  
  =head2 Driver.xs
  
  F<Driver.xs> should look something like this:
  
    #include "Driver.h"
  
    DBISTATE_DECLARE;
  
    INCLUDE: Driver.xsi
  
    MODULE = DBD::Driver    PACKAGE = DBD::Driver::dr
  
    /* Non-standard drh XS methods following here, if any.       */
    /* If none (the usual case), omit the MODULE line above too. */
  
    MODULE = DBD::Driver    PACKAGE = DBD::Driver::db
  
    /* Non-standard dbh XS methods following here, if any.       */
    /* Currently this includes things like _list_tables from     */
    /* DBD::mSQL and DBD::mysql.                                 */
  
    MODULE = DBD::Driver    PACKAGE = DBD::Driver::st
  
    /* Non-standard sth XS methods following here, if any.       */
    /* In particular this includes things like _list_fields from */
    /* DBD::mSQL and DBD::mysql for accessing metadata.          */
  
  Note especially the include of F<Driver.xsi> here: B<DBI> inserts stub
  functions for almost all private methods here which will typically do
  much work for you.
  
  Wherever you really have to implement something, it will call a private
  function in F<dbdimp.c>, and this is what you have to implement.
  
  You need to set up an extra routine if your driver needs to export
  constants of its own, analogous to the SQL types available when you say:
  
    use DBI qw(:sql_types);
  
   *FIX ME* T.B.S
  
  =head2 Driver.h
  
  F<Driver.h> is very simple and the operational contents should look like this:
  
    #ifndef DRIVER_H_INCLUDED
    #define DRIVER_H_INCLUDED
  
    #define NEED_DBIXS_VERSION 93    /* 93 for DBI versions 1.00 to 1.51+ */
    #define PERL_NO_GET_CONTEXT      /* if used require DBI 1.51+ */
  
    #include <DBIXS.h>      /* installed by the DBI module  */
  
    #include "dbdimp.h"
  
    #include "dbivport.h"   /* see below                    */
  
    #include <dbd_xsh.h>    /* installed by the DBI module  */
  
    #endif /* DRIVER_H_INCLUDED */
  
  The F<DBIXS.h> header defines most of the interesting information that
  the writer of a driver needs.
  
  The file F<dbd_xsh.h> header provides prototype declarations for the C
  functions that you might decide to implement. Note that you should
  normally only define one of C<dbd_db_login()>, C<dbd_db_login6()> or
  C<dbd_db_login6_sv> unless you are intent on supporting really old
  versions of B<DBI> (prior to B<DBI> 1.06) as well as modern
  versions. The only standard, B<DBI>-mandated functions that you need
  write are those specified in the F<dbd_xsh.h> header. You might also
  add extra driver-specific functions in F<Driver.xs>.
  
  The F<dbivport.h> file should be I<copied> from the latest B<DBI> release
  into your distribution each time you modify your driver. Its job is to
  allow you to enhance your code to work with the latest B<DBI> API while
  still allowing your driver to be compiled and used with older versions
  of the B<DBI> (for example, when the C<DBIh_SET_ERR_CHAR()> macro was added
  to B<DBI> 1.41, an emulation of it was added to F<dbivport.h>). This makes
  users happy and your life easier. Always read the notes in F<dbivport.h>
  to check for any limitations in the emulation that you should be aware
  of.
  
  With B<DBI> v1.51 or better I recommend that the driver defines
  I<PERL_NO_GET_CONTEXT> before F<DBIXS.h> is included. This can significantly
  improve efficiency when running under a thread enabled perl. (Remember that
  the standard perl in most Linux distributions is built with threads enabled.
  So is ActiveState perl for Windows, and perl built for Apache mod_perl2.)
  If you do this there are some things to keep in mind:
  
  =over 4
  
  =item *
  
  If I<PERL_NO_GET_CONTEXT> is defined, then every function that calls the Perl
  API will need to start out with a C<dTHX;> declaration.
  
  =item *
  
  You'll know which functions need this, because the C compiler will
  complain that the undeclared identifier C<my_perl> is used if I<and only if>
  the perl you are using to develop and test your driver has threads enabled.
  
  =item *
  
  If you don't remember to test with a thread-enabled perl before making
  a release it's likely that you'll get failure reports from users who are.
  
  =item *
  
  For driver private functions it is possible to gain even more
  efficiency by replacing C<dTHX;> with C<pTHX_> prepended to the
  parameter list and then C<aTHX_> prepended to the argument list where
  the function is called.
  
  =back
  
  See L<perlguts/How multiple interpreters and concurrency are supported> for
  additional information about I<PERL_NO_GET_CONTEXT>.
  
  =head2 Implementation header dbdimp.h
  
  This header file has two jobs:
  
  First it defines data structures for your private part of the handles.
  
  Second it defines macros that rename the generic names like
  C<dbd_db_login()> to database specific names like C<ora_db_login()>. This
  avoids name clashes and enables use of different drivers when you work
  with a statically linked perl.
  
  It also will have the important task of disabling XS methods that you
  don't want to implement.
  
  Finally, the macros will also be used to select alternate
  implementations of some functions. For example, the C<dbd_db_login()>
  function is not passed the attribute hash.
  
  Since B<DBI> v1.06, if a C<dbd_db_login6()> macro is defined (for a function
  with 6 arguments), it will be used instead with the attribute hash
  passed as the sixth argument.
  
  Since B<DBI> post v1.607, if a C<dbd_db_login6_sv()> macro is defined (for
  a function like dbd_db_login6 but with scalar pointers for the dbname,
  username and password), it will be used instead. This will allow your
  login6 function to see if there are any unicode characters in the
  dbname.
  
  People used to just pick Oracle's F<dbdimp.c> and use the same names,
  structures and types. I strongly recommend against that. At first glance
  this saves time, but your implementation will be less readable. It was
  just hell when I had to separate B<DBI> specific parts, Oracle specific
  parts, mSQL specific parts and mysql specific parts in B<DBD::mysql>'s
  I<dbdimp.h> and I<dbdimp.c>. (B<DBD::mysql> was a port of B<DBD::mSQL>
  which was based on B<DBD::Oracle>.) [Seconded, based on the experience
  taking B<DBD::Informix> apart, even though the version inherited in 1996
  was only based on B<DBD::Oracle>.]
  
  This part of the driver is I<your exclusive part>. Rewrite it from
  scratch, so it will be clean and short: in other words, a better piece
  of code. (Of course keep an eye on other people's work.)
  
    struct imp_drh_st {
        dbih_drc_t com;           /* MUST be first element in structure   */
        /* Insert your driver handle attributes here */
    };
  
    struct imp_dbh_st {
        dbih_dbc_t com;           /* MUST be first element in structure   */
        /* Insert your database handle attributes here */
    };
  
    struct imp_sth_st {
        dbih_stc_t com;           /* MUST be first element in structure   */
        /* Insert your statement handle attributes here */
    };
  
    /*  Rename functions for avoiding name clashes; prototypes are  */
    /*  in dbd_xst.h                                                */
    #define dbd_init            drv_dr_init
    #define dbd_db_login6_sv    drv_db_login_sv
    #define dbd_db_do           drv_db_do
    ... many more here ...
  
  These structures implement your private part of the handles.
  
  You I<have> to use the name C<imp_dbh_{dr|db|st}> and the first field
  I<must> be of type I<dbih_drc_t|_dbc_t|_stc_t> and I<must> be called
  C<com>.
  
  You should never access these fields directly, except by using the
  I<DBIc_xxx()> macros below.
  
  =head2 Implementation source dbdimp.c
  
  Conventionally, F<dbdimp.c> is the main implementation file (but
  B<DBD::Informix> calls the file F<dbdimp.ec>). This section includes a
  short note on each function that is used in the F<Driver.xsi> template
  and thus I<has> to be implemented.
  
  Of course, you will probably also need to implement other support
  functions, which should usually be file static if they are placed in
  F<dbdimp.c>. If they are placed in other files, you need to list those
  files in F<Makefile.PL> (and F<MANIFEST>) to handle them correctly.
  
  It is wise to adhere to a namespace convention for your functions to
  avoid conflicts. For example, for a driver with prefix I<drv_>, you
  might call externally visible functions I<dbd_drv_xxxx>. You should also
  avoid non-constant global variables as much as possible to improve the
  support for threading.
  
  Since Perl requires support for function prototypes (ANSI or ISO or
  Standard C), you should write your code using function prototypes too.
  
  It is possible to use either the unmapped names such as C<dbd_init()> or
  the mapped names such as C<dbd_ix_dr_init()> in the F<dbdimp.c> file.
  B<DBD::Informix> uses the mapped names which makes it easier to identify
  where to look for linkage problems at runtime (which will report errors
  using the mapped names).
  
  Most other drivers, and in particular B<DBD::Oracle>, use the unmapped
  names in the source code which makes it a little easier to compare code
  between drivers and eases discussions on the I<dbi-dev> mailing list.
  The majority of the code fragments here will use the unmapped names.
  
  Ultimately, you should provide implementations for most of the
  functions listed in the F<dbd_xsh.h> header. The exceptions are
  optional functions (such as C<dbd_st_rows()>) and those functions with
  alternative signatures, such as C<dbd_db_login6_sv>,
  C<dbd_db_login6()> and I<dbd_db_login()>. Then you should only
  implement one of the alternatives, and generally the newer one of the
  alternatives.
  
  =head3 The dbd_init method
  
    #include "Driver.h"
  
    DBISTATE_DECLARE;
  
    void dbd_init(dbistate_t* dbistate)
    {
        DBISTATE_INIT;  /*  Initialize the DBI macros  */
    }
  
  The C<dbd_init()> function will be called when your driver is first
  loaded; the bootstrap command in C<DBD::Driver::dr::driver()> triggers this,
  and the call is generated in the I<BOOT> section of F<Driver.xst>.
  These statements are needed to allow your driver to use the B<DBI> macros.
  They will include your private header file F<dbdimp.h> in turn.
  Note that I<DBISTATE_INIT> requires the name of the argument to C<dbd_init()>
  to be called C<dbistate()>.
  
  =head3 The dbd_drv_error method
  
  You need a function to record errors so B<DBI> can access them properly.
  You can call it whatever you like, but we'll call it C<dbd_drv_error()>
  here.
  
  The argument list depends on your database software; different systems
  provide different ways to get at error information.
  
    static void dbd_drv_error(SV *h, int rc, const char *what)
    {
  
  Note that I<h> is a generic handle, may it be a driver handle, a
  database or a statement handle.
  
        D_imp_xxh(h);
  
  This macro will declare and initialize a variable I<imp_xxh> with
  a pointer to your private handle pointer. You may cast this to
  to I<imp_drh_t>, I<imp_dbh_t> or I<imp_sth_t>.
  
  To record the error correctly, equivalent to the C<set_err()> method,
  use one of the C<DBIh_SET_ERR_CHAR(...)> or C<DBIh_SET_ERR_SV(...)> macros,
  which were added in B<DBI> 1.41:
  
    DBIh_SET_ERR_SV(h, imp_xxh, err, errstr, state, method);
    DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method);
  
  For C<DBIh_SET_ERR_SV> the I<err>, I<errstr>, I<state>, and I<method>
  parameters are C<SV*> (use &sv_undef instead of NULL).
  
  For C<DBIh_SET_ERR_CHAR> the I<err_c>, I<errstr>, I<state>, I<method>
  parameters are C<char*>.
  
  The I<err_i> parameter is an C<IV> that's used instead of I<err_c> if
  I<err_c> is C<Null>.
  
  The I<method> parameter can be ignored.
  
  The C<DBIh_SET_ERR_CHAR> macro is usually the simplest to use when you
  just have an integer error code and an error message string:
  
    DBIh_SET_ERR_CHAR(h, imp_xxh, Nullch, rc, what, Nullch, Nullch);
  
  As you can see, any parameters that aren't relevant to you can be C<Null>.
  
  To make drivers compatible with B<DBI> < 1.41 you should be using F<dbivport.h>
  as described in L</Driver.h> above.
  
  The (obsolete) macros such as C<DBIh_EVENT2> should be removed from drivers.
  
  The names C<dbis> and C<DBIS>, which were used in previous versions of
  this document, should be replaced with the C<DBIc_STATE(imp_xxh)> macro.
  
  The name C<DBILOGFP>, which was also used in previous versions of this
  document, should be replaced by C<DBIc_LOGPIO(imp_xxh)>.
  
  Your code should not call the C C<E<lt>stdio.hE<gt>> I/O functions; you
  should use C<PerlIO_printf()> as shown:
  
        if (DBIc_TRACE_LEVEL(imp_xxh) >= 2)
            PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar %s: %s\n",
                foo, neatsvpv(errstr,0));
  
  That's the first time we see how tracing works within a B<DBI> driver. Make
  use of this as often as you can, but don't output anything at a trace
  level less than 3. Levels 1 and 2 are reserved for the B<DBI>.
  
  You can define up to 8 private trace flags using the top 8 bits
  of C<DBIc_TRACE_FLAGS(imp)>, that is: C<0xFF000000>. See the
  C<parse_trace_flag()> method elsewhere in this document.
  
  =head3 The dbd_dr_data_sources method
  
  This method is optional; the support for it was added in B<DBI> v1.33.
  
  As noted in the discussion of F<Driver.pm>, if the data sources
  can be determined by pure Perl code, do it that way. If, as in
  B<DBD::Informix>, the information is obtained by a C function call, then
  you need to define a function that matches the prototype:
  
    extern AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs);
  
  An outline implementation for B<DBD::Informix> follows, assuming that the
  C<sqgetdbs()> function call shown will return up to 100 databases names,
  with the pointers to each name in the array dbsname and the name strings
  themselves being stores in dbsarea.
  
    AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attr)
    {
        int ndbs;
        int i;
        char *dbsname[100];
        char  dbsarea[10000];
        AV *av = Nullav;
  
        if (sqgetdbs(&ndbs, dbsname, 100, dbsarea, sizeof(dbsarea)) == 0)
        {
            av = NewAV();
            av_extend(av, (I32)ndbs);
            sv_2mortal((SV *)av);
            for (i = 0; i < ndbs; i++)
              av_store(av, i, newSVpvf("dbi:Informix:%s", dbsname[i]));
        }
        return(av);
    }
  
  The actual B<DBD::Informix> implementation has a number of extra lines of
  code, logs function entry and exit, reports the error from C<sqgetdbs()>,
  and uses C<#define>'d constants for the array sizes.
  
  =head3 The dbd_db_login6 method
  
    int dbd_db_login6_sv(SV* dbh, imp_dbh_t* imp_dbh, SV* dbname,
                         SV* user, SV* auth, SV *attr);
  
    or
  
    int dbd_db_login6(SV* dbh, imp_dbh_t* imp_dbh, char* dbname,
                     char* user, char* auth, SV *attr);
  
  This function will really connect to the database. The argument I<dbh>
  is the database handle. I<imp_dbh> is the pointer to the handles private
  data, as is I<imp_xxx> in C<dbd_drv_error()> above. The arguments
  I<dbname>, I<user>, I<auth> and I<attr> correspond to the arguments of
  the driver handle's C<connect()> method.
  
  You will quite often use database specific attributes here, that are
  specified in the DSN. I recommend you parse the DSN (using Perl) within
  the C<connect()> method and pass the segments of the DSN via the
  attributes parameter through C<_login()> to C<dbd_db_login6()>.
  
  Here's how you fetch them; as an example we use I<hostname> attribute,
  which can be up to 12 characters long excluding null terminator:
  
    SV** svp;
    STRLEN len;
    char* hostname;
  
    if ( (svp = DBD_ATTRIB_GET_SVP(attr, "drv_hostname", 12)) && SvTRUE(*svp)) {
        hostname = SvPV(*svp, len);
        DBD_ATTRIB_DELETE(attr, "drv_hostname", 12); /* avoid later STORE */
    } else {
        hostname = "localhost";
    }
  
  If you handle any driver specific attributes in the dbd_db_login6
  method you probably want to delete them from C<attr> (as above with
  DBD_ATTRIB_DELETE). If you don't delete your handled attributes DBI
  will call C<STORE> for each attribute after the connect/login and this
  is at best redundant for attributes you have already processed.
  
  B<Note: Until revision 11605 (post DBI 1.607), there was a problem with
  DBD_ATTRIBUTE_DELETE so unless you require a DBI version after 1.607
  you need to replace each DBD_ATTRIBUTE_DELETE call with:>
  
    hv_delete((HV*)SvRV(attr), key, key_len, G_DISCARD)
  
  Note that you can also obtain standard attributes such as I<AutoCommit> and
  I<ChopBlanks> from the attributes parameter, using C<DBD_ATTRIB_GET_IV> for
  integer attributes.
  
  If, for example, your database does not support transactions but
  I<AutoCommit> is set off (requesting transaction support), then you can
  emulate a 'failure to connect'.
  
  Now you should really connect to the database. In general, if the
  connection fails, it is best to ensure that all allocated resources are
  released so that the handle does not need to be destroyed separately. If
  you are successful (and possibly even if you fail but you have allocated
  some resources), you should use the following macros:
  
    DBIc_IMPSET_on(imp_dbh);
  
  This indicates that the driver (implementor) has allocated resources in
  the I<imp_dbh> structure and that the implementors private C<dbd_db_destroy()>
  function should be called when the handle is destroyed.
  
    DBIc_ACTIVE_on(imp_dbh);
  
  This indicates that the handle has an active connection to the server
  and that the C<dbd_db_disconnect()> function should be called before the
  handle is destroyed.
  
  Note that if you do need to fail, you should report errors via the I<drh>
  or I<imp_drh> rather than via I<dbh> or I<imp_dbh> because I<imp_dbh> will be
  destroyed by the failure, so errors recorded in that handle will not be
  visible to B<DBI>, and hence not the user either.
  
  Note too, that the function is passed I<dbh> and I<imp_dbh>, and there
  is a macro C<D_imp_drh_from_dbh> which can recover the I<imp_drh> from
  the I<imp_dbh>. However, there is no B<DBI> macro to provide you with the
  I<drh> given either the I<imp_dbh> or the I<dbh> or the I<imp_drh> (and
  there's no way to recover the I<dbh> given just the I<imp_dbh>).
  
  This suggests that, despite the above notes about C<dbd_drv_error()>
  taking an C<SV *>, it may be better to have two error routines, one
  taking I<imp_dbh> and one taking I<imp_drh> instead. With care, you can
  factor most of the formatting code out so that these are small routines
  calling a common error formatter. See the code in B<DBD::Informix>
  1.05.00 for more information.
  
  The C<dbd_db_login6()> function should return I<TRUE> for success,
  I<FALSE> otherwise.
  
  Drivers implemented long ago may define the five-argument function
  C<dbd_db_login()> instead of C<dbd_db_login6()>. The missing argument is
  the attributes. There are ways to work around the missing attributes,
  but they are ungainly; it is much better to use the 6-argument form.
  Even later drivers will use C<dbd_db_login6_sv()> which provides the
  dbname, username and password as SVs.
  
  =head3 The dbd_db_commit and dbd_db_rollback methods
  
    int dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh);
    int dbd_db_rollback(SV* dbh, imp_dbh_t* imp_dbh);
  
  These are used for commit and rollback. They should return I<TRUE> for
  success, I<FALSE> for error.
  
  The arguments I<dbh> and I<imp_dbh> are the same as for C<dbd_db_login6()>
  above; I will omit describing them in what follows, as they appear
  always.
  
  These functions should return I<TRUE> for success, I<FALSE> otherwise.
  
  =head3 The dbd_db_disconnect method
  
  This is your private part of the C<disconnect()> method. Any I<dbh> with
  the I<ACTIVE> flag on must be disconnected. (Note that you have to set
  it in C<dbd_db_connect()> above.)
  
    int dbd_db_disconnect(SV* dbh, imp_dbh_t* imp_dbh);
  
  The database handle will return I<TRUE> for success, I<FALSE> otherwise.
  In any case it should do a:
  
    DBIc_ACTIVE_off(imp_dbh);
  
  before returning so B<DBI> knows that C<dbd_db_disconnect()> was executed.
  
  Note that there's nothing to stop a I<dbh> being I<disconnected> while
  it still have active children. If your database API reacts badly to
  trying to use an I<sth> in this situation then you'll need to add code
  like this to all I<sth> methods:
  
    if (!DBIc_ACTIVE(DBIc_PARENT_COM(imp_sth)))
      return 0;
  
  Alternatively, you can add code to your driver to keep explicit track of
  the statement handles that exist for each database handle and arrange
  to destroy those handles before disconnecting from the database. There
  is code to do this in B<DBD::Informix>. Similar comments apply to the
  driver handle keeping track of all the database handles.
  
  Note that the code which destroys the subordinate handles should only
  release the associated database resources and mark the handles inactive;
  it does not attempt to free the actual handle structures.
  
  This function should return I<TRUE> for success, I<FALSE> otherwise, but
  it is not clear what anything can do about a failure.
  
  =head3 The dbd_db_discon_all method
  
    int dbd_discon_all (SV *drh, imp_drh_t *imp_drh);
  
  This function may be called at shutdown time. It should make
  best-efforts to disconnect all database handles - if possible. Some
  databases don't support that, in which case you can do nothing
  but return 'success'.
  
  This function should return I<TRUE> for success, I<FALSE> otherwise, but
  it is not clear what anything can do about a failure.
  
  =head3 The dbd_db_destroy method
  
  This is your private part of the database handle destructor. Any I<dbh> with
  the I<IMPSET> flag on must be destroyed, so that you can safely free
  resources. (Note that you have to set it in C<dbd_db_connect()> above.)
  
    void dbd_db_destroy(SV* dbh, imp_dbh_t* imp_dbh)
    {
        DBIc_IMPSET_off(imp_dbh);
    }
  
  The B<DBI> F<Driver.xst> code will have called C<dbd_db_disconnect()> for you,
  if the handle is still 'active', before calling C<dbd_db_destroy()>.
  
  Before returning the function must switch I<IMPSET> to off, so B<DBI> knows
  that the destructor was called.
  
  A B<DBI> handle doesn't keep references to its children. But children
  do keep references to their parents. So a database handle won't be
  C<DESTROY>'d until all its children have been C<DESTROY>'d.
  
  =head3 The dbd_db_STORE_attrib method
  
  This function handles
  
    $dbh->{$key} = $value;
  
  Its prototype is:
  
    int dbd_db_STORE_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv,
                            SV* valuesv);
  
  You do not handle all attributes; on the contrary, you should not handle
  B<DBI> attributes here: leave this to B<DBI>. (There are two exceptions,
  I<AutoCommit> and I<ChopBlanks>, which you should care about.)
  
  The return value is I<TRUE> if you have handled the attribute or I<FALSE>
  otherwise. If you are handling an attribute and something fails, you
  should call C<dbd_drv_error()>, so B<DBI> can raise exceptions, if desired.
  If C<dbd_drv_error()> returns, however, you have a problem: the user will
  never know about the error, because he typically will not check
  C<$dbh-E<gt>errstr()>.
  
  I cannot recommend a general way of going on, if C<dbd_drv_error()> returns,
  but there are examples where even the B<DBI> specification expects that
  you C<croak()>. (See the I<AutoCommit> method in L<DBI>.)
  
  If you have to store attributes, you should either use your private
  data structure I<imp_xxx>, the handle hash (via C<(HV*)SvRV(dbh)>), or use
  the private I<imp_data>.
  
  The first is best for internal C values like integers or pointers and
  where speed is important within the driver. The handle hash is best for
  values the user may want to get/set via driver-specific attributes.
  The private I<imp_data> is an additional C<SV> attached to the handle. You
  could think of it as an unnamed handle attribute. It's not normally used.
  
  =head3 The dbd_db_FETCH_attrib method
  
  This is the counterpart of C<dbd_db_STORE_attrib()>, needed for:
  
    $value = $dbh->{$key};
  
  Its prototype is:
  
    SV* dbd_db_FETCH_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv);
  
  Unlike all previous methods this returns an C<SV> with the value. Note
  that you should normally execute C<sv_2mortal()>, if you return a nonconstant
  value. (Constant values are C<&sv_undef>, C<&sv_no> and C<&sv_yes>.)
  
  Note, that B<DBI> implements a caching algorithm for attribute values.
  If you think, that an attribute may be fetched, you store it in the
  I<dbh> itself:
  
    if (cacheit) /* cache value for later DBI 'quick' fetch? */
        hv_store((HV*)SvRV(dbh), key, kl, cachesv, 0);
  
  =head3 The dbd_st_prepare method
  
  This is the private part of the C<prepare()> method. Note that you
  B<must not> really execute the statement here. You may, however,
  preparse and validate the statement, or do similar things.
  
    int dbd_st_prepare(SV* sth, imp_sth_t* imp_sth, char* statement,
                       SV* attribs);
  
  A typical, simple, possibility is to do nothing and rely on the perl
  C<prepare()> code that set the I<Statement> attribute on the handle. This
  attribute can then be used by C<dbd_st_execute()>.
  
  If the driver supports placeholders then the I<NUM_OF_PARAMS> attribute
  must be set correctly by C<dbd_st_prepare()>:
  
    DBIc_NUM_PARAMS(imp_sth) = ...
  
  If you can, you should also setup attributes like I<NUM_OF_FIELDS>, I<NAME>,
  etc. here, but B<DBI> doesn't require that - they can be deferred until
  execute() is called. However, if you do, document it.
  
  In any case you should set the I<IMPSET> flag, as you did in
  C<dbd_db_connect()> above:
  
    DBIc_IMPSET_on(imp_sth);
  
  =head3 The dbd_st_execute method
  
  This is where a statement will really be executed.
  
    int dbd_st_execute(SV* sth, imp_sth_t* imp_sth);
  
  Note that you must be aware a statement may be executed repeatedly.
  Also, you should not expect that C<finish()> will be called between two
  executions, so you might need code, like the following, near the start
  of the function:
  
    if (DBIc_ACTIVE(imp_sth))
        dbd_st_finish(h, imp_sth);
  
  If your driver supports the binding of parameters (it should!), but the
  database doesn't, you must do it here. This can be done as follows:
  
    SV *svp;
    char* statement = DBD_ATTRIB_GET_PV(h, "Statement", 9, svp, "");
    int numParam = DBIc_NUM_PARAMS(imp_sth);
    int i;
  
    for (i = 0; i < numParam; i++)
    {
        char* value = dbd_db_get_param(sth, imp_sth, i);
        /* It is your drivers task to implement dbd_db_get_param,    */
        /* it must be setup as a counterpart of dbd_bind_ph.         */
        /* Look for '?' and replace it with 'value'.  Difficult      */
        /* task, note that you may have question marks inside        */
        /* quotes and comments the like ...  :-(                     */
        /* See DBD::mysql for an example. (Don't look too deep into  */
        /* the example, you will notice where I was lazy ...)        */
    }
  
  The next thing is to really execute the statement.
  
  Note that you must set the attributes I<NUM_OF_FIELDS>, I<NAME>, etc
  when the statement is successfully executed if the driver has not
  already done so: they may be used even before a potential C<fetchrow()>.
  In particular you have to tell B<DBI> the number of fields that the
  statement has, because it will be used by B<DBI> internally. Thus the
  function will typically ends with:
  
    if (isSelectStatement) {
        DBIc_NUM_FIELDS(imp_sth) = numFields;
        DBIc_ACTIVE_on(imp_sth);
    }
  
  It is important that the I<ACTIVE> flag only be set for C<SELECT>
  statements (or any other statements that can return many
  values from the database using a cursor-like mechanism). See
  C<dbd_db_connect()> above for more explanations.
  
  There plans for a preparse function to be provided by B<DBI>, but this has
  not reached fruition yet.
  Meantime, if you want to know how ugly it can get, try looking at the
  C<dbd_ix_preparse()> in B<DBD::Informix> F<dbdimp.ec> and the related
  functions in F<iustoken.c> and F<sqltoken.c>.
  
  =head3 The dbd_st_fetch method
  
  This function fetches a row of data. The row is stored in in an array,
  of C<SV>'s that B<DBI> prepares for you. This has two advantages: it is fast
  (you even reuse the C<SV>'s, so they don't have to be created after the
  first C<fetchrow()>), and it guarantees that B<DBI> handles C<bind_cols()> for
  you.
  
  What you do is the following:
  
    AV* av;
    int numFields = DBIc_NUM_FIELDS(imp_sth); /* Correct, if NUM_FIELDS
        is constant for this statement. There are drivers where this is
        not the case! */
    int chopBlanks = DBIc_is(imp_sth, DBIcf_ChopBlanks);
    int i;
  
    if (!fetch_new_row_of_data(...)) {
        ... /* check for error or end-of-data */
        DBIc_ACTIVE_off(imp_sth); /* turn off Active flag automatically */
        return Nullav;
    }
    /* get the fbav (field buffer array value) for this row       */
    /* it is very important to only call this after you know      */
    /* that you have a row of data to return.                     */
    av = DBIc_DBISTATE(imp_sth)->get_fbav(imp_sth);
    for (i = 0; i < numFields; i++) {
        SV* sv = fetch_a_field(..., i);
        if (chopBlanks && SvOK(sv) && type_is_blank_padded(field_type[i])) {
            /*  Remove white space from end (only) of sv  */
        }
        sv_setsv(AvARRAY(av)[i], sv); /* Note: (re)use! */
    }
    return av;
  
  There's no need to use a C<fetch_a_field()> function returning an C<SV*>.
  It's more common to use your database API functions to fetch the
  data as character strings and use code like this:
  
    sv_setpvn(AvARRAY(av)[i], char_ptr, char_count);
  
  C<NULL> values must be returned as C<undef>. You can use code like this:
  
    SvOK_off(AvARRAY(av)[i]);
  
  The function returns the C<AV> prepared by B<DBI> for success or C<Nullav>
  otherwise.
  
   *FIX ME* Discuss what happens when there's no more data to fetch.
   Are errors permitted if another fetch occurs after the first fetch
   that reports no more data. (Permitted, not required.)
  
  If an error occurs which leaves the I<$sth> in a state where remaining
  rows can't be fetched then I<Active> should be turned off before the
  method returns.
  
  =head3 The dbd_st_finish3 method
  
  The C<$sth-E<gt>finish()> method can be called if the user wishes to
  indicate that no more rows will be fetched even if the database has more
  rows to offer, and the B<DBI> code can call the function when handles are
  being destroyed. See the B<DBI> specification for more background details.
  
  In both circumstances, the B<DBI> code ends up calling the
  C<dbd_st_finish3()> method (if you provide a mapping for
  C<dbd_st_finish3()> in F<dbdimp.h>), or C<dbd_st_finish()> otherwise.
  The difference is that C<dbd_st_finish3()> takes a third argument which
  is an C<int> with the value 1 if it is being called from a C<destroy()>
  method and 0 otherwise.
  
  Note that B<DBI> v1.32 and earlier test on C<dbd_db_finish3()> to call
  C<dbd_st_finish3()>; if you provide C<dbd_st_finish3()>, either define
  C<dbd_db_finish3()> too, or insist on B<DBI> v1.33 or later.
  
  All it I<needs> to do is turn off the I<Active> flag for the I<sth>.
  It will only be called by F<Driver.xst> code, if the driver has set I<ACTIVE>
  to on for the I<sth>.
  
  Outline example:
  
    int dbd_st_finish3(SV* sth, imp_sth_t* imp_sth, int from_destroy) {
        if (DBIc_ACTIVE(imp_sth))
        {
            /* close cursor or equivalent action */
            DBIc_ACTIVE_off(imp_sth);
        }
        return 1;
    }
  
  The from_destroy parameter is true if C<dbd_st_finish3()> is being called
  from C<DESTROY()> - and so the statement is about to be destroyed.
  For many drivers there is no point in doing anything more than turning off
  the I<Active> flag in this case.
  
  The function returns I<TRUE> for success, I<FALSE> otherwise, but there isn't
  a lot anyone can do to recover if there is an error.
  
  =head3 The dbd_st_destroy method
  
  This function is the private part of the statement handle destructor.
  
    void dbd_st_destroy(SV* sth, imp_sth_t* imp_sth) {
        ... /* any clean-up that's needed */
        DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it   */
    }
  
  The B<DBI> F<Driver.xst> code will call C<dbd_st_finish()> for you, if the
  I<sth> has the I<ACTIVE> flag set, before calling C<dbd_st_destroy()>.
  
  =head3 The dbd_st_STORE_attrib and dbd_st_FETCH_attrib methods
  
  These functions correspond to C<dbd_db_STORE()> and C<dbd_db_FETCH()> attrib
  above, except that they are for statement handles.
  See above.
  
    int dbd_st_STORE_attrib(SV* sth, imp_sth_t* imp_sth, SV* keysv,
                            SV* valuesv);
    SV* dbd_st_FETCH_attrib(SV* sth, imp_sth_t* imp_sth, SV* keysv);
  
  =head3 The dbd_bind_ph method
  
  This function is internally used by the C<bind_param()> method, the
  C<bind_param_inout()> method and by the B<DBI> F<Driver.xst> code if
  C<execute()> is called with any bind parameters.
  
    int dbd_bind_ph (SV *sth, imp_sth_t *imp_sth, SV *param,
                     SV *value, IV sql_type, SV *attribs,
                     int is_inout, IV maxlen);
  
  The I<param> argument holds an C<IV> with the parameter number (1, 2, ...).
  The I<value> argument is the parameter value and I<sql_type> is its type.
  
  If your driver does not support C<bind_param_inout()> then you should
  ignore I<maxlen> and croak if I<is_inout> is I<TRUE>.
  
  If your driver I<does> support C<bind_param_inout()> then you should
  note that I<value> is the C<SV> I<after> dereferencing the reference
  passed to C<bind_param_inout()>.
  
  In drivers of simple databases the function will, for example, store
  the value in a parameter array and use it later in C<dbd_st_execute()>.
  See the B<DBD::mysql> driver for an example.
  
  =head3 Implementing bind_param_inout support
  
  To provide support for parameters bound by reference rather than by
  value, the driver must do a number of things.  First, and most
  importantly, it must note the references and stash them in its own
  driver structure.  Secondly, when a value is bound to a column, the
  driver must discard any previous reference bound to the column.  On
  each execute, the driver must evaluate the references and internally
  bind the values resulting from the references.  This is only applicable
  if the user writes:
  
    $sth->execute;
  
  If the user writes:
  
    $sth->execute(@values);
  
  then B<DBI> automatically calls the binding code for each element of
  I<@values>.  These calls are indistinguishable from explicit user calls to
  C<bind_param()>.
  
  =head2 C/XS version of Makefile.PL
  
  The F<Makefile.PL> file for a C/XS driver is similar to the code needed
  for a pure Perl driver, but there are a number of extra bits of
  information needed by the build system.
  
  For example, the attributes list passed to C<WriteMakefile()> needs
  to specify the object files that need to be compiled and built into
  the shared object (DLL). This is often, but not necessarily, just
  F<dbdimp.o> (unless that should be F<dbdimp.obj> because you're building
  on MS Windows).
  
  Note that you can reliably determine the extension of the object files
  from the I<$Config{obj_ext}> values, and there are many other useful pieces
  of configuration information lurking in that hash.
  You get access to it with:
  
      use Config;
  
  =head2 Methods which do not need to be written
  
  The B<DBI> code implements the majority of the methods which are accessed
  using the notation C<DBI-E<gt>function()>, the only exceptions being
  C<DBI-E<gt>connect()> and C<DBI-E<gt>data_sources()> which require
  support from the driver.
  
  The B<DBI> code implements the following documented driver, database and
  statement functions which do not need to be written by the B<DBD> driver
  writer.
  
  =over 4
  
  =item $dbh->do()
  
  The default implementation of this function prepares, executes and
  destroys the statement.  This can be replaced if there is a better
  way to implement this, such as C<EXECUTE IMMEDIATE> which can
  sometimes be used if there are no parameters.
  
  =item $h->errstr()
  
  =item $h->err()
  
  =item $h->state()
  
  =item $h->trace()
  
  The B<DBD> driver does not need to worry about these routines at all.
  
  =item $h->{ChopBlanks}
  
  This attribute needs to be honored during C<fetch()> operations, but does
  not need to be handled by the attribute handling code.
  
  =item $h->{RaiseError}
  
  The B<DBD> driver does not need to worry about this attribute at all.
  
  =item $h->{PrintError}
  
  The B<DBD> driver does not need to worry about this attribute at all.
  
  =item $sth->bind_col()
  
  Assuming the driver uses the C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()>
  function (C drivers, see below), or the C<$sth-E<gt>_set_fbav($data)>
  method (Perl drivers) the driver does not need to do anything about this
  routine.
  
  =item $sth->bind_columns()
  
  Regardless of whether the driver uses
  C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()>, the driver does not need
  to do anything about this routine as it simply iteratively calls
  C<$sth-E<gt>bind_col()>.
  
  =back
  
  The B<DBI> code implements a default implementation of the following
  functions which do not need to be written by the B<DBD> driver writer
  unless the default implementation is incorrect for the Driver.
  
  =over 4
  
  =item $dbh->quote()
  
  This should only be written if the database does not accept the ANSI
  SQL standard for quoting strings, with the string enclosed in single
  quotes and any embedded single quotes replaced by two consecutive
  single quotes.
  
  For the two argument form of quote, you need to implement the
  C<type_info()> method to provide the information that quote needs.
  
  =item $dbh->ping()
  
  This should be implemented as a simple efficient way to determine
  whether the connection to the database is still alive. Typically
  code like this:
  
    sub ping {
        my $dbh = shift;
        $sth = $dbh->prepare_cached(q{
            select * from A_TABLE_NAME where 1=0
        }) or return 0;
        $sth->execute or return 0;
        $sth->finish;
        return 1;
    }
  
  where I<A_TABLE_NAME> is the name of a table that always exists (such as a
  database system catalogue).
  
  =back
  
  =head1 METADATA METHODS
  
  The exposition above ignores the B<DBI> MetaData methods.
  The metadata methods are all associated with a database handle.
  
  =head2 Using DBI::DBD::Metadata
  
  The B<DBI::DBD::Metadata> module is a good semi-automatic way for the
  developer of a B<DBD> module to write the C<get_info()> and C<type_info()>
  functions quickly and accurately.
  
  =head3 Generating the get_info method
  
  Prior to B<DBI> v1.33, this existed as the method C<write_getinfo_pm()>
  in the B<DBI::DBD> module. From B<DBI> v1.33, it exists as the method
  C<write_getinfo_pm()> in the B<DBI::DBD::Metadata> module. This
  discussion assumes you have B<DBI> v1.33 or later.
  
  You examine the documentation for C<write_getinfo_pm()> using:
  
      perldoc DBI::DBD::Metadata
  
  To use it, you need a Perl B<DBI> driver for your database which implements
  the C<get_info()> method. In practice, this means you need to install
  B<DBD::ODBC>, an ODBC driver manager, and an ODBC driver for your
  database.
  
  With the pre-requisites in place, you might type:
  
      perl -MDBI::DBD::Metadata -we \
         "write_getinfo_pm (qw{ dbi:ODBC:foo_db username password Driver })"
  
  The procedure writes to standard output the code that should be added to
  your F<Driver.pm> file and the code that should be written to
  F<lib/DBD/Driver/GetInfo.pm>.
  
  You should review the output to ensure that it is sensible.
  
  =head3 Generating the type_info method
  
  Given the idea of the C<write_getinfo_pm()> method, it was not hard
  to devise a parallel method, C<write_typeinfo_pm()>, which does the
  analogous job for the B<DBI> C<type_info_all()> metadata method. The
  C<write_typeinfo_pm()> method was added to B<DBI> v1.33.
  
  You examine the documentation for C<write_typeinfo_pm()> using:
  
      perldoc DBI::DBD::Metadata
  
  The setup is exactly analogous to the mechanism described in
  L</Generating the get_info method>.
  
  With the pre-requisites in place, you might type:
  
      perl -MDBI::DBD::Metadata -we \
         "write_typeinfo (qw{ dbi:ODBC:foo_db username password Driver })"
  
  The procedure writes to standard output the code that should be added to
  your F<Driver.pm> file and the code that should be written to
  F<lib/DBD/Driver/TypeInfo.pm>.
  
  You should review the output to ensure that it is sensible.
  
  =head2 Writing DBD::Driver::db::get_info
  
  If you use the B<DBI::DBD::Metadata> module, then the code you need is
  generated for you.
  
  If you decide not to use the B<DBI::DBD::Metadata> module, you
  should probably borrow the code from a driver that has done so (eg
  B<DBD::Informix> from version 1.05 onwards) and crib the code from
  there, or look at the code that generates that module and follow
  that. The method in F<Driver.pm> will be very simple; the method in
  F<lib/DBD/Driver/GetInfo.pm> is not very much more complex unless your
  DBMS itself is much more complex.
  
  Note that some of the B<DBI> utility methods rely on information from the
  C<get_info()> method to perform their operations correctly. See, for
  example, the C<quote_identifier()> and quote methods, discussed below.
  
  =head2 Writing DBD::Driver::db::type_info_all
  
  If you use the C<DBI::DBD::Metadata> module, then the code you need is
  generated for you.
  
  If you decide not to use the C<DBI::DBD::Metadata> module, you
  should probably borrow the code from a driver that has done so (eg
  C<DBD::Informix> from version 1.05 onwards) and crib the code from
  there, or look at the code that generates that module and follow
  that. The method in F<Driver.pm> will be very simple; the method in
  F<lib/DBD/Driver/TypeInfo.pm> is not very much more complex unless your
  DBMS itself is much more complex.
  
  =head2 Writing DBD::Driver::db::type_info
  
  The guidelines on writing this method are still not really clear.
  No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::table_info
  
   *FIX ME* The guidelines on writing this method have not been written yet.
   No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::column_info
  
   *FIX ME* The guidelines on writing this method have not been written yet.
   No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::primary_key_info
  
   *FIX ME* The guidelines on writing this method have not been written yet.
   No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::primary_key
  
   *FIX ME* The guidelines on writing this method have not been written yet.
   No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::foreign_key_info
  
   *FIX ME* The guidelines on writing this method have not been written yet.
   No sample implementation is available.
  
  =head2 Writing DBD::Driver::db::tables
  
  This method generates an array of names in a format suitable for being
  embedded in SQL statements in places where a table name is expected.
  
  If your database hews close enough to the SQL standard or if you have
  implemented an appropriate C<table_info()> function and and the appropriate
  C<quote_identifier()> function, then the B<DBI> default version of this method
  will work for your driver too.
  
  Otherwise, you have to write a function yourself, such as:
  
      sub tables
      {
          my($dbh, $cat, $sch, $tab, $typ) = @_;
          my(@res);
          my($sth) = $dbh->table_info($cat, $sch, $tab, $typ);
          my(@arr);
          while (@arr = $sth->fetchrow_array)
          {
              push @res, $dbh->quote_identifier($arr[0], $arr[1], $arr[2]);
          }
          return @res;
      }
  
  See also the default implementation in F<DBI.pm>.
  
  =head2 Writing DBD::Driver::db::quote
  
  This method takes a value and converts it into a string suitable for
  embedding in an SQL statement as a string literal.
  
  If your DBMS accepts the SQL standard notation for strings (single
  quotes around the string as a whole with any embedded single quotes
  doubled up), then you do not need to write this method as B<DBI> provides a
  default method that does it for you.
  
  If your DBMS uses an alternative notation or escape mechanism, then you
  need to provide an equivalent function. For example, suppose your DBMS
  used C notation with double quotes around the string and backslashes
  escaping both double quotes and backslashes themselves. Then you might
  write the function as:
  
      sub quote
      {
          my($dbh, $str) = @_;
          $str =~ s/["\\]/\\$&/gmo;
          return qq{"$str"};
      }
  
  Handling newlines and other control characters is left as an exercise
  for the reader.
  
  This sample method ignores the I<$data_type> indicator which is the
  optional second argument to the method.
  
  =head2 Writing DBD::Driver::db::quote_identifier
  
  This method is called to ensure that the name of the given table (or
  other database object) can be embedded into an SQL statement without
  danger of misinterpretation. The result string should be usable in the
  text of an SQL statement as the identifier for a table.
  
  If your DBMS accepts the SQL standard notation for quoted identifiers
  (which uses double quotes around the identifier as a whole, with any
  embedded double quotes doubled up) and accepts I<"schema"."identifier">
  (and I<"catalog"."schema"."identifier"> when a catalog is specified), then
  you do not need to write this method as B<DBI> provides a default method
  that does it for you.
  
  In fact, even if your DBMS does not handle exactly that notation but
  you have implemented the C<get_info()> method and it gives the correct
  responses, then it will work for you. If your database is fussier, then
  you need to implement your own version of the function.
  
  For example, B<DBD::Informix> has to deal with an environment variable
  I<DELIMIDENT>. If it is not set, then the DBMS treats names enclosed in
  double quotes as strings rather than names, which is usually a syntax
  error. Additionally, the catalog portion of the name is separated from
  the schema and table by a different delimiter (colon instead of dot),
  and the catalog portion is never enclosed in quotes. (Fortunately,
  valid strings for the catalog will never contain weird characters that
  might need to be escaped, unless you count dots, dashes, slashes and
  at-signs as weird.) Finally, an Informix database can contain objects
  that cannot be accessed because they were created by a user with the
  I<DELIMIDENT> environment variable set, but the current user does not
  have it set. By design choice, the C<quote_identifier()> method encloses
  those identifiers in double quotes anyway, which generally triggers a
  syntax error, and the metadata methods which generate lists of tables
  etc omit those identifiers from the result sets.
  
      sub quote_identifier
      {
          my($dbh, $cat, $sch, $obj) = @_;
          my($rv) = "";
          my($qq) = (defined $ENV{DELIMIDENT}) ? '"' : '';
          $rv .= qq{$cat:} if (defined $cat);
          if (defined $sch)
          {
              if ($sch !~ m/^\w+$/o)
              {
                  $qq = '"';
                  $sch =~ s/$qq/$qq$qq/gm;
              }
              $rv .= qq{$qq$sch$qq.};
          }
          if (defined $obj)
          {
              if ($obj !~ m/^\w+$/o)
              {
                  $qq = '"';
                  $obj =~ s/$qq/$qq$qq/gm;
              }
              $rv .= qq{$qq$obj$qq};
          }
          return $rv;
      }
  
  Handling newlines and other control characters is left as an exercise
  for the reader.
  
  Note that there is an optional fourth parameter to this function which
  is a reference to a hash of attributes; this sample implementation
  ignores that.
  
  This sample implementation also ignores the single-argument variant of
  the method.
  
  =head1 TRACING
  
  Tracing in DBI is controlled with a combination of a trace level and a
  set of flags which together are known as the trace settings. The trace
  settings are stored in a single integer and divided into levels and
  flags by a set of masks (C<DBIc_TRACE_LEVEL_MASK> and
  C<DBIc_TRACE_FLAGS_MASK>).
  
  Each handle has it's own trace settings and so does the DBI. When you
  call a method the DBI merges the handles settings into its own for the
  duration of the call: the trace flags of the handle are OR'd into the
  trace flags of the DBI, and if the handle has a higher trace level
  then the DBI trace level is raised to match it. The previous DBI trace
  setings are restored when the called method returns.
  
  =head2 Trace Level
  
  The trace level is the first 4 bits of the trace settings (masked by
  C<DBIc_TRACE_FLAGS_MASK>) and represents trace levels of 1 to 15. Do
  not output anything at trace levels less than 3 as they are reserved
  for DBI.
  
  For advice on what to output at each level see "Trace Levels" in
  L<DBI>.
  
  To test for a trace level you can use the C<DBIc_TRACE_LEVEL> macro
  like this:
  
    if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) {
        PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar");
    }
  
  Also B<note> the use of PerlIO_printf which you should always use for
  tracing and never the C C<stdio.h> I/O functions.
  
  =head2 Trace Flags
  
  Trace flags are used to enable tracing of specific activities within
  the DBI and drivers. The DBI defines some trace flags and drivers can
  define others. DBI trace flag names begin with a capital letter and
  driver specific names begin with a lowercase letter. For a list of DBI
  defined trace flags see "Trace Flags" in L<DBI>.
  
  If you want to use private trace flags you'll probably want to be able
  to set them by name. Drivers are expected to override the
  parse_trace_flag (note the singular) and check if $trace_flag_name is
  a driver specific trace flags and, if not, then call the DBIs default
  parse_trace_flag(). To do that you'll need to define a
  parse_trace_flag() method like this:
  
    sub parse_trace_flag {
        my ($h, $name) = @_;
        return 0x01000000 if $name eq 'foo';
        return 0x02000000 if $name eq 'bar';
        return 0x04000000 if $name eq 'baz';
        return 0x08000000 if $name eq 'boo';
        return 0x10000000 if $name eq 'bop';
        return $h->SUPER::parse_trace_flag($name);
    }
  
  All private flag names must be lowercase, and all private flags must
  be in the top 8 of the 32 bits of C<DBIc_TRACE_FLAGS(imp)> i.e.,
  0xFF000000.
  
  If you've defined a parse_trace_flag() method in ::db you'll also want
  it in ::st, so just alias it in:
  
    *parse_trace_flag = \&DBD::foo:db::parse_trace_flag;
  
  You may want to act on the current 'SQL' trace flag that DBI defines
  to output SQL prepared/executed as DBI currently does not do SQL
  tracing.
  
  =head2 Trace Macros
  
  Access to the trace level and trace flags is via a set of macros.
  
    DBIc_TRACE_SETTINGS(imp) returns the trace settings
    DBIc_TRACE_LEVEL(imp) returns the trace level
    DBIc_TRACE_FLAGS(imp) returns the trace flags
    DBIc_TRACE(imp, flags, flaglevel, level)
  
    e.g.,
  
    DBIc_TRACE(imp, 0, 0, 4)
      if level >= 4
  
    DBIc_TRACE(imp, DBDtf_FOO, 2, 4)
      if tracing DBDtf_FOO & level>=2 or level>=4
  
    DBIc_TRACE(imp, DBDtf_FOO, 2, 0)
      as above but never trace just due to level
  
  =head1 WRITING AN EMULATION LAYER FOR AN OLD PERL INTERFACE
  
  Study F<Oraperl.pm> (supplied with B<DBD::Oracle>) and F<Ingperl.pm> (supplied
  with B<DBD::Ingres>) and the corresponding I<dbdimp.c> files for ideas.
  
  Note that the emulation code sets C<$dbh-E<gt>{CompatMode} = 1;> for each
  connection so that the internals of the driver can implement behaviour
  compatible with the old interface when dealing with those handles.
  
  =head2 Setting emulation perl variables
  
  For example, ingperl has a I<$sql_rowcount> variable. Rather than try
  to manually update this in F<Ingperl.pm> it can be done faster in C code.
  In C<dbd_init()>:
  
    sql_rowcount = perl_get_sv("Ingperl::sql_rowcount", GV_ADDMULTI);
  
  In the relevant places do:
  
    if (DBIc_COMPAT(imp_sth))     /* only do this for compatibility mode handles */
        sv_setiv(sql_rowcount, the_row_count);
  
  =head1 OTHER MISCELLANEOUS INFORMATION
  
  =head2 The imp_xyz_t types
  
  Any handle has a corresponding C structure filled with private data.
  Some of this data is reserved for use by B<DBI> (except for using the
  DBIc macros below), some is for you. See the description of the
  F<dbdimp.h> file above for examples. Most functions in F<dbdimp.c>
  are passed both the handle C<xyz> and a pointer to C<imp_xyz>. In
  rare cases, however, you may use the following macros:
  
  =over 4
  
  =item D_imp_dbh(dbh)
  
  Given a function argument I<dbh>, declare a variable I<imp_dbh> and
  initialize it with a pointer to the handles private data. Note: This
  must be a part of the function header, because it declares a variable.
  
  =item D_imp_sth(sth)
  
  Likewise for statement handles.
  
  =item D_imp_xxx(h)
  
  Given any handle, declare a variable I<imp_xxx> and initialize it
  with a pointer to the handles private data. It is safe, for example,
  to cast I<imp_xxx> to C<imp_dbh_t*>, if C<DBIc_TYPE(imp_xxx) == DBIt_DB>.
  (You can also call C<sv_derived_from(h, "DBI::db")>, but that's much
  slower.)
  
  =item D_imp_dbh_from_sth
  
  Given a I<imp_sth>, declare a variable I<imp_dbh> and initialize it with a
  pointer to the parent database handle's implementors structure.
  
  =back
  
  =head2 Using DBIc_IMPSET_on
  
  The driver code which initializes a handle should use C<DBIc_IMPSET_on()>
  as soon as its state is such that the cleanup code must be called.
  When this happens is determined by your driver code.
  
  B<Failure to call this can lead to corruption of data structures.>
  
  For example, B<DBD::Informix> maintains a linked list of database
  handles in the driver, and within each handle, a linked list of
  statements. Once a statement is added to the linked list, it is crucial
  that it is cleaned up (removed from the list). When I<DBIc_IMPSET_on()>
  was being called too late, it was able to cause all sorts of problems.
  
  =head2 Using DBIc_is(), DBIc_has(), DBIc_on() and DBIc_off()
  
  Once upon a long time ago, the only way of handling the internal B<DBI>
  boolean flags/attributes was through macros such as:
  
    DBIc_WARN       DBIc_WARN_on        DBIc_WARN_off
    DBIc_COMPAT     DBIc_COMPAT_on      DBIc_COMPAT_off
  
  Each of these took an I<imp_xxh> pointer as an argument.
  
  Since then, new attributes have been added such as I<ChopBlanks>,
  I<RaiseError> and I<PrintError>, and these do not have the full set of
  macros. The approved method for handling these is now the four macros:
  
    DBIc_is(imp, flag)
    DBIc_has(imp, flag)       an alias for DBIc_is
    DBIc_on(imp, flag)
    DBIc_off(imp, flag)
    DBIc_set(imp, flag, on)   set if on is true, else clear
  
  Consequently, the C<DBIc_XXXXX> family of macros is now mostly deprecated
  and new drivers should avoid using them, even though the older drivers
  will probably continue to do so for quite a while yet. However...
  
  There is an I<important exception> to that. The I<ACTIVE> and I<IMPSET>
  flags should be set via the C<DBIc_ACTIVE_on()> and C<DBIc_IMPSET_on()> macros,
  and unset via the C<DBIc_ACTIVE_off()> and C<DBIc_IMPSET_off()> macros.
  
  =head2 Using the get_fbav() method
  
  B<THIS IS CRITICAL for C/XS drivers>.
  
  The C<$sth-E<gt>bind_col()> and C<$sth-E<gt>bind_columns()> documented
  in the B<DBI> specification do not have to be implemented by the driver
  writer because B<DBI> takes care of the details for you.
  
  However, the key to ensuring that bound columns work is to call the
  function C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()> in the code which
  fetches a row of data.
  
  This returns an C<AV>, and each element of the C<AV> contains the C<SV> which
  should be set to contain the returned data.
  
  The pure Perl equivalent is the C<$sth-E<gt>_set_fbav($data)> method, as
  described in the part on pure Perl drivers.
  
  =head2 Casting strings to Perl types based on a SQL type
  
  DBI from 1.611 (and DBIXS_REVISION 13606) defines the
  sql_type_cast_svpv method which may be used to cast a string
  representation of a value to a more specific Perl type based on a SQL
  type. You should consider using this method when processing bound
  column data as it provides some support for the TYPE bind_col
  attribute which is rarely used in drivers.
  
    int sql_type_cast_svpv(pTHX_ SV *sv, int sql_type, U32 flags, void *v)
  
  C<sv> is what you would like cast, C<sql_type> is one of the DBI defined
  SQL types (e.g., C<SQL_INTEGER>) and C<flags> is a bitmask as follows:
  
  =over
  
  =item DBIstcf_STRICT
  
  If set this indicates you want an error state returned if the cast
  cannot be performed.
  
  =item DBIstcf_DISCARD_STRING
  
  If set and the pv portion of the C<sv> is cast then this will cause
  sv's pv to be freed up.
  
  =back
  
  sql_type_cast_svpv returns the following states:
  
   -2 sql_type is not handled - sv not changed
   -1 sv is undef, sv not changed
    0 sv could not be cast cleanly and DBIstcf_STRICT was specified
    1 sv could not be case cleanly and DBIstcf_STRICT was not specified
    2 sv was cast ok
  
  The current implementation of sql_type_cast_svpv supports
  C<SQL_INTEGER>, C<SQL_DOUBLE> and C<SQL_NUMERIC>. C<SQL_INTEGER> uses
  sv_2iv and hence may set IV, UV or NV depending on the
  number. C<SQL_DOUBLE> uses sv_2nv so may set NV and C<SQL_NUMERIC>
  will set IV or UV or NV.
  
  DBIstcf_STRICT should be implemented as the StrictlyTyped attribute
  and DBIstcf_DISCARD_STRING implemented as the DiscardString attribute
  to the bind_col method and both default to off.
  
  See DBD::Oracle for an example of how this is used.
  
  =head1 SUBCLASSING DBI DRIVERS
  
  This is definitely an open subject. It can be done, as demonstrated by
  the B<DBD::File> driver, but it is not as simple as one might think.
  
  (Note that this topic is different from subclassing the B<DBI>. For an
  example of that, see the F<t/subclass.t> file supplied with the B<DBI>.)
  
  The main problem is that the I<dbh>'s and I<sth>'s that your C<connect()> and
  C<prepare()> methods return are not instances of your B<DBD::Driver::db>
  or B<DBD::Driver::st> packages, they are not even derived from it.
  Instead they are instances of the B<DBI::db> or B<DBI::st> classes or
  a derived subclass. Thus, if you write a method C<mymethod()> and do a
  
    $dbh->mymethod()
  
  then the autoloader will search for that method in the package B<DBI::db>.
  Of course you can instead to a
  
    $dbh->func('mymethod')
  
  and that will indeed work, even if C<mymethod()> is inherited, but not
  without additional work. Setting I<@ISA> is not sufficient.
  
  =head2 Overwriting methods
  
  The first problem is, that the C<connect()> method has no idea of
  subclasses. For example, you cannot implement base class and subclass
  in the same file: The C<install_driver()> method wants to do a
  
    require DBD::Driver;
  
  In particular, your subclass B<has> to be a separate driver, from
  the view of B<DBI>, and you cannot share driver handles.
  
  Of course that's not much of a problem. You should even be able
  to inherit the base classes C<connect()> method. But you cannot
  simply overwrite the method, unless you do something like this,
  quoted from B<DBD::CSV>:
  
    sub connect ($$;$$$) {
        my ($drh, $dbname, $user, $auth, $attr) = @_;
  
        my $this = $drh->DBD::File::dr::connect($dbname, $user, $auth, $attr);
        if (!exists($this->{csv_tables})) {
            $this->{csv_tables} = {};
        }
  
        $this;
    }
  
  Note that we cannot do a
  
    $drh->SUPER::connect($dbname, $user, $auth, $attr);
  
  as we would usually do in a an OO environment, because I<$drh> is an instance
  of B<DBI::dr>. And note, that the C<connect()> method of B<DBD::File> is
  able to handle subclass attributes. See the description of Pure Perl
  drivers above.
  
  It is essential that you always call superclass method in the above
  manner. However, that should do.
  
  =head2 Attribute handling
  
  Fortunately the B<DBI> specifications allow a simple, but still
  performant way of handling attributes. The idea is based on the
  convention that any driver uses a prefix I<driver_> for its private
  methods. Thus it's always clear whether to pass attributes to the super
  class or not. For example, consider this C<STORE()> method from the
  B<DBD::CSV> class:
  
    sub STORE {
        my ($dbh, $attr, $val) = @_;
        if ($attr !~ /^driver_/) {
            return $dbh->DBD::File::db::STORE($attr, $val);
        }
        if ($attr eq 'driver_foo') {
        ...
    }
  
  =cut
  
  use Exporter ();
  use Config qw(%Config);
  use Carp;
  use Cwd;
  use File::Spec;
  use strict;
  use vars qw(
      @ISA @EXPORT
      $is_dbi
  );
  
  BEGIN {
      if ($^O eq 'VMS') {
  	require vmsish;
  	import  vmsish;
  	require VMS::Filespec;
  	import  VMS::Filespec;
      }
      else {
  	*vmsify  = sub { return $_[0] };
  	*unixify = sub { return $_[0] };
      }
  }
  
  @ISA = qw(Exporter);
  
  @EXPORT = qw(
      dbd_dbi_dir
      dbd_dbi_arch_dir
      dbd_edit_mm_attribs
      dbd_postamble
  );
  
  BEGIN {
      $is_dbi = (-r 'DBI.pm' && -r 'DBI.xs' && -r 'DBIXS.h');
      require DBI unless $is_dbi;
  }
  
  my $done_inst_checks;
  
  sub _inst_checks {
      return if $done_inst_checks++;
      my $cwd = cwd();
      if ($cwd =~ /\Q$Config{path_sep}/) {
  	warn "*** Warning: Path separator characters (`$Config{path_sep}') ",
  	    "in the current directory path ($cwd) may cause problems\a\n\n";
          sleep 2;
      }
      if ($cwd =~ /\s/) {
  	warn "*** Warning: whitespace characters ",
  	    "in the current directory path ($cwd) may cause problems\a\n\n";
          sleep 2;
      }
      if (   $^O eq 'MSWin32'
  	&& $Config{cc} eq 'cl'
  	&& !(exists $ENV{'LIB'} && exists $ENV{'INCLUDE'}))
      {
  	die <<EOT;
  *** You're using Microsoft Visual C++ compiler or similar but
      the LIB and INCLUDE environment variables are not both set.
  
      You need to run the VCVARS32.BAT batch file that was supplied
      with the compiler before you can use it.
  
      A copy of vcvars32.bat can typically be found in the following
      directories under your Visual Studio install directory:
          Visual C++ 6.0:     vc98\\bin
          Visual Studio .NET: vc7\\bin
  
      Find it, run it, then retry this.
  
      If you think this error is not correct then just set the LIB and
      INCLUDE environment variables to some value to disable the check.
  EOT
      }
  }
  
  sub dbd_edit_mm_attribs {
      # this both edits the attribs in-place and returns the flattened attribs
      my $mm_attr = shift;
      my $dbd_attr = shift || {};
      croak "dbd_edit_mm_attribs( \%makemaker [, \%other ]): too many parameters"
  	if @_;
      _inst_checks();
  
      # decide what needs doing
  
      # do whatever needs doing
      if ($dbd_attr->{create_pp_tests}) {
  	# XXX need to convert this to work within the generated Makefile
  	# so 'make' creates them and 'make clean' deletes them
  	my %test_variants = (
  	    p => {	name => "DBI::PurePerl",
  			add => [ '$ENV{DBI_PUREPERL} = 2' ],
  	    },
  	    g => {	name => "DBD::Gofer",
  			add => [ q{$ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic'} ],
  	    },
  	    xgp => {	name => "PurePerl & Gofer",
  			add => [ q{$ENV{DBI_PUREPERL} = 2; $ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic'} ],
  	    },
  	#   mx => {	name => "DBD::Multiplex",
  	#               add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Multiplex:';} ],
  	#   }
  	#   px => {	name => "DBD::Proxy",
  	#		need mechanism for starting/stopping the proxy server
  	#		add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Proxy:XXX';} ],
  	#   }
  	);
  
  	opendir DIR, 't' or die "Can't read 't' directory: $!";
  	my @tests = grep { /\.t$/ } readdir DIR;
  	closedir DIR;
  
          while ( my ($v_type, $v_info) = each %test_variants ) {
              printf "Creating test wrappers for $v_info->{name}:\n";
  
              foreach my $test (sort @tests) {
                  next if $test !~ /^\d/;
                  my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 && $Config{useithreads});
                  my $v_test = "t/zv${v_type}_$test";
                  my $v_perl = ($test =~ /taint/) ? "perl -wT" : "perl -w";
  		printf "%s %s\n", $v_test, ($usethr) ? "(use threads)" : "";
  		open PPT, ">$v_test" or warn "Can't create $v_test: $!";
  		print PPT "#!$v_perl\n";
  		print PPT "use threads;\n" if $usethr;
  		print PPT "$_;\n" foreach @{$v_info->{add}};
  		print PPT "require './t/$test'; # or warn \$!;\n";
  		close PPT or warn "Error writing $v_test: $!";
  	    }
  	}
      }
      return %$mm_attr;
  }
  
  sub dbd_dbi_dir {
      _inst_checks();
      return '.' if $is_dbi;
      my $dbidir = $INC{'DBI.pm'} || die "DBI.pm not in %INC!";
      $dbidir =~ s:/DBI\.pm$::;
      return $dbidir;
  }
  
  sub dbd_dbi_arch_dir {
      _inst_checks();
      return '$(INST_ARCHAUTODIR)' if $is_dbi;
      my $dbidir = dbd_dbi_dir();
      my %seen;
      my @try = grep { not $seen{$_}++ } map { vmsify( unixify($_) . "/auto/DBI/" ) } @INC;
      my @xst = grep { -f vmsify( unixify($_) . "/Driver.xst" ) } @try;
      Carp::croak("Unable to locate Driver.xst in @try") unless @xst;
      Carp::carp( "Multiple copies of Driver.xst found in: @xst") if @xst > 1;
      print "Using DBI $DBI::VERSION (for perl $] on $Config{archname}) installed in $xst[0]\n";
      return File::Spec->canonpath($xst[0]);
  }
  
  sub dbd_postamble {
      my $self = shift;
      _inst_checks();
      my $dbi_instarch_dir = ($is_dbi) ? "." : dbd_dbi_arch_dir();
      my $dbi_driver_xst= File::Spec->catfile($dbi_instarch_dir, 'Driver.xst');
      my $xstf_h = File::Spec->catfile($dbi_instarch_dir, 'Driver_xst.h');
  
      # we must be careful of quotes, expecially for Win32 here.
      return '
  # --- This section was generated by DBI::DBD::dbd_postamble()
  DBI_INSTARCH_DIR='.$dbi_instarch_dir.'
  DBI_DRIVER_XST='.$dbi_driver_xst.'
  
  # The main dependancy (technically correct but probably not used)
  $(BASEEXT).c: $(BASEEXT).xsi
  
  # This dependancy is needed since MakeMaker uses the .xs.o rule
  $(BASEEXT)$(OBJ_EXT): $(BASEEXT).xsi
  
  $(BASEEXT).xsi: $(DBI_DRIVER_XST) '.$xstf_h.'
  	$(PERL) -p -e "s/~DRIVER~/$(BASEEXT)/g" $(DBI_DRIVER_XST) > $(BASEEXT).xsi
  
  # ---
  ';
  }
  
  package DBDI; # just to reserve it via PAUSE for the future
  
  1;
  
  __END__
  
  =head1 AUTHORS
  
  Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>),
  Jochen Wiedmann <joe@ispsoft.de>,
  Steffen Goeldner <sgoeldner@cpan.org>,
  and Tim Bunce <dbi-users@perl.org>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_DBD

$fatpacked{"darwin-thread-multi-2level/DBI/DBD/Metadata.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_DBD_METADATA';
  package DBI::DBD::Metadata;
  
  # $Id: Metadata.pm 8696 2007-01-24 23:12:38Z timbo $
  #
  # Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann,
  # Steffen Goeldner and Tim Bunce
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  use Exporter ();
  use Carp;
  
  use DBI;
  use DBI::Const::GetInfoType qw(%GetInfoType);
  
  # Perl 5.005_03 does not recognize 'our'
  @ISA = qw(Exporter);
  @EXPORT = qw(write_getinfo_pm write_typeinfo_pm);
  
  $VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  
  
  use strict;
  
  =head1 NAME
  
  DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods
  
  =head1 SYNOPSIS
  
  The idea is to extract metadata information from a good quality
  ODBC driver and use it to generate code and data to use in your own
  DBI driver for the same database.
  
  For generating code to support the get_info method:
  
    perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
  
    perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver
  
  For generating code to support the type_info method:
  
    perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')"
  
    perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver
  
  Where C<dbi:ODBC:dsn-name> is the connection to use to extract the
  data, and C<Driver> is the name of the driver you want the code
  generated for (the driver name gets embedded into the output in
  many places).
  
  =head1 Generating a GetInfo package for a driver
  
  The C<write_getinfo_pm> in the DBI::DBD::Metadata module generates a
  DBD::Driver::GetInfo package on standard output.
  
  This method generates a DBD::Driver::GetInfo package from the data
  source you specified in the parameter list or in the environment
  variable DBI_DSN.
  DBD::Driver::GetInfo should help a DBD author implementing the DBI
  get_info() method.
  Because you are just creating this package, it's very unlikely that
  DBD::Driver already provides a good implementation for get_info().
  Thus you will probably connect via DBD::ODBC.
  
  Once you are sure that it is producing semi-sane data, you would
  typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and
  then hand edit the result.
  Do not forget to update your Makefile.PL and MANIFEST to include this as
  an extra PM file that should be installed.
  
  If you connect via DBD::ODBC, you should use version 0.38 or greater;
  
  Please take a critical look at the data returned!
  ODBC drivers vary dramatically in their quality.
  
  The generator assumes that most values are static and places these
  values directly in the %info hash.
  A few examples show the use of CODE references and the implementation
  via subroutines.
  It is very likely that you have to write additional subroutines for
  values depending on the session state or server version, e.g.
  SQL_DBMS_VER.
  
  A possible implementation of DBD::Driver::db::get_info() may look like:
  
    sub get_info {
      my($dbh, $info_type) = @_;
      require DBD::Driver::GetInfo;
      my $v = $DBD::Driver::GetInfo::info{int($info_type)};
      $v = $v->($dbh) if ref $v eq 'CODE';
      return $v;
    }
  
  Please replace Driver (or "<foo>") with the name of your driver.
  Note that this stub function is generated for you by write_getinfo_pm
  function, but you must manually transfer the code to Driver.pm.
  
  =cut
  
  sub write_getinfo_pm
  {
      my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
      my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1});
      $driver = "<foo>" unless defined $driver;
  
      print <<PERL;
  
  # Transfer this to ${driver}.pm
  
  # The get_info function was automatically generated by
  # DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
  
  package DBD::${driver}::db;         # This line can be removed once transferred.
  
      sub get_info {
          my(\$dbh, \$info_type) = \@_;
          require DBD::${driver}::GetInfo;
          my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)};
          \$v = \$v->(\$dbh) if ref \$v eq 'CODE';
          return \$v;
      }
  
  # Transfer this to lib/DBD/${driver}/GetInfo.pm
  
  # The \%info hash was automatically generated by
  # DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION.
  
  package DBD::${driver}::GetInfo;
  
  use strict;
  use DBD::${driver};
  
  # Beware: not officially documented interfaces...
  # use DBI::Const::GetInfoType qw(\%GetInfoType);
  # use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues);
  
  my \$sql_driver = '${driver}';
  my \$sql_ver_fmt = '%02d.%02d.%04d';   # ODBC version string: ##.##.#####
  my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION);
  PERL
  
  my $kw_map = 0;
  {
  # Informix CLI (ODBC) v3.81.0000 does not return a list of keywords.
      local $\ = "\n";
      local $, = "\n";
      my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS});
      if ($kw)
      {
          print "\nmy \@Keywords = qw(\n";
          print sort split /,/, $kw;
          print ");\n\n";
          print "sub sql_keywords {\n";
          print q%    return join ',', @Keywords;%;
          print "\n}\n\n";
          $kw_map = 1;
      }
  }
  
      print <<'PERL';
  
  sub sql_data_source_name {
      my $dbh = shift;
      return "dbi:$sql_driver:" . $dbh->{Name};
  }
  
  sub sql_user_name {
      my $dbh = shift;
      # CURRENT_USER is a non-standard attribute, probably undef
      # Username is a standard DBI attribute
      return $dbh->{CURRENT_USER} || $dbh->{Username};
  }
  
  PERL
  
  	print "\nour \%info = (\n";
      foreach my $key (sort keys %GetInfoType)
      {
          my $num = $GetInfoType{$key};
          my $val = eval { $dbh->get_info($num); };
          if ($key eq 'SQL_DATA_SOURCE_NAME') {
              $val = '\&sql_data_source_name';
          }
          elsif ($key eq 'SQL_KEYWORDS') {
              $val = ($kw_map) ? '\&sql_keywords' : 'undef';
          }
          elsif ($key eq 'SQL_DRIVER_NAME') {
              $val = "\$INC{'DBD/$driver.pm'}";
          }
          elsif ($key eq 'SQL_DRIVER_VER') {
              $val = '$sql_driver_ver';
          }
          elsif ($key eq 'SQL_USER_NAME') {
              $val = '\&sql_user_name';
          }
          elsif (not defined $val) {
              $val = 'undef';
          }
          elsif ($val eq '') {
              $val = "''";
          }
          elsif ($val =~ /\D/) {
              $val =~ s/\\/\\\\/g;
              $val =~ s/'/\\'/g;
              $val = "'$val'";
          }
          printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key;
      }
  	print ");\n\n1;\n\n__END__\n";
  }
  
  
  
  =head1 Generating a TypeInfo package for a driver
  
  The C<write_typeinfo_pm> function in the DBI::DBD::Metadata module generates
  on standard output the data needed for a driver's type_info_all method.
  It also provides default implementations of the type_info_all
  method for inclusion in the driver's main implementation file.
  
  The driver parameter is the name of the driver for which the methods
  will be generated; for the sake of examples, this will be "Driver".
  Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn",
  where the odbc_dsn is a DSN for one of the driver's databases.
  The user and pass parameters are the other optional connection
  parameters that will be provided to the DBI connect method.
  
  Once you are sure that it is producing semi-sane data, you would
  typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm,
  and then hand edit the result if necessary.
  Do not forget to update your Makefile.PL and MANIFEST to include this as
  an extra PM file that should be installed.
  
  Please take a critical look at the data returned!
  ODBC drivers vary dramatically in their quality.
  
  The generator assumes that all the values are static and places these
  values directly in the %info hash.
  
  A possible implementation of DBD::Driver::type_info_all() may look like:
  
    sub type_info_all {
      my ($dbh) = @_;
      require DBD::Driver::TypeInfo;
      return [ @$DBD::Driver::TypeInfo::type_info_all ];
    }
  
  Please replace Driver (or "<foo>") with the name of your driver.
  Note that this stub function is generated for you by the write_typeinfo_pm
  function, but you must manually transfer the code to Driver.pm.
  
  =cut
  
  
  # These two are used by fmt_value...
  my %dbi_inv;
  my %sql_type_inv;
  
  #-DEBUGGING-#
  #sub print_hash
  #{
  #   my ($name, %hash) = @_;
  #   print "Hash: $name\n";
  #   foreach my $key (keys %hash)
  #   {
  #       print "$key => $hash{$key}\n";
  #   }
  #}
  #-DEBUGGING-#
  
  sub inverse_hash
  {
      my (%hash) = @_;
      my (%inv);
      foreach my $key (keys %hash)
      {
          my $val = $hash{$key};
          die "Double mapping for key value $val ($inv{$val}, $key)!"
              if (defined $inv{$val});
          $inv{$val} = $key;
      }
      return %inv;
  }
  
  sub fmt_value
  {
      my ($num, $val) = @_;
      if (!defined $val)
      {
          $val = "undef";
      }
      elsif ($val !~ m/^[-+]?\d+$/)
      {
          # All the numbers in type_info_all are integers!
          # Anything that isn't an integer is a string.
          # Ensure that no double quotes screw things up.
          $val =~ s/"/\\"/g if ($val =~ m/"/o);
          $val = qq{"$val"};
      }
      elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/)
      {
          # All numeric...
          $val = $sql_type_inv{$val}
              if (defined $sql_type_inv{$val});
      }
      return $val;
  }
  
  sub write_typeinfo_pm
  {
      my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV;
      my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1});
      $driver = "<foo>" unless defined $driver;
  
      print <<PERL;
  
  # Transfer this to ${driver}.pm
  
  # The type_info_all function was automatically generated by
  # DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
  
  package DBD::${driver}::db;         # This line can be removed once transferred.
  
      sub type_info_all
      {
          my (\$dbh) = \@_;
          require DBD::${driver}::TypeInfo;
          return [ \@\$DBD::${driver}::TypeInfo::type_info_all ];
      }
  
  # Transfer this to lib/DBD/${driver}/TypeInfo.pm.
  # Don't forget to add version and intellectual property control information.
  
  # The \%type_info_all hash was automatically generated by
  # DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION.
  
  package DBD::${driver}::TypeInfo;
  
  {
      require Exporter;
      require DynaLoader;
      \@ISA = qw(Exporter DynaLoader);
      \@EXPORT = qw(type_info_all);
      use DBI qw(:sql_types);
  
  PERL
  
      # Generate SQL type name mapping hashes.
  	# See code fragment in DBI specification.
      my %sql_type_map;
      foreach (@{$DBI::EXPORT_TAGS{sql_types}})
      {
          no strict 'refs';
          $sql_type_map{$_} = &{"DBI::$_"}();
          $sql_type_inv{$sql_type_map{$_}} = $_;
      }
      #-DEBUG-# print_hash("sql_type_map", %sql_type_map);
      #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv);
  
      my %dbi_map =
          (
              TYPE_NAME          =>  0,
              DATA_TYPE          =>  1,
              COLUMN_SIZE        =>  2,
              LITERAL_PREFIX     =>  3,
              LITERAL_SUFFIX     =>  4,
              CREATE_PARAMS      =>  5,
              NULLABLE           =>  6,
              CASE_SENSITIVE     =>  7,
              SEARCHABLE         =>  8,
              UNSIGNED_ATTRIBUTE =>  9,
              FIXED_PREC_SCALE   => 10,
              AUTO_UNIQUE_VALUE  => 11,
              LOCAL_TYPE_NAME    => 12,
              MINIMUM_SCALE      => 13,
              MAXIMUM_SCALE      => 14,
              SQL_DATA_TYPE      => 15,
              SQL_DATETIME_SUB   => 16,
              NUM_PREC_RADIX     => 17,
              INTERVAL_PRECISION => 18,
          );
  
      #-DEBUG-# print_hash("dbi_map", %dbi_map);
  
      %dbi_inv = inverse_hash(%dbi_map);
  
      #-DEBUG-# print_hash("dbi_inv", %dbi_inv);
  
      my $maxlen = 0;
      foreach my $key (keys %dbi_map)
      {
          $maxlen = length($key) if length($key) > $maxlen;
      }
  
      # Print the name/value mapping entry in the type_info_all array;
      my $fmt = "            \%-${maxlen}s => \%2d,\n";
      my $numkey = 0;
      my $maxkey = 0;
      print "    \$type_info_all = [\n        {\n";
      foreach my $i (sort { $a <=> $b } keys %dbi_inv)
      {
          printf($fmt, $dbi_inv{$i}, $i);
          $numkey++;
          $maxkey = $i;
      }
      print "        },\n";
  
      print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n"
          unless $numkey = $maxkey + 1;
  
      my $h = $dbh->type_info_all;
      my @tia = @$h;
      my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]};
      shift @tia;     # Remove the mapping reference.
      my $numtyp = $#tia;
  
      #-DEBUG-# print_hash("odbc_map", %odbc_map);
  
      # In theory, the key/number mapping sequence for %dbi_map
      # should be the same as the one from the ODBC driver.  However, to
      # prevent the possibility of mismatches, and to deal with older
      # missing attributes or unexpected new ones, we chase back through
      # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc
      # to map our new key number to the old one.
      # Report if @dbi_to_odbc is not an identity mapping.
      my @dbi_to_odbc;
      foreach my $num (sort { $a <=> $b } keys %dbi_inv)
      {
          # Find the name in %dbi_inv that matches this index number.
          my $dbi_key = $dbi_inv{$num};
          #-DEBUG-# print "dbi_key = $dbi_key\n";
          #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n";
          # Find the index in %odbc_map that has this key.
          $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef;
      }
  
      # Determine the length of the longest formatted value in each field
      my @len;
      for (my $i = 0; $i <= $numtyp; $i++)
      {
          my @odbc_val = @{$tia[$i]};
          for (my $num = 0; $num <= $maxkey; $num++)
          {
              # Find the value of the entry in the @odbc_val array.
              my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
              $val = fmt_value($num, $val);
              #-DEBUG-# print "val = $val\n";
              $val = "$val,";
              $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num];
          }
      }
  
      # Generate format strings to left justify each string in maximum field width.
      my @fmt;
      for (my $i = 0; $i <= $maxkey; $i++)
      {
          $fmt[$i] = "%-$len[$i]s";
          #-DEBUG-# print "fmt[$i] = $fmt[$i]\n";
      }
  
      # Format the data from type_info_all
      for (my $i = 0; $i <= $numtyp; $i++)
      {
          my @odbc_val = @{$tia[$i]};
          print "        [ ";
          for (my $num = 0; $num <= $maxkey; $num++)
          {
              # Find the value of the entry in the @odbc_val array.
              my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef;
              $val = fmt_value($num, $val);
              printf $fmt[$num], "$val,";
          }
          print " ],\n";
      }
  
      print "    ];\n\n    1;\n}\n\n__END__\n";
  
  }
  
  1;
  
  __END__
  
  =head1 AUTHORS
  
  Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>),
  Jochen Wiedmann <joe@ispsoft.de>,
  Steffen Goeldner <sgoeldner@cpan.org>,
  and Tim Bunce <dbi-users@perl.org>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_DBD_METADATA

$fatpacked{"darwin-thread-multi-2level/DBI/FAQ.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_FAQ';
  ###
  ### $Id: FAQ.pm 10253 2007-11-15 09:26:16Z timbo $
  ###
  ### DBI Frequently Asked Questions POD
  ###
  ### Copyright section reproduced from below.
  ###
  ### This document is Copyright (c)1994-2000 Alligator Descartes, with portions
  ### Copyright (c)1994-2000 their original authors. This module is released under
  ### the 'Artistic' license which you can find in the perl distribution.
  ### 
  ### This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved.
  ### Permission to distribute this document, in full or in part, via email,
  ### Usenet, ftp archives or http is granted providing that no charges are involved,
  ### reasonable attempt is made to use the most current version and all credits
  ### and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
  ### Requests for other distribution rights, including incorporation into 
  ### commercial products, such as books, magazine articles or CD-ROMs should be
  ### made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
  ### 
  
  package DBI::FAQ;
  
  our $VERSION = sprintf("1.%06d", q$Revision: 10253 $ =~ /(\d+)/o);
  
  
  =head1 NAME
  
  DBI::FAQ -- The Frequently Asked Questions for the Perl5 Database Interface
  
  =for html
  <BODY BGCOLOR="#ffffff" TEXT="#000000" LINK="#3a15ff" ALINK="#ff0000" VLINK="#ff282d">
  <!--#include virtual="/technology/perl/DBI/templatetop.html" -->
  <CENTER>
  <FONT SIZE="+2">
  DBI Frequently Asked Questions v.0.38
  </FONT>
  <BR>
  <FONT SIZE="-1">
  <I>Last updated: February 8th, 2000</I>
  </FONT>
  </CENTER>
  <P>
  
  =head1 SYNOPSIS
  
      perldoc DBI::FAQ
  
  =head1 VERSION
  
  This document is currently at version I<0.38>, as of I<February 8th, 2000>.
  
  That's B<very> old. A newer FAQ can be found at L<http://faq.dbi-support.com/>
  
  =head1 DESCRIPTION
  
  This document serves to answer the most frequently asked questions on both
  the DBI Mailing Lists and personally to members of the DBI development team.
  
  =head1 Basic Information & Information Sources
  
  =head2 1.1 What is DBI, DBperl, Oraperl and *perl?
  
  To quote Tim Bunce, the architect and author of DBI:
  
      ``DBI is a database access Application Programming Interface (API)
        for the Perl Language. The DBI API Specification defines a set
        of functions, variables and conventions that provide a consistent
        database interface independant of the actual database being used.''
  
  In simple language, the DBI interface allows users to access multiple database
  types transparently. So, if you connecting to an Oracle, Informix, mSQL, Sybase
  or whatever database, you don't need to know the underlying mechanics of the
  3GL layer. The API defined by DBI will work on I<all> these database types.
  
  A similar benefit is gained by the ability to connect to two I<different>
  databases of different vendor within the one perl script, I<ie>, I want
  to read data from an Oracle database and insert it back into an Informix
  database all within one program. The DBI layer allows you to do this simply
  and powerfully.
  
  
  =for html
  Here's a diagram that demonstrates the principle:
  <P>
  <CENTER>
  <IMG SRC="img/dbiarch.gif" WIDTH=451 HEIGHT=321 ALT="[ DBI Architecture ]">
  </CENTER>
  <P>
  
  I<DBperl> is the old name for the interface specification. It's usually
  now used to denote perlI<4> modules on database interfacing, such as,
  I<oraperl>, I<isqlperl>, I<ingperl> and so on. These interfaces
  didn't have a standard API and are generally I<not> supported.
  
  Here's a list of DBperl modules, their corresponding DBI counterparts and
  support information. I<Please note>, the author's listed here generally
  I<do not> maintain the DBI module for the same database. These email
  addresses are unverified and should only be used for queries concerning the
  perl4 modules listed below. DBI driver queries should be directed to the
  I<dbi-users> mailing list.
  
      Module Name	Database Required   Author          DBI
      -----------	-----------------   ------          ---
      Sybperl     Sybase              Michael Peppler DBD::Sybase
                                      <mpeppler@itf.ch>
      Oraperl     Oracle 6 & 7        Kevin Stock     DBD::Oracle
                                      <dbi-users@perl.org>
      Ingperl     Ingres              Tim Bunce &     DBD::Ingres
                                      Ted Lemon
                                      <dbi-users@perl.org>
      Interperl   Interbase           Buzz Moschetti  DBD::Interbase
                                      <buzz@bear.com>
      Uniperl     Unify 5.0           Rick Wargo      None
                                      <rickers@coe.drexel.edu>
      Pgperl      Postgres            Igor Metz       DBD::Pg
                                      <metz@iam.unibe.ch>
      Btreeperl   NDBM                John Conover    SDBM?
                                      <john@johncon.com>
      Ctreeperl   C-Tree              John Conover    None
                                      <john@johncon.com>
      Cisamperl   Informix C-ISAM     Mathias Koerber None
                                      <mathias@unicorn.swi.com.sg>
      Duaperl     X.500 Directory     Eric Douglas    None
                  User Agent
  
  However, some DBI modules have DBperl emulation layers, so, I<DBD::Oracle>
  comes with an Oraperl emulation layer, which allows you to run legacy oraperl
  scripts without modification. The emulation layer translates the oraperl API
  calls into DBI calls and executes them through the DBI switch.
  
  Here's a table of emulation layer information:
  
      Module		    Emulation Layer     Status
      ------          ---------------     ------
      DBD::Oracle     Oraperl             Complete
      DBD::Informix   Isqlperl            Under development
      DBD::Ingres     Ingperl             Complete?
      DBD::Sybase     Sybperl             Working? ( Needs verification )
      DBD::mSQL       Msqlperl            Experimentally released with 
                                          DBD::mSQL-0.61
  
  The I<Msqlperl> emulation is a special case. I<Msqlperl> is a perl5 driver
  for I<mSQL> databases, but does not conform to the DBI Specification. It's
  use is being deprecated in favour of I<DBD::mSQL>. I<Msqlperl> may be downloaded
  from CPAN I<via>:
  
      http://www.perl.com/cgi-bin/cpan_mod?module=Msqlperl
  
  =head2 1.2. Where can I get it from?
  
  The Comprehensive Perl Archive Network
  resources should be used for retrieving up-to-date versions of the DBI
  and drivers. CPAN may be accessed I<via> Tom Christiansen's splendid 
  I<CPAN multiplexer> program located at:
  
      http://www.perl.com/CPAN/
  
  For more specific version information and exact URLs of drivers, please see
  the DBI drivers list and the DBI module pages which can be found on:
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  This list is automatically generated on a nightly basis from CPAN and should
  be up-to-date.
  
  =head2 1.3. Where can I get more information?
  
  There are a few information sources on DBI. 
  
  =over 4
  
  =item I<"Programming the Perl DBI">
  
  "Programming the Perl DBI" is the I<official> book on the DBI written by
  Alligator Descartes and Tim Bunce and published by O'Reilly & Associates.
  The book was released on February 9th, 2000.
  
  The table of contents is:
  
      Preface
      1. Introduction
          From Mainframes to Workstations
          Perl
          DBI in the Real World
          A Historical Interlude and Standing Stones
      2. Basic Non-DBI Databases
          Storage Managers and Layers
          Query Languages and Data Functions
          Standing Stones and the Sample Database
          Flat-File Databases
          Putting Complex Data into Flat Files
          Concurrent Database Access and Locking
          DBM Files and the Berkeley Database Manager
          The MLDBM Module
          Summary
      3. SQL and Relational Databases
          The Relational Database Methodology
          Datatypes and NULL Values
          Querying Data
          Modifying Data Within Tables
          Creating and Destroying Tables
      4. Programming with the DBI
          DBI Architecture
          Handles
          Data Source Names
          Connection and Disconnection
          Error Handling
          Utility Methods and Functions
      5. Interacting with the Database
          Issuing Simple Queries
          Executing Non-SELECT Statements
          Binding Parameters to Statements
          Binding Output Columns
          do() Versus prepare()
          Atomic and Batch Fetching
      6. Advanced DBI
          Handle Attributes and Metadata
          Handling LONG/LOB Data
          Transactions, Locking, and Isolation
      7. ODBC and the DBI
          ODBC -- Embraced and Extended
          DBI -- Thrashed and Mutated
          The Nuts and Bolts of ODBC
          ODBC from Perl
          The Marriage of DBI and ODBC
          Questions and Choices
          Moving Between Win32::ODBC and the DBI
          And What About ADO?
      8. DBI Shell and Database Proxying
          dbish -- The DBI Shell
          Database Proxying
      A. DBI Specification
      B. Driver and Database Characteristics
      C. ASLaN Sacred Site Charter
      Index
  
  The book should be available from all good bookshops and can be ordered online
  either <I>via</I> O'Reilly & Associates
  
      http://www.oreilly.com/catalog/perldbi
  
  or Amazon
  
      http://www.amazon.com/exec/obidos/ASIN/1565926994/dbi
  
  =item I<POD documentation>
  
  I<POD>s are chunks of documentation usually embedded within perl programs
  that document the code ``I<in place>'', providing a useful resource for
  programmers and users of modules. POD for DBI and drivers is beginning to 
  become more commonplace, and documentation for these modules can be read
  with the C<perldoc> program included with Perl.
  
  =over 4 
  
  =item The DBI Specification
  
  The POD for the DBI Specification can be read with the:
  
      perldoc DBI
  
  command. The Specification also forms Appendix A of "Programming the Perl
  DBI".
  
  =item Oraperl
  
  Users of the Oraperl emulation layer bundled with I<DBD::Oracle>, may read
  up on how to program with the Oraperl interface by typing:
  
      perldoc Oraperl
  
  This will produce an updated copy of the original oraperl man page written by
  Kevin Stock for perl4. The oraperl API is fully listed and described there.
  
  =item Drivers
  
  Users of the DBD modules may read about some of the private functions
  and quirks of that driver by typing:
  
      perldoc <driver>
  
  For example, the I<DBD::mSQL> driver is bundled with driver-specific 
  documentation that can be accessed by typing
  
      perldoc DBD::mSQL
  
  =item Frequently Asked Questions
  
  This document, the I<Frequently Asked Questions> is also available as POD
  documentation! You can read this on your own system by typing:
  
      perldoc DBI::FAQ
  
  This may be more convenient to persons not permanently, or conveniently,
  connected to the Internet. The I<DBI::FAQ> module should be downloaded and
  installed for the more up-to-date version.
  
  The version of I<DBI::FAQ> shipped with the C<DBI> module may be slightly out
  of date.
  
  =item POD in general
  
  Information on writing POD, and on the philosophy of POD in general, can be
  read by typing:
  
      perldoc perlpod
  
  Users with the Tk module installed may be interested to learn there is a
  Tk-based POD reader available called C<tkpod>, which formats POD in a convenient
  and readable way. This is available I<via> CPAN as the module called 
  I<Tk::POD> and is highly recommended.
  
  =back
  
  =item I<Driver and Database Characteristics>
  
  The driver summaries that were produced for Appendix B of "Programming the
  Perl DBI" are available online at:
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  in the driver information table. These summaries contain standardised
  information on each driver and database which should aid you in selecting
  a database to use. It will also inform you quickly of any issues within
  drivers or whether a driver is not fully compliant with the DBI Specification.
  
  =item I<Rambles, Tidbits and Observations>
  
      http://dbi.perl.org/tidbits
      http://www.symbolstone.org/technology/perl/DBI/tidbits
  
  There are a series of occasional rambles from various people on the
  DBI mailing lists who, in an attempt to clear up a simple point, end up
  drafting fairly comprehensive documents. These are quite often varying in
  quality, but do provide some insights into the workings of the interfaces.
  
  =item I<Articles>
  
  A list of articles discussing the DBI can be found on the DBI WWW page at:
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  These articles are of varying quality and age, from the original Perl Journal
  article written by Alligator and Tim, to more recent debacles published online
  from about.com.
  
  =item I<README files>
  
  The I<README> files included with each driver occasionally contains 
  some useful information ( no, really! ) that may be pertinent to the user.
  Please read them. It makes our worthless existences more bearable. These
  can all be read from the main DBI WWW page at:
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  =item I<Mailing Lists>
  
  There are three mailing lists for DBI:
  
      dbi-announce@perl.org     -- for announcements, very low traffic
      dbi-users@perl.org        -- general user support
      dbi-dev@perl.org          -- for driver developers (no user support)
  
  For information on how to subscribe, set digest mode etc, and unsubscribe,
  send an email message (the content will be ignored) to:
  
      dbi-announce-help@perl.org
      dbi-users-help@perl.org
      dbi-dev-help@perl.org
  
  =item I<Mailing List Archives>
  
  =over 4
  
  =item I<US Mailing List Archives>
  
      http://outside.organic.com/mail-archives/dbi-users/
  
  Searchable hypermail archives of the three mailing lists, and some of the
  much older traffic have been set up for users to browse.
  
  =item I<European Mailing List Archives>
  
      http://www.rosat.mpe-garching.mpg.de/mailing-lists/PerlDB-Interest
  
  As per the US archive above.
  
  =back
  
  =back
  
  =head1 Compilation Problems
  
  =head2 2.1. Compilation problems or "It fails the test!"
  
  First off, consult the README for that driver in case there is useful 
  information about the problem. It may be a known problem for your given 
  architecture and operating system or database. You can check the README
  files for each driver in advance online at:
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  If it's a known problem, you'll probably have to wait till it gets fixed. If 
  you're I<really> needing it fixed, try the following:
  
  =over 4
  
  =item I<Attempt to fix it yourself>
  
  This technique is generally I<not> recommended to the faint-hearted.
  If you do think you have managed to fix it, then, send a patch file
  ( context diff ) to the author with an explanation of:
  
  =over 4
  
  =item *
  
  What the problem was, and test cases, if possible.
  
  =item *
  
  What you needed to do to fix it. Please make sure you mention everything.
  
  =item *
  
  Platform information, database version, perl version, module version and 
  DBI version.
  
  =back
  
  =item I<Email the author> Do I<NOT> whinge!
  
  Please email the address listed in the WWW pages for whichever driver you
  are having problems with. Do I<not> directly email the author at a
  known address unless it corresponds with the one listed.
  
  We tend to have real jobs to do, and we do read the mailing lists for
  problems. Besides, we may not have access to <I<insert your
  favourite brain-damaged platform here>> and couldn't be of any
  assistance anyway! Apologies for sounding harsh, but that's the way of it!
  
  However, you might catch one of these creative genii at 3am when we're
  doing this sort of stuff anyway, and get a patch within 5 minutes. The
  atmosphere in the DBI circle is that we I<do> appreciate the users'
  problems, since we work in similar environments.
  
  If you are planning to email the author, please furnish as much information
  as possible, I<ie>:
  
  =over 4
  
  =item *
  
  I<ALL> the information asked for in the README file in
  the problematic module. And we mean I<ALL> of it. We don't
  put lines like that in documentation for the good of our health, or
  to meet obscure README file standards of length.
  
  =item *
  
  If you have a core dump, try the I<Devel::CoreStack> module for
  generating a stack trace from the core dump. Send us that too.
  I<Devel::CoreStack> can be found on CPAN at:
  
      http://www.perl.com/cgi-bin/cpan_mod?module=Devel::CoreStack
  
  =item *
  
  Module versions, perl version, test cases, operating system versions
  and I<any other pertinent information>.
  
  =back
  
  Remember, the more information you send us, the quicker we can track 
  problems down. If you send us no useful information, expect nothing back.
  
  Finally, please be aware that some authors, including Tim Bunce, specifically
  request that you do I<not> mail them directly. Please respect their wishes and
  use the email addresses listed in the appropriate module C<README> file.
  
  =item I<Email the dbi-users Mailing List>
  
  It's usually a fairly intelligent idea to I<cc> the mailing list
  anyway with problems. The authors all read the lists, so you lose nothing
  by mailing there.
  
  =back
  
  =head1 Platform and Driver Issues
  
  =head2 3.1 What's the difference between ODBC and DBI?
  
  In terms of architecture - not much: Both define programming
  interfaces. Both allow multiple drivers to be loaded to do the
  actual work.
  
  In terms of ease of use - much: The DBI is a 'high level' interface
  that, like Perl itself, strives to make the simple things easy while
  still making the hard things possible. The ODBC is a 'low level'
  interface. All nuts-bolts-knobs-and-dials.
  
  Now there's an ODBC driver for the DBI (DBD::ODBC) the "What's the
  difference" question is more usefully rephrased as:
  
  Chapter 7 of "Programming the Perl DBI" covers this topic in far more
  detail and should be consulted.
  
  =head2 3.2 What's the difference between Win32::ODBC and DBD::ODBC?
  
  The DBI, and thus DBD::ODBC, has a different philosophy from the
  Win32::ODBC module:
  
  The Win32::ODBC module is a 'thin' layer over the low-level ODBC API.
  The DBI defines a simpler 'higher level' interface.
  
  The Win32::ODBC module gives you access to more of the ODBC API.
  The DBI and DBD::ODBC give you access to only the essentials.
  (But, unlike Win32::ODBC, the DBI and DBD::ODBC do support parameter
  binding and multiple prepared statements which reduces the load on
  the database server and can dramatically increase performance.)
  
  The Win32::ODBC module only works on Win32 systems.
  The DBI and DBD::ODBC are very portable and work on Win32 and Unix.
  
  The DBI and DBD::ODBC modules are supplied as a standard part of the
  Perl 5.004 binary distribution for Win32 (they don't work with the
  older, non-standard, ActiveState port).
  
  Scripts written with the DBI and DBD::ODBC are faster than Win32::ODBC
  on Win32 and are trivially portable to other supported database types.
  
  The DBI offers optional automatic printing or die()ing on errors which
  makes applications simpler and more robust.
  
  The current DBD::ODBC driver version 0.16 is new and not yet fully stable.
  A new release is due soon [relative to the date of the next TPJ issue :-]
  and will be much improved and offer more ODBC functionality.
  
  To summarise: The Win32::ODBC module is your best choice if you need
  access to more of the ODBC API than the DBI gives you. Otherwise, the
  DBI and DBD::ODBC combination may be your best bet.
  
  Chapter 7 of "Programming the Perl DBI" covers this topic in far more
  detail and should be consulted.
  
  =head2 3.3 Is DBI supported under Windows 95 / NT platforms?
  
  Finally, yes! Jeff Urlwin has been working diligently on building
  I<DBI> and I<DBD::ODBC> under these platforms, and, with the
  advent of a stabler perl and a port of I<MakeMaker>, the project has
  come on by great leaps and bounds.
  
  The I<DBI> and I<DBD::Oracle> Win32 ports are now a standard part of DBI,
  so, downloading I<DBI> of version higher than I<0.81> should work fine as 
  should using the most recent I<DBD::Oracle> version.
  
  =head2 3.4 Can I access Microsoft Access or SQL-Server databases with DBI?
  
  Yes, use the I<DBD::ODBC> driver.
  
  =head2 3.5 Is the a DBD for <I<insert favourite database here>>?
  
  Is is listed on the DBI drivers page?
  
      http://dbi.perl.org/
      http://www.symbolstone.org/technology/perl/DBI
  
  If not, no. A complete absence of a given database driver from that
  page means that no-one has announced any intention to work on it, not that
  such a driver is impossible to write.
  
  A corollary of the above statement implies that if you see an announcement
  for a driver I<not> on the above page, there's a good chance it's not
  actually a I<DBI> driver, and may not conform to the specifications. Therefore,
  questions concerning problems with that code should I<not> really be addressed
  to the DBI Mailing Lists.
  
  =head2 3.6 What's DBM? And why should I use DBI instead?
  
  Extracted from ``I<DBI - The Database Interface for Perl 5>'':
  
      ``UNIX was originally blessed with simple file-based ``databases'', namely
      the dbm system. dbm lets you store data in files, and retrieve
      that data quickly. However, it also has serious drawbacks.
  
          File Locking
  
          The dbm systems did not allow particularly robust file locking
          capabilities, nor any capability for correcting problems arising through
          simultaneous writes [ to the database ].
  
          Arbitrary Data Structures
  
          The dbm systems only allows a single fixed data structure:
          key-value pairs. That value could be a complex object, such as a
          [ C ] struct, but the key had to be unique. This was a large
          limitation on the usefulness of dbm systems.
  
      However, dbm systems still provide a useful function for users with
      simple datasets and limited resources, since they are fast, robust and 
      extremely well-tested. Perl modules to access dbm systems have now
      been integrated into the core Perl distribution via the
      AnyDBM_File module.''
  
  To sum up, DBM is a perfectly satisfactory solution for essentially read-only
  databases, or small and simple datasets. However, for more 
  scaleable dataset handling, not to mention robust transactional locking, 
  users are recommended to use a more powerful database engine I<via> I<DBI>.
  
  Chapter 2 of "Programming the Perl DBI" discusses DBM files in detail.
  
  =head2 3.7 What database do you recommend me using?
  
  This is a particularly thorny area in which an objective answer is difficult
  to come by, since each dataset, proposed usage and system configuration
  differs from person to person.
  
  From the current author's point of view, if the dataset is relatively
  small, being tables of less than 1 million rows, and less than 1000 tables
  in a given database, then I<mSQL> is a perfectly acceptable solution
  to your problem. This database is extremely cheap, is wonderfully robust
  and has excellent support. More information is available on the Hughes
  Technology WWW site at:
  
      http://www.hughes.com.au
  
  You may also wish to look at MySQL which is a more powerful database engine
  that has a similar feel to mSQL.
  
      http://www.tcx.se
  
  If the dataset is larger than 1 million row tables or 1000 tables, or if you
  have either more money, or larger machines, I would recommend I<Oracle RDBMS>.
  Oracle's WWW site is an excellent source of more information.
  
      http://www.oracle.com
  
  I<Informix> is another high-end RDBMS that is worth considering. There are
  several differences between Oracle and Informix which are too complex for
  this document to detail. Information on Informix can be found on their
  WWW site at:
  
      http://www.informix.com
  
  In the case of WWW fronted applications, I<mSQL> may be a better option
  due to slow connection times between a CGI script and the Oracle RDBMS and
  also the amount of resource each Oracle connection will consume. I<mSQL>
  is lighter resource-wise and faster.
  
  These views are not necessarily representative of anyone else's opinions,
  and do not reflect any corporate sponsorship or views. They are provided
  I<as-is>.
  
  =head2 3.8 Is <I<insert feature here>> supported in DBI?
  
  Given that we're making the assumption that the feature you have requested
  is a non-standard database-specific feature, then the answer will be I<no>.
  
  DBI reflects a I<generic> API that will work for most databases, and has
  no database-specific functionality.
  
  However, driver authors may, if they so desire, include hooks to database-specific
  functionality through the C<func()> method defined in the DBI API.
  Script developers should note that use of functionality provided I<via>
  the C<func()> methods is very unlikely to be portable across databases.
  
  =head1 Programming Questions
  
  =head2 4.1 Is DBI any use for CGI programming?
  
  In a word, yes! DBI is hugely useful for CGI programming! In fact, I would
  tentatively say that CGI programming is one of two top uses for DBI.
  
  DBI confers the ability to CGI programmers to power WWW-fronted databases
  to their users, which provides users with vast quantities of ordered
  data to play with. DBI also provides the possibility that, if a site is
  receiving far too much traffic than their database server can cope with, they
  can upgrade the database server behind the scenes with no alterations to
  the CGI scripts.
  
  =head2 4.2 How do I get faster connection times with DBD::Oracle and CGI?
  
      Contributed by John D. Groenveld
  
  The Apache C<httpd> maintains a pool of C<httpd> children to service client 
  requests.
  
  Using the Apache I<mod_perl> module by I<Doug MacEachern>, the perl 
  interpreter is embedded with the C<httpd> children. The CGI, DBI, and your 
  other favorite modules can be loaded at the startup of each child. These 
  modules will not be reloaded unless changed on disk.
  
  For more information on Apache, see the Apache Project's WWW site:
  
      http://www.apache.org
  
  The I<mod_perl> module can be downloaded from CPAN I<via>:
  
      http://www.perl.com/cgi-bin/cpan_mod?module=Apache
  
  =head2 4.3 How do I get persistent connections with DBI and CGI?
  
      Contributed by John D. Groenveld
  
  Using Edmund Mergl's I<Apache::DBI> module, database logins are stored in a 
  hash with each of these C<httpd> child. If your application is based on a 
  single database user, this connection can be started with each child. 
  Currently, database connections cannot be shared between C<httpd> children.
  
  I<Apache::DBI> can be downloaded from CPAN I<via>:
  
      http://www.perl.com/cgi-bin/cpan_mod?module=Apache::DBI
  
  =head2 4.4 ``When I run a perl script from the command line, it works, but, when I run it under the C<httpd>, it fails!'' Why?
  
  Basically, a good chance this is occurring is due to the fact that the user
  that you ran it from the command line as has a correctly configured set of
  environment variables, in the case of I<DBD::Oracle>, variables like
  C<ORACLE_HOME>, C<ORACLE_SID> or C<TWO_TASK>.
  
  The C<httpd> process usually runs under the user id of C<nobody>,
  which implies there is no configured environment. Any scripts attempting to
  execute in this situation will correctly fail.
  
  One way to solve this problem is to set the environment for your database in a
  C<BEGIN { }> block at the top of your script. Another technique is to configure
  your WWW server to pass-through certain environment variables to your CGI 
  scripts.
  
  Similarly, you should check your C<httpd> error logfile for any clues,
  as well as the ``Idiot's Guide To Solving Perl / CGI Problems'' and
  ``Perl CGI Programming FAQ'' for further information. It is
  unlikely the problem is DBI-related.
  
  The ``Idiot's Guide To Solving Perl / CGI Problems'' can be located at:
  
      http://www.perl.com/perl/faq/index.html
  
  as can the ``Perl CGI Programming FAQ''. Read I<BOTH> these documents 
  carefully!
  
  =head2 4.5 How do I get the number of rows returned from a C<SELECT> statement?
  
  Count them. Read the DBI docs for the C<rows()> method.
  
  =head1 Miscellaneous Questions
  
  =head2 5.1 Can I do multi-threading with DBI?
  
  Perl version 5.005 and later can be built to support multi-threading.
  The DBI, as of version 1.02, does not yet support multi-threading
  so it would be unsafe to let more than one thread enter the DBI at
  the same time.
  
  It is expected that some future version of the DBI will at least be
  thread-safe (but not thread-hot) by automatically blocking threads
  intering the DBI while it's already in use.
  
  For some OCI example code for Oracle that has multi-threaded C<SELECT>
  statements, see:
  
      http://www.symbolstone.org/technology/oracle/oci/orathreads.tar.gz
  
  =head2 5.2 How do I handle BLOB data with DBI?
  
  Handling BLOB data with the DBI is very straight-forward. BLOB columns are
  specified in a SELECT statement as per normal columns. However, you also
  need to specify a maximum BLOB size that the <I>database handle</I> can
  fetch using the C<LongReadLen> attribute.
  
  For example:
  
      ### $dbh is a connected database handle
      $sth = $dbh->prepare( "SELECT blob_column FROM blobby_table" );
      $sth->execute;
  
  would fail.
  
      ### $dbh is a connected database handle
      ### Set the maximum BLOB size...
      $dbh->{LongReadLen} = 16384;        ### 16Kb...Not much of a BLOB!
  
      $sth = $dbh->prepare( "..." );
  
  would succeed <I>provided no column values were larger than the specified
  value</I>.
  
  If the BLOB data is longer than the value of C<LongReadLen>, then an
  error will occur. However, the DBI provides an additional piece of
  functionality that will automatically truncate the fetched BLOB to the
  size of C<LongReadLen> if it is longer. This does not cause an error to
  occur, but may make your fetched BLOB data useless.
  
  This behaviour is regulated by the C<LongTruncOk> attribute which is 
  defaultly set to a false value ( thus making overlong BLOB fetches fail ).
  
      ### Set BLOB handling such that it's 16Kb and can be truncated
      $dbh->{LongReadLen} = 16384;
      $dbh->{LongTruncOk} = 1;
  
  Truncation of BLOB data may not be a big deal in cases where the BLOB
  contains run-length encoded data, but data containing checksums at the end,
  for example, a ZIP file, would be rendered useless.
  
  =head2 5.3 How can I invoke stored procedures with DBI?
  
  The DBI does not define a database-independent way of calling stored procedures.
  
  However, most database that support them also provide a way to call
  them from SQL statements - and the DBI certainly supports that.
  
  So, assuming that you have created a stored procedure within the target
  database, I<eg>, an Oracle database, you can use C<$dbh>->C<do()> to
  immediately execute the procedure. For example,
  
      $dbh->do( "BEGIN someProcedure; END;" );   # Oracle-specific
  
  You should also be able to C<prepare> and C<execute>, which is
  the recommended way if you'll be calling the procedure often.
  
  =head2 5.4 How can I get return values from stored procedures with DBI?
  
      Contributed by Jeff Urlwin
  
      $sth = $dbh->prepare( "BEGIN foo(:1, :2, :3); END;" );
      $sth->bind_param(1, $a);
      $sth->bind_param_inout(2, \$path, 2000);
      $sth->bind_param_inout(3, \$success, 2000);
      $sth->execute;
  
  Remember to perform error checking, though! ( Or use the C<RaiseError>
  attribute ).
  
  =head2 5.5 How can I create or drop a database with DBI?
  
  Database creation and deletion are concepts that are entirely too abstract
  to be adequately supported by DBI. For example, Oracle does not support the
  concept of dropping a database at all! Also, in Oracle, the database
  I<server> essentially I<is> the database, whereas in mSQL, the
  server process runs happily without any databases created in it. The
  problem is too disparate to attack in a worthwhile way.
  
  Some drivers, therefore, support database creation and deletion through
  the private C<func()> methods. You should check the documentation for
  the drivers you are using to see if they support this mechanism.
  
  =head2 5.6 How can I C<commit> or C<rollback> a statement with DBI?
  
  See the C<commit()> and C<rollback()> methods in the DBI Specification.
  
  Chapter 6 of "Programming the Perl DBI" discusses transaction handling within
  the context of DBI in more detail.
  
  =head2 5.7 How are C<NULL> values handled by DBI?
  
  C<NULL> values in DBI are specified to be treated as the value C<undef>.
  C<NULL>s can be inserted into databases as C<NULL>, for example:
  
      $rv = $dbh->do( "INSERT INTO table VALUES( NULL )" );
  
  but when queried back, the C<NULL>s should be tested against C<undef>.
  This is standard across all drivers.
  
  =head2 5.8 What are these C<func()> methods all about?
  
  The C<func()> method is defined within DBI as being an entry point
  for database-specific functionality, I<eg>, the ability to create or
  drop databases. Invoking these driver-specific methods is simple, for example,
  to invoke a C<createDatabase> method that has one argument, we would
  write:
  
      $rv =$dbh->func( 'argument', 'createDatabase' );
  
  Software developers should note that the C<func()> methods are
  non-portable between databases.
  
  =head2 5.9 Is DBI Year 2000 Compliant?
  
  DBI has no knowledge of understanding of what dates are. Therefore, DBI
  itself does not have a Year 2000 problem. Individual drivers may use date
  handling code internally and therefore be potentially susceptible to the
  Year 2000 problem, but this is unlikely.
  
  You may also wish to read the ``Does Perl have a Year 2000 problem?'' section
  of the Perl FAQ at:
  
      http://www.perl.com/CPAN/doc/FAQs/FAQ/PerlFAQ.html
  
  =head1 Support and Training
  
  The Perl5 Database Interface is I<FREE> software. IT COMES WITHOUT WARRANTY
  OF ANY KIND. See the DBI README for more details.
  
  However, some organizations are providing either technical support or
  training programs on DBI. The present author has no knowledge as
  to the quality of these services. The links are included for reference
  purposes only and should not be regarded as recommendations in any way.
  I<Caveat emptor>.
  
  =head2 Commercial Support
  
  =over 4
  
  =item The Perl Clinic
  
  The Perl Clinic provides commercial support for I<Perl> and Perl
  related problems, including the I<DBI> and its drivers.  Support is
  provided by the company with whom Tim Bunce, author of I<DBI> and
  I<DBD::Oracle>, works and ActiveState. For more information on their
  services, please see:
  
      http://www.perlclinic.com
  
  =back
  
  =head2 Training
  
  =over 4
  
  =item Westlake Solutions
  
  A hands-on class for experienced Perl CGI developers that teaches
  how to write database-connected CGI scripts using Perl and DBI.pm.  This
  course, along with four other courses on CGI scripting with Perl, is
  taught in Washington, DC; Arlington, Virginia; and on-site worldwide upon
  request.
  
  See:
  
      http://www.westlake.com/training
  
  for more details.
  
  =back
  
  =head1 Other References
  
  In this section, we present some miscellaneous WWW links that may be of
  some interest to DBI users. These are not verified and may result in
  unknown sites or missing documents.
  
      http://www-ccs.cs.umass.edu/db.html
      http://www.odmg.org/odmg93/updates_dbarry.html
      http://www.jcc.com/sql_stnd.html
  
  =head1 AUTHOR
  
  Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>. 
  Portions are Copyright their original stated authors.
  
  =head1 COPYRIGHT
  
  This document is Copyright (c)1994-2000 Alligator Descartes, with portions
  Copyright (c)1994-2000 their original authors. This module is released under
  the 'Artistic' license which you can find in the perl distribution.
  
  This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved.
  Permission to distribute this document, in full or in part, via email,
  Usenet, ftp archives or http is granted providing that no charges are involved,
  reasonable attempt is made to use the most current version and all credits
  and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
  Requests for other distribution rights, including incorporation into 
  commercial products, such as books, magazine articles or CD-ROMs should be
  made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
  
  =for html
  <!--#include virtual="/technology/perl/DBI/templatebottom.html" -->
  </BODY>
  </HTML>
DARWIN-THREAD-MULTI-2LEVEL_DBI_FAQ

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Execute.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_EXECUTE';
  package DBI::Gofer::Execute;
  
  #   $Id: Execute.pm 11769 2008-09-12 13:18:59Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use Carp;
  
  use DBI qw(dbi_time);
  use DBI::Gofer::Request;
  use DBI::Gofer::Response;
  
  use base qw(DBI::Util::_accessor);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 11769 $ =~ /(\d+)/o);
  
  our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common};
  our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods;
  
  our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr
  
  our $current_dbh;   # the dbh we're using for this request
  
  
  # set trace for server-side gofer
  # Could use DBI_TRACE env var when it's an unrelated separate process
  # but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream)
  DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};
  
  
  # define valid configuration attributes (args to new())
  # the values here indicate the basic type of values allowed
  my %configuration_attributes = (
      gofer_execute_class => 1,
      default_connect_dsn => 1,
      forced_connect_dsn  => 1,
      default_connect_attributes => {},
      forced_connect_attributes  => {},
      track_recent => 1,
      check_request_sub => sub {},
      check_response_sub => sub {},
      forced_single_resultset => 1,
      max_cached_dbh_per_drh => 1,
      max_cached_sth_per_dbh => 1,
      forced_response_attributes => {},
      forced_gofer_random => 1,
      stats => {},
  );
  
  __PACKAGE__->mk_accessors(
      keys %configuration_attributes
  );
  
  
  
  sub new {
      my ($self, $args) = @_;
      $args->{default_connect_attributes} ||= {};
      $args->{forced_connect_attributes}  ||= {};
      $args->{max_cached_sth_per_dbh}     ||= 1000;
      $args->{stats} ||= {};
      return $self->SUPER::new($args);
  }
  
  
  sub valid_configuration_attributes {
      my $self = shift;
      return { %configuration_attributes };
  }
  
  
  my %extra_attr = (
      # Only referenced if the driver doesn't support private_attribute_info method.
      # What driver-specific attributes should be returned for the driver being used?
      # keyed by $dbh->{Driver}{Name}
      # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others
      # which would reduce processing/traffic for non-select statements
      mysql  => {
          dbh => [qw(
              mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid
              mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id
          )],
          sth => [qw(
              mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment
              mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid
          )],
          # XXX this dbh_after_sth stuff is a temporary, but important, hack.
          # should be done via hash instead of arrays where the hash value contains
          # flags that can indicate which attributes need to be handled in this way
          dbh_after_sth => [qw(
              mysql_insertid
          )],
      },
      Pg  => {
          dbh => [qw(
              pg_protocol pg_lib_version pg_server_version
              pg_db pg_host pg_port pg_default_port
              pg_options pg_pid
          )],
          sth => [qw(
              pg_size pg_type pg_oid_status pg_cmd_status
          )],
      },
      Sybase => {
          dbh => [qw(
              syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string
          )],
          sth => [qw(
              syb_types syb_proc_status syb_result_type
          )],
      },
      SQLite => {
          dbh => [qw(
              sqlite_version
          )],
          sth => [qw(
          )],
      },
      ExampleP => {
          dbh => [qw(
              examplep_private_dbh_attrib
          )],
          sth => [qw(
              examplep_private_sth_attrib
          )],
          dbh_after_sth => [qw(
              examplep_insertid
          )],
      },
  );
  
  
  sub _connect {
      my ($self, $request) = @_;
  
      my $stats = $self->{stats};
  
      # discard CachedKids from time to time
      if (++$stats->{_requests_served} % 1000 == 0 # XXX config?
          and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh}
      ) {
          my %drivers = DBI->installed_drivers();
          while ( my ($driver, $drh) = each %drivers ) {
              next unless my $CK = $drh->{CachedKids};
              next unless keys %$CK > $max_cached_dbh_per_drh;
              next if $driver eq 'Gofer'; # ie transport=null when testing
              DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver",
                  scalar keys %$CK, $self->{max_cached_dbh_per_drh});
              $_->{Active} && $_->disconnect for values %$CK;
              %$CK = ();
          }
      }
  
      # local $ENV{...} can leak, so only do it if required
      local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};
  
      my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call };
      $connect_method ||= 'connect_cached';
      $stats->{method_calls_dbh}->{$connect_method}++;
  
      # delete attributes we don't want to affect the server-side
      # (Could just do this on client-side and trust the client. DoS?)
      delete @{$attr}{qw(Profile InactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)};
  
      $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn
          or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request";
  
      my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || '';
  
      my $connect_attr = {
  
          # the configured default attributes, if any
          %{ $self->default_connect_attributes },
  
          # pass username and password as attributes
          # then they can be overridden by forced_connect_attributes
          Username => $username,
          Password => $password,
  
          # the requested attributes
          %$attr,
  
          # force some attributes the way we'd like them
          PrintWarn  => $local_log,
          PrintError => $local_log,
  
          # the configured default attributes, if any
          %{ $self->forced_connect_attributes },
  
          # RaiseError must be enabled
          RaiseError => 1,
  
          # reset Executed flag (of the cached handle) so we can use it to tell
          # if errors happened before the main part of the request was executed
          Executed => 0,
  
          # ensure this connect_cached doesn't have the same args as the client
          # because that causes subtle issues if in the same process (ie transport=null)
          # include pid to avoid problems with forking (ie null transport in mod_perl)
          # include gofer-random to avoid random behaviour leaking to other handles
          dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random),
      };
  
      # XXX implement our own private connect_cached method? (with rate-limited ping)
      my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr);
  
      $dbh->{ShowErrorStatement} = 1 if $local_log;
  
      # XXX should probably just be a Callbacks => arg to connect_cached
      # with a cache of pre-built callback hooks (memoized, without $self) 
      if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) {
          $self->_install_rand_callbacks($dbh, $random);
      }
  
      my $CK = $dbh->{CachedKids};
      if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) {
          %$CK = (); #  clear all statement handles
      }
  
      #$dbh->trace(0);
      $current_dbh = $dbh;
      return $dbh;
  }
  
  
  sub reset_dbh {
      my ($self, $dbh) = @_;
      $dbh->set_err(undef, undef); # clear any error state
  }
  
  
  sub new_response_with_err {
      my ($self, $rv, $eval_error, $dbh) = @_;
      # this is the usual way to create a response for both success and failure
      # capture err+errstr etc and merge in $eval_error ($@)
  
      my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
  
      if ($eval_error) {
          $err ||= $DBI::stderr || 1; # ensure err is true
          if ($errstr) {
              $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr;
              chomp $errstr;
              $errstr .= "; $eval_error";
          }
          else {
              $errstr = $eval_error;
          }
      }
      chomp $errstr if $errstr;
  
      my $flags;
      # (XXX if we ever add transaction support then we'll need to take extra
      # steps because the commit/rollback would reset Executed before we get here)
      $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed};
  
      my $response = DBI::Gofer::Response->new({
          rv     => $rv,
          err    => $err,
          errstr => $errstr,
          state  => $state,
          flags  => $flags,
      });
  
      return $response;
  }
  
  
  sub execute_request {
      my ($self, $request) = @_;
      # should never throw an exception
  
      DBI->trace_msg("-----> execute_request\n");
  
      my @warnings;
      local $SIG{__WARN__} = sub {
          push @warnings, @_;
          warn @_ if $local_log;
      };
  
      my $response = eval {
  
          if (my $check_request_sub = $self->check_request_sub) {
              $request = $check_request_sub->($request, $self)
                  or die "check_request_sub failed";
          }
  
          my $version = $request->version || 0;
          die ref($request)." version $version is not supported"
              if $version < 0.009116 or $version >= 1;
  
          ($request->is_sth_request)
              ? $self->execute_sth_request($request)
              : $self->execute_dbh_request($request);
      };
      $response ||= $self->new_response_with_err(undef, $@, $current_dbh);
  
      if (my $check_response_sub = $self->check_response_sub) {
          # not protected with an eval so it can choose to throw an exception
          my $new = $check_response_sub->($response, $self, $request);
          $response = $new if ref $new;
      }
  
      undef $current_dbh;
  
      $response->warnings(\@warnings) if @warnings;
      DBI->trace_msg("<----- execute_request\n");
      return $response;
  }
  
  
  sub execute_dbh_request {
      my ($self, $request) = @_;
      my $stats = $self->{stats};
  
      my $dbh;
      my $rv_ref = eval {
          $dbh = $self->_connect($request);
          my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
          my $wantarray = shift @$args;
          my $meth      = shift @$args;
          $stats->{method_calls_dbh}->{$meth}++;
          my @rv = ($wantarray)
              ?        $dbh->$meth(@$args)
              : scalar $dbh->$meth(@$args);
          \@rv;
      } || [];
      my $response = $self->new_response_with_err($rv_ref, $@, $dbh);
  
      return $response if not $dbh;
  
      # does this request also want any dbh attributes returned?
      if (my $dbh_attributes = $request->dbh_attributes) {
          $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) );
      }
  
      if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
          $stats->{method_calls_dbh}->{last_insert_id}++;
          my $id = $dbh->last_insert_id( @$lid_args );
          $response->last_insert_id( $id );
      }
  
      if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
          # dbh_method_call was probably a metadata method like table_info
          # that returns a statement handle, so turn the $sth into resultset
          my $sth = $rv_ref->[0];
          $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
          $response->rv("(sth)"); # don't try to return actual sth
      }
  
      # we're finished with this dbh for this request
      $self->reset_dbh($dbh);
  
      return $response;
  }
  
  
  sub gather_dbh_attributes {
      my ($self, $dbh, $dbh_attributes) = @_;
      my @req_attr_names = @$dbh_attributes;
      if ($req_attr_names[0] eq '*') { # auto include std + private
          shift @req_attr_names;
          push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) };
      }
      my %dbh_attr_values;
      @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names);
  
      # XXX piggyback installed_methods onto dbh_attributes for now
      $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
      
      # XXX piggyback default_methods onto dbh_attributes for now
      $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
      
      return \%dbh_attr_values;
  }
  
  
  sub _std_response_attribute_names {
      my ($self, $h) = @_;
      $h = tied(%$h) || $h; # switch to inner handle
  
      # cache the private_attribute_info data for each handle
      # XXX might be better to cache it in the executor
      # as it's unlikely to change
      # or perhaps at least cache it in the dbh even for sth
      # as the sth are typically very short lived
  
      my ($dbh, $h_type, $driver_name, @attr_names);
  
      if ($dbh = $h->{Database}) {    # is an sth
  
          # does the dbh already have the answer cached?
          return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth};
  
          ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name});
          push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE);
      }
      else {                          # is a dbh
          return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh};
  
          ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h);
          # explicitly add these because drivers may have different defaults
          # add Name so the client gets the real Name of the connection
          push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
      }
  
      if (my $pai = $h->private_attribute_info) {
          push @attr_names, keys %$pai;
      }
      else {
          push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
      }
      if (my $fra = $self->{forced_response_attributes}) {
          push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []}
      }
      $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n");
  
      # cache into the dbh even for sth, as the dbh is usually longer lived
      return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names;
  }
  
  
  sub execute_sth_request {
      my ($self, $request) = @_;
      my $dbh;
      my $sth;
      my $last_insert_id;
      my $stats = $self->{stats};
  
      my $rv = eval {
          $dbh = $self->_connect($request);
  
          my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ]
          shift @$args; # discard wantarray
          my $meth = shift @$args;
          $stats->{method_calls_sth}->{$meth}++;
          $sth = $dbh->$meth(@$args);
          my $last = '(sth)'; # a true value (don't try to return actual sth)
  
          # execute methods on the sth, e.g., bind_param & execute
          if (my $calls = $request->sth_method_calls) {
              for my $meth_call (@$calls) {
                  my $method = shift @$meth_call;
                  $stats->{method_calls_sth}->{$method}++;
                  $last = $sth->$method(@$meth_call);
              }
          }
  
          if (my $lid_args = $request->dbh_last_insert_id_args) {
              $stats->{method_calls_sth}->{last_insert_id}++;
              $last_insert_id = $dbh->last_insert_id( @$lid_args );
          }
  
          $last;
      };
      my $response = $self->new_response_with_err($rv, $@, $dbh);
  
      return $response if not $dbh;
  
      $response->last_insert_id( $last_insert_id )
          if defined $last_insert_id;
  
      # even if the eval failed we still want to try to gather attribute values
      # (XXX would be nice to be able to support streaming of results.
      # which would reduce memory usage and latency for large results)
      if ($sth) {
          $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) );
          $sth->finish;
      }
  
      # does this request also want any dbh attributes returned?
      my $dbh_attr_set;
      if (my $dbh_attributes = $request->dbh_attributes) {
          $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes);
      }
      # XXX needs to be integrated with private_attribute_info() etc
      if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) {
          @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr);
      }
      $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set;
  
      $self->reset_dbh($dbh);
  
      return $response;
  }
  
  
  sub gather_sth_resultsets {
      my ($self, $sth, $request, $response) = @_;
      my $resultsets = eval {
  
          my $attr_names = $self->_std_response_attribute_names($sth);
          my $sth_attr = {};
          $sth_attr->{$_} = 1 for @$attr_names;
  
          # let the client add/remove sth atributes
          if (my $sth_result_attr = $request->sth_result_attr) {
              $sth_attr->{$_} = $sth_result_attr->{$_}
                  for keys %$sth_result_attr;
          }
          my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr;
  
          my $row_count = 0;
          my $rs_list = [];
          while (1) {
              my $rs = $self->fetch_result_set($sth, \@sth_attr);
              push @$rs_list, $rs;
              if (my $rows = $rs->{rowset}) {
                  $row_count += @$rows;
              }
              last if $self->{forced_single_resultset};
              last if !($sth->more_results || $sth->{syb_more_results});
           }
  
          my $stats = $self->{stats};
          $stats->{rows_returned_total} += $row_count;
          $stats->{rows_returned_max} = $row_count
              if $row_count > ($stats->{rows_returned_max}||0);
  
          $rs_list;
      };
      $response->add_err(1, $@) if $@;
      return $resultsets;
  }
  
  
  sub fetch_result_set {
      my ($self, $sth, $sth_attr) = @_;
      my %meta;
      eval {
          @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr);
          # we assume @$sth_attr contains NUM_OF_FIELDS
          $meta{rowset}       = $sth->fetchall_arrayref()
              if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT
          # the fetchall_arrayref may fail with a 'not executed' kind of error
          # because gather_sth_resultsets/fetch_result_set are called even if
          # execute() failed, or even if there was no execute() call at all.
          # The corresponding error goes into the resultset err, not the top-level
          # response err, so in most cases this resultset err is never noticed.
      };
      if ($@) {
          chomp $@;
          $meta{err}    = $DBI::err    || 1;
          $meta{errstr} = $DBI::errstr || $@;
          $meta{state}  = $DBI::state;
      }
      return \%meta;
  }
  
  
  sub _get_default_methods {
      my ($dbh) = @_;
      # returns a ref to a hash of dbh method names for methods which the driver
      # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer.
      my $ImplementorClass = $dbh->{ImplementorClass} or die;
      my %default_methods;
      for my $method (@all_dbh_methods) {
          my $dbi_sub = $all_dbh_methods{$method}       || 42;
          my $imp_sub = $ImplementorClass->can($method) || 42;
          next if $imp_sub != $dbi_sub;
          #warn("default $method\n");
          $default_methods{$method} = 1;
      }
      return \%default_methods;
  }
  
  
  # XXX would be nice to make this a generic DBI module
  sub _install_rand_callbacks {
      my ($self, $dbh, $dbi_gofer_random) = @_;
  
      my $callbacks = $dbh->{Callbacks} || {};
      my $prev      = $dbh->{private_gofer_rand_fail_callbacks} || {};
  
      # return if we've already setup this handle with callbacks for these specs
      return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random);
      #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}";
      $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random;
  
      my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note);
      my @specs = split /,/, $dbi_gofer_random;
      for my $spec (@specs) {
          if ($spec =~ m/^fail=(-?[.\d]+)%?$/) {
              $fail_percent = $1;
              $spec_part{fail} = $spec;
              next;
          }
          if ($spec =~ m/^err=(-?\d+)$/) {
              $fail_err = $1;
              $spec_part{err} = $spec;
              next;
          }
          if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) {
              $delay_duration = $1;
              $delay_percent  = $2;
              $spec_part{delay} = $spec;
              next;
          }
          elsif ($spec !~ m/^(\w+|\*)$/) {
              warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name";
              next;
          }
  
          my $method = $spec;
          if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) {
              warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n";
              next;
          }
          unless (defined $fail_percent or defined $delay_percent) {
              warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceeded by 'fail=N' and/or 'delayN=N'";
              next;
          }
  
          push @spec_note, join(",", values(%spec_part), $method);
          $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err);
      }
      warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n"
          if @spec_note;
      $dbh->{Callbacks} = $callbacks;
      $dbh->{private_gofer_rand_fail_callbacks} = $callbacks;
  }
  
  my %_mk_rand_callback_seqn;
  
  sub _mk_rand_callback {
      my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_;
      my ($fail_modrate, $delay_modrate);
      $fail_percent  ||= 0;  $fail_modrate  = int(1/(-$fail_percent )*100) if $fail_percent;
      $delay_percent ||= 0;  $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent;
      # note that $method may be "*" but that's not recommended or documented or wise
      return sub {
          my ($h) = @_;
          my $seqn = ++$_mk_rand_callback_seqn{$method};
          my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent :
                      ($delay_percent < 0) ? !($seqn % $delay_modrate): 0;
          my $fail  = ($fail_percent  > 0) ? rand(100) < $fail_percent  :
                      ($fail_percent  < 0) ? !($seqn % $fail_modrate) : 0;
          #no warnings 'uninitialized';
          #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay";
          if ($delay) {
              my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n";
              # Note what's happening in a trace message. If the delay percent is an even
              # number then use warn() instead so it's sent back to the client.
              ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg);
              select undef, undef, undef, $delay_duration; # allows floating point value
          }
          if ($fail) {
              undef $_; # tell DBI to not call the method
              # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr
              # as it's checked for in a few places, such as the gofer retry logic
              return $h->set_err($fail_err || $DBI::stderr,
                  "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)");
          }
          return;
      }
  }
  
  
  sub update_stats {
      my ($self,
          $request, $response,
          $frozen_request, $frozen_response,
          $time_received,
          $store_meta, $other_meta,
      ) = @_;
  
      # should always have a response object here
      carp("No response object provided") unless $request;
  
      my $stats = $self->{stats};
      $stats->{frozen_request_max_bytes} = length($frozen_request)
          if $frozen_request
          && length($frozen_request)  > ($stats->{frozen_request_max_bytes}||0);
      $stats->{frozen_response_max_bytes} = length($frozen_response)
          if $frozen_response
          && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0);
  
      my $recent;
      if (my $track_recent = $self->{track_recent}) {
          $recent = {
              request  => $frozen_request,
              response => $frozen_response,
              time_received => $time_received,
              duration => dbi_time()-$time_received,
              # for any other info
              ($store_meta) ? (meta => $store_meta) : (),
          };
          $recent->{request_object} = $request
              if !$frozen_request && $request;
          $recent->{response_object} = $response
              if !$frozen_response;
          my @queues =  ($stats->{recent_requests} ||= []);
          push @queues, ($stats->{recent_errors}   ||= [])
              if !$response or $response->err;
          for my $queue (@queues) {
              push @$queue, $recent;
              shift @$queue if @$queue > $track_recent;
          }
      }
      return $recent;
  }
  
  
  1;
  __END__
  
  =head1 NAME
  
  DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses
  
  =head1 SYNOPSIS
  
    $executor = DBI::Gofer::Execute->new( { ...config... });
  
    $response = $executor->execute_request( $request );
  
  =head1 DESCRIPTION
  
  Accepts a DBI::Gofer::Request object, executes the requested DBI method calls,
  and returns a DBI::Gofer::Response object.
  
  Any error, including any internal 'fatal' errors are caught and converted into
  a DBI::Gofer::Response object.
  
  This module is usually invoked by a 'server-side' Gofer transport module.
  They usually have names in the "C<DBI::Gofer::Transport::*>" namespace.
  Examples include: L<DBI::Gofer::Transport::stream> and L<DBI::Gofer::Transport::mod_perl>.
  
  =head1 CONFIGURATION
  
  =head2 check_request_sub
  
  If defined, it must be a reference to a subroutine that will 'check' the request.
  It is passed the request object and the executor as its only arguments.
  
  The subroutine can either return the original request object or die with a
  suitable error message (which will be turned into a Gofer response).
  
  It can also construct and return a new request that should be executed instead
  of the original request.
  
  =head2 check_response_sub
  
  If defined, it must be a reference to a subroutine that will 'check' the response.
  It is passed the response object, the executor, and the request object.
  The sub may alter the response object and return undef, or return a new response object.
  
  This mechanism can be used to, for example, terminate the service if specific
  database errors are seen.
  
  =head2 forced_connect_dsn
  
  If set, this DSN is always used instead of the one in the request.
  
  =head2 default_connect_dsn
  
  If set, this DSN is used if C<forced_connect_dsn> is not set and the request does not contain a DSN itself.
  
  =head2 forced_connect_attributes
  
  A reference to a hash of connect() attributes. Individual attributes in
  C<forced_connect_attributes> will take precedence over corresponding attributes
  in the request.
  
  =head2 default_connect_attributes
  
  A reference to a hash of connect() attributes. Individual attributes in the
  request take precedence over corresponding attributes in C<default_connect_attributes>.
  
  =head2 max_cached_dbh_per_drh
  
  If set, the loaded drivers will be checked to ensure they don't have more than
  this number of cached connections. There is no default value. This limit is not
  enforced for every request.
  
  =head2 max_cached_sth_per_dbh
  
  If set, all the cached statement handles will be cleared once the number of
  cached statement handles rises above this limit. The default is 1000.
  
  =head2 forced_single_resultset
  
  If true, then only the first result set will be fetched and returned in the response.
  
  =head2 forced_response_attributes
  
  A reference to a data structure that can specify extra attributes to be returned in responses.
  
    forced_response_attributes => {
        DriverName => {
            dbh => [ qw(dbh_attrib_name) ],
            sth => [ qw(sth_attrib_name) ],
        },
    },
  
  This can be useful in cases where the driver has not implemented the
  private_attribute_info() method and DBI::Gofer::Execute's own fallback list of
  private attributes doesn't include the driver or attributes you need.
  
  =head2 track_recent
  
  If set, specifies the number of recent requests and responses that should be
  kept by the update_stats() method for diagnostics. See L<DBI::Gofer::Transport::mod_perl>.
  
  Note that this setting can significantly increase memory use. Use with caution.
  
  =head2 forced_gofer_random
  
  Enable forced random failures and/or delays for testing. See L</DBI_GOFER_RANDOM> below.
  
  =head1 DRIVER-SPECIFIC ISSUES
  
  Gofer needs to know about any driver-private attributes that should have their
  values sent back to the client.
  
  If the driver doesn't support private_attribute_info() method, and very few do,
  then the module fallsback to using some hard-coded details, if available, for
  the driver being used. Currently hard-coded details are available for the
  mysql, Pg, Sybase, and SQLite drivers.
  
  =head1 TESTING
  
  DBD::Gofer, DBD::Execute and related packages are well tested by executing the
  DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer.
  
  Because Gofer includes timeout and 'retry on error' mechanisms there is a need
  for some way to trigger delays and/or errors. This can be done via the
  C<forced_gofer_random> configuration item, or else the DBI_GOFER_RANDOM environment
  variable.
  
  =head2 DBI_GOFER_RANDOM
  
  The value of the C<forced_gofer_random> configuration item (or else the
  DBI_GOFER_RANDOM environment variable) is treated as a series of tokens
  separated by commas.
  
  The tokens can be one of three types:
  
  =over 4
  
  =item fail=R%
  
  Set the current failure rate to R where R is a percentage.
  The value R can be floating point, e.g., C<fail=0.05%>.
  Negative values for R have special meaning, see below.
  
  =item err=N
  
  Sets the current failure err vaue to N (instead of the DBI's default 'standard
  err value' of 2000000000). This is useful when you want to simulate a
  specific error.
  
  =item delayN=R%
  
  Set the current random delay rate to R where R is a percentage, and set the
  current delay duration to N seconds. The values of R and N can be floating point,
  e.g., C<delay0.5=0.2%>.  Negative values for R have special meaning, see below.
  
  If R is an odd number (R % 2 == 1) then a message is logged via warn() which
  will be returned to, and echoed at, the client.
  
  =item methodname
  
  Applies the current fail, err, and delay values to the named method.
  If neither a fail nor delay have been set yet then a warning is generated.
  
  =back
  
  For example:
  
    $executor = DBI::Gofer::Execute->new( {
      forced_gofer_random => "fail=0.01%,do,delay60=1%,execute",
    });
  
  will cause the do() method to fail for 0.01% of calls, and the execute() method to
  fail 0.01% of calls and be delayed by 60 seconds on 1% of calls.
  
  If the percentage value (C<R>) is negative then instead of the failures being
  triggered randomly (via the rand() function) they are triggered via a sequence
  number. In other words "C<fail=-20%>" will mean every fifth call will fail.
  Each method has a distinct sequence number.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_EXECUTE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Request.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_REQUEST';
  package DBI::Gofer::Request;
  
  #   $Id: Request.pm 12536 2009-02-24 22:37:09Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  
  use DBI qw(neat neat_list);
  
  use base qw(DBI::Util::_accessor);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
  
  use constant GOf_REQUEST_IDEMPOTENT => 0x0001;
  use constant GOf_REQUEST_READONLY   => 0x0002;
  
  our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY);
  
  
  __PACKAGE__->mk_accessors(qw(
      version
      flags
      dbh_connect_call
      dbh_method_call
      dbh_attributes
      dbh_last_insert_id_args
      sth_method_calls
      sth_result_attr
  ));
  __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
      meta
  ));
  
  
  sub new {
      my ($self, $args) = @_;
      $args->{version} ||= $VERSION;
      return $self->SUPER::new($args);
  }
  
  
  sub reset {
      my ($self, $flags) = @_;
      # remove everything except connect and version
      %$self = (
          version => $self->{version},
          dbh_connect_call => $self->{dbh_connect_call},
      );
      $self->{flags} = $flags if $flags;
  }
  
  
  sub init_request {
      my ($self, $method_and_args, $dbh) = @_;
      $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 );
      $self->dbh_method_call($method_and_args);
  }
  
  
  sub is_sth_request {
      return shift->{sth_result_attr};
  }
  
  
  sub statements {
      my $self = shift;
      my @statements;
      if (my $dbh_method_call = $self->dbh_method_call) {
          my $statement_method_regex = qr/^(?:do|prepare)$/;
          my (undef, $method, $arg1) = @$dbh_method_call;
          push @statements, $arg1 if $method && $method =~ $statement_method_regex;
      }
      return @statements;
  }
  
  
  sub is_idempotent {
      my $self = shift;
  
      if (my $flags = $self->flags) {
          return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY);
      }
  
      # else check if all statements are SELECT statement that don't include FOR UPDATE
      my @statements = $self->statements;
      # XXX this is very minimal for now, doesn't even allow comments before the select
      # (and can't ever work for "exec stored_procedure_name" kinds of statements)
      # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar")
      return 1 if @statements == grep {
                  m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi
               } @statements;
  
      return 0;
  }
  
  
  sub summary_as_text {
      my $self = shift;
      my ($context) = @_;
      my @s = '';
  
      if ($context && %$context) {
          my @keys = sort keys %$context;
          push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
      }
  
      my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call };
      $method ||= 'connect_cached';
      $pass = '***' if defined $pass;
      my $tmp = '';
      if ($attr) { 
          $tmp = { %{$attr||{}} }; # copy so we can edit
          $tmp->{Password} = '***' if exists $tmp->{Password};
          $tmp = "{ ".neat_list([ %$tmp ])." }";
      }
      push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp;
  
      if (my $flags = $self->flags) {
          push @s, sprintf "flags: 0x%x", $flags;
      }
  
      if (my $dbh_attr = $self->dbh_attributes) {
          push @s, sprintf "dbh->FETCH: %s", @$dbh_attr
              if @$dbh_attr;
      }
  
      my ($wantarray, $meth, @args) = @{ $self->dbh_method_call };
      my $args = neat_list(\@args);
      $args =~ s/\n+/ /g;
      push @s, sprintf "dbh->%s(%s)", $meth, $args;
  
      if (my $lii_args = $self->dbh_last_insert_id_args) {
          push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args);
      }
  
      for my $call (@{ $self->sth_method_calls || [] }) {
          my ($meth, @args) = @$call;
          ($args = neat_list(\@args)) =~ s/\n+/ /g;
          push @s, sprintf "sth->%s(%s)", $meth, $args;
      }
  
      if (my $sth_attr = $self->sth_result_attr) {
          push @s, sprintf "sth->FETCH: %s", %$sth_attr
              if %$sth_attr;
      }
  
      return join("\n\t", @s) . "\n";
  }
  
  
  sub outline_as_text { # one-line version of summary_as_text
      my $self = shift;
      my @s = '';
      my $neatlen = 80;
  
      if (my $flags = $self->flags) {
          push @s, sprintf "flags=0x%x", $flags;
      }
  
      my (undef, $meth, @args) = @{ $self->dbh_method_call };
      push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
  
      for my $call (@{ $self->sth_method_calls || [] }) {
          my ($meth, @args) = @$call;
          push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen);
      }
  
      my ($method, $dsn) = @{ $self->dbh_connect_call };
      push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting
  
      (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines
      return $outline;
  }
  
  1;
  
  =head1 NAME
  
  DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute
  
  =head1 DESCRIPTION
  
  This is an internal class.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_REQUEST

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Response.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_RESPONSE';
  package DBI::Gofer::Response;
  
  #   $Id: Response.pm 11565 2008-07-22 20:17:33Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  
  use Carp;
  use DBI qw(neat neat_list);
  
  use base qw(DBI::Util::_accessor Exporter);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 11565 $ =~ /(\d+)/o);
  
  use constant GOf_RESPONSE_EXECUTED => 0x0001;
  
  our @EXPORT = qw(GOf_RESPONSE_EXECUTED);
  
  
  __PACKAGE__->mk_accessors(qw(
      version
      rv
      err
      errstr
      state
      flags
      last_insert_id
      dbh_attributes
      sth_resultsets
      warnings
  ));
  __PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
      meta
  ));
  
  
  sub new {
      my ($self, $args) = @_;
      $args->{version} ||= $VERSION;
      chomp $args->{errstr} if $args->{errstr};
      return $self->SUPER::new($args);
  }   
  
  
  sub err_errstr_state {
      my $self = shift;
      return @{$self}{qw(err errstr state)};
  }
  
  sub executed_flag_set {
      my $flags = shift->flags
          or return 0;
      return $flags & GOf_RESPONSE_EXECUTED;
  }
  
  
  sub add_err {
      my ($self, $err, $errstr, $state, $trace) = @_;
  
      # acts like the DBI's set_err method.
      # this code copied from DBI::PurePerl's set_err method.
  
      chomp $errstr if $errstr;
      $state ||= '';
      carp ref($self)."->add_err($err, $errstr, $state)"
          if $trace and defined($err) || $errstr;
  
      my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state});
  
      if ($r_errstr) {
          $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err
                  if $r_err && $err && $r_err ne $err;
          $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
                  if $r_state and $r_state ne "S1000" && $state && $r_state ne $state;
          $r_errstr .= "\n$errstr" if $r_errstr ne $errstr;
      }   
      else { 
          $r_errstr = $errstr;
      }
  
      # assign if higher priority: err > "0" > "" > undef
      my $err_changed;
      if ($err                 # new error: so assign
          or !defined $r_err   # no existing warn/info: so assign
             # new warn ("0" len 1) > info ("" len 0): so assign
          or defined $err && length($err) > length($r_err)
      ) {
          $r_err = $err;
          ++$err_changed;
      }
  
      $r_state = ($state eq "00000") ? "" : $state
          if $state && $err_changed;
  
      ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state);
  
      return undef;
  }
  
  
  sub summary_as_text {
      my $self = shift;
      my ($context) = @_;
  
      my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
  
      my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
      $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr))
          if defined $err;
      $s[-1] .= sprintf(",  flags=0x%x", $self->{flags})
          if defined $self->{flags};
  
      push @s, "last_insert_id=%s", $self->last_insert_id
          if defined $self->last_insert_id;
  
      if (my $dbh_attr = $self->dbh_attributes) {
          my @keys = sort keys %$dbh_attr;
          push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys)
              if @keys;
      }   
  
      for my $rs (@{$self->sth_resultsets || []}) {
          my ($rowset, $err, $errstr, $state)
              = @{$rs}{qw(rowset err errstr state)};
          my $summary = "rowset: ";
          my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
          my $rows = $rowset ? @$rowset : 0;
          if ($rowset || $NUM_OF_FIELDS > 0) {
              $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS;
          }
          $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err;
          if ($rows) {
              my $NAME = $rs->{NAME};
              # generate 
              my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1;
              $summary .= sprintf " [%s]", join ", ", @colinfo;
              $summary .= ",..." if $rows > 1;
              # we can be a little more helpful for Sybase/MSSQL user
              $summary .= " syb_result_type=$rs->{syb_result_type}"
                  if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040;
          }
          push @s, $summary;
      }
      for my $w (@{$self->warnings || []}) {
          chomp $w;
          push @s, "warning: $w";
      }
      if ($context && %$context) { 
          my @keys = sort keys %$context;
          push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
      }       
      return join("\n\t", @s). "\n";
  }
  
  
  sub outline_as_text { # one-line version of summary_as_text
      my $self = shift;
      my ($context) = @_;
  
      my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state});
  
      my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
      $s .= sprintf(", err=%s %s", $err, neat($errstr))
          if defined $err;
      $s .= sprintf(", flags=0x%x", $self->{flags})
          if $self->{flags};
  
      if (my $sth_resultsets = $self->sth_resultsets) {
          $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets);
  
          my @rs;
          for my $rs (@{$self->sth_resultsets || []}) {
              my $summary = "";
              my ($rowset, $err, $errstr)
                  = @{$rs}{qw(rowset err errstr)};
              my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
              my $rows = $rowset ? @$rowset : 0;
              if ($rowset || $NUM_OF_FIELDS > 0) {
                  $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS;
              }
              $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr)
                  if defined $err;
              push @rs, $summary;
          }
          $s .= join "; ", map { "[$_]" } @rs;
      }
  
      return $s;
  }
  
  
  1;
  
  =head1 NAME
  
  DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer
  
  =head1 DESCRIPTION
  
  This is an internal class.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_RESPONSE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Serializer/Base.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_BASE';
  package DBI::Gofer::Serializer::Base;
  
  #   $Id: Base.pm 9949 2007-09-18 09:38:15Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  =head1 NAME
  
  DBI::Gofer::Serializer::Base - base class for Gofer serialization
  
  =head1 SYNOPSIS
  
      $serializer = $serializer_class->new();
  
      $string = $serializer->serialize( $data );
      ($string, $deserializer_class) = $serializer->serialize( $data );
  
      $data = $serializer->deserialize( $string );
  
  =head1 DESCRIPTION
  
  DBI::Gofer::Serializer::* classes implement a very minimal subset of the L<Data::Serializer> API.
  
  Gofer serializers are expected to be very fast and are not required to deal
  with anything other than non-blessed references to arrays and hashes, and plain scalars.
  
  =cut
  
  
  use strict;
  use warnings;
  
  use Carp qw(croak);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
  
  
  sub new {
      my $class = shift;
      my $deserializer_class = $class->deserializer_class;
      return bless { deserializer_class => $deserializer_class } => $class;
  }
  
  sub deserializer_class {
      my $self = shift;
      my $class = ref($self) || $self;
      $class =~ s/^DBI::Gofer::Serializer:://;
      return $class;
  }
  
  sub serialize {
      my $self = shift;
      croak ref($self)." has not implemented the serialize method";
  }
  
  sub deserialize {
      my $self = shift;
      croak ref($self)." has not implemented the deserialize method";
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_BASE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Serializer/DataDumper.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_DATADUMPER';
  package DBI::Gofer::Serializer::DataDumper;
  
  use strict;
  use warnings;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
  
  #   $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  =head1 NAME
  
  DBI::Gofer::Serializer::DataDumper - Gofer serialization using DataDumper
  
  =head1 SYNOPSIS
  
      $serializer = DBI::Gofer::Serializer::DataDumper->new();
  
      $string = $serializer->serialize( $data );
  
  =head1 DESCRIPTION
  
  Uses DataDumper to serialize. Deserialization is not supported.
  The output of this class is only meant for human consumption.
  
  See also L<DBI::Gofer::Serializer::Base>.
  
  =cut
  
  use Data::Dumper;
  
  use base qw(DBI::Gofer::Serializer::Base);
  
  
  sub serialize {
      my $self = shift;
      local $Data::Dumper::Indent    = 1;
      local $Data::Dumper::Terse     = 1;
      local $Data::Dumper::Useqq     = 0; # enabling this disables xs
      local $Data::Dumper::Sortkeys  = 1;
      local $Data::Dumper::Quotekeys = 0;
      local $Data::Dumper::Deparse   = 0;
      local $Data::Dumper::Purity    = 0;
      my $frozen = Data::Dumper::Dumper(shift);
      return $frozen unless wantarray;
      return ($frozen, $self->{deserializer_class});
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_DATADUMPER

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Serializer/Storable.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_STORABLE';
  package DBI::Gofer::Serializer::Storable;
  
  use strict;
  use warnings;
  
  use base qw(DBI::Gofer::Serializer::Base);
  
  #   $Id: Storable.pm 9949 2007-09-18 09:38:15Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  =head1 NAME
  
  DBI::Gofer::Serializer::Storable - Gofer serialization using Storable
  
  =head1 SYNOPSIS
  
      $serializer = DBI::Gofer::Serializer::Storable->new();
  
      $string = $serializer->serialize( $data );
      ($string, $deserializer_class) = $serializer->serialize( $data );
  
      $data = $serializer->deserialize( $string );
  
  =head1 DESCRIPTION
  
  Uses Storable::nfreeze() to serialize and Storable::thaw() to deserialize.
  
  The serialize() method sets local $Storable::forgive_me = 1; so it doesn't
  croak if it encounters any data types that can't be serialized, such as code refs.
  
  See also L<DBI::Gofer::Serializer::Base>.
  
  =cut
  
  use Storable qw(nfreeze thaw);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
  
  use base qw(DBI::Gofer::Serializer::Base);
  
  
  sub serialize {
      my $self = shift;
      local $Storable::forgive_me = 1; # for CODE refs etc
      my $frozen = nfreeze(shift);
      return $frozen unless wantarray;
      return ($frozen, $self->{deserializer_class});
  }
  
  sub deserialize {
      my $self = shift;
      return thaw(shift);
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_SERIALIZER_STORABLE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Transport/Base.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_BASE';
  package DBI::Gofer::Transport::Base;
  
  #   $Id: Base.pm 12536 2009-02-24 22:37:09Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use DBI;
  
  use base qw(DBI::Util::_accessor);
  
  use DBI::Gofer::Serializer::Storable;
  use DBI::Gofer::Serializer::DataDumper;
  
  
  our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
  
  
  __PACKAGE__->mk_accessors(qw(
      trace
      keep_meta_frozen
      serializer_obj
  ));
  
  
  # see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute
  sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] }
  
  
  sub new {
      my ($class, $args) = @_;
      $args->{trace} ||= $class->_init_trace;
      $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new();
      my $self = bless {}, $class;
      $self->$_( $args->{$_} ) for keys %$args;
      $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace;
      return $self;
  }
  
  my $packet_header_text  = "GoFER1:";
  my $packet_header_regex = qr/^GoFER(\d+):/;
  
  
  sub _freeze_data {
      my ($self, $data, $serializer, $skip_trace) = @_;
      my $frozen = eval {
          $self->_dump("freezing $self->{trace} ".ref($data), $data)
              if !$skip_trace and $self->trace;
  
          local $data->{meta}; # don't include meta in serialization
  	$serializer ||= $self->{serializer_obj};
          my ($data, $deserializer_class)  = $serializer->serialize($data);
  
          $packet_header_text . $data;
      };
      if ($@) {
          chomp $@;
          die "Error freezing ".ref($data)." object: $@";
      }
  
      # stash the frozen data into the data structure itself
      # to make life easy for the client caching code in DBD::Gofer::Transport::Base
      $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen;
  
      return $frozen;
  }
  # public aliases used by subclasses
  *freeze_request  = \&_freeze_data;
  *freeze_response = \&_freeze_data;
  
  
  sub _thaw_data {
      my ($self, $frozen_data, $serializer, $skip_trace) = @_;
      my $data;
      eval {
          # check for and extract our gofer header and the info it contains
          (my $frozen = $frozen_data) =~ s/$packet_header_regex//o
              or die "does not have gofer header\n";
          my ($t_version) = $1;
  	$serializer ||= $self->{serializer_obj};
          $data = $serializer->deserialize($frozen);
          die ref($serializer)."->deserialize didn't return a reference"
              unless ref $data;
          $data->{_transport}{version} = $t_version;
  
          $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen;
      };
      if ($@) {
          chomp(my $err = $@);
          # remove extra noise from Storable
          $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{};
          my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50);
          Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace;
          die $msg;
      }
      $self->_dump("thawing $self->{trace} ".ref($data), $data)
          if !$skip_trace and $self->trace;
  
      return $data;
  }
  # public aliases used by subclasses
  *thaw_request  = \&_thaw_data;
  *thaw_response = \&_thaw_data;
  
  
  # this should probably live in the request and response classes
  # and the tace level passed in
  sub _dump {
      my ($self, $label, $data) = @_;
  
      # don't dump the binary
      local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen};
  
      my $trace_level = $self->trace;
      my $summary;
      if ($trace_level >= 4) {
          require Data::Dumper;
          local $Data::Dumper::Indent    = 1;
          local $Data::Dumper::Terse     = 1;
          local $Data::Dumper::Useqq     = 0;
          local $Data::Dumper::Sortkeys  = 1;
          local $Data::Dumper::Quotekeys = 0;
          local $Data::Dumper::Deparse   = 0;
          local $Data::Dumper::Purity    = 0;
          $summary = Data::Dumper::Dumper($data);
      }
      elsif ($trace_level >= 2) {
          $summary = eval { $data->summary_as_text } || $@ || "no summary available\n";
      }
      else {
          $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n";
      }
      $self->trace_msg("$label: $summary");
  }
  
  
  sub trace_msg {
      my ($self, $msg, $min_level) = @_;
      $min_level = 1 unless defined $min_level;
      # transport trace level can override DBI's trace level
      $min_level = 0 if $self->trace >= $min_level;
      return DBI->trace_msg("gofer ".$msg, $min_level);
  }
  
  1;
  
  =head1 NAME
  
  DBI::Gofer::Transport::Base - Base class for Gofer transports
  
  =head1 DESCRIPTION
  
  This is the base class for server-side Gofer transports.
  
  It's also the base class for the client-side base class L<DBD::Gofer::Transport::Base>.
  
  This is an internal class.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_BASE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Transport/pipeone.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_PIPEONE';
  package DBI::Gofer::Transport::pipeone;
  
  #   $Id: pipeone.pm 12536 2009-02-24 22:37:09Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use DBI::Gofer::Execute;
  
  use base qw(DBI::Gofer::Transport::Base Exporter);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
  
  our @EXPORT = qw(run_one_stdio);
  
  my $executor = DBI::Gofer::Execute->new();
  
  sub run_one_stdio {
  
      my $transport = DBI::Gofer::Transport::pipeone->new();
  
      my $frozen_request = do { local $/; <STDIN> };
  
      my $response = $executor->execute_request( $transport->thaw_request($frozen_request) );
  
      my $frozen_response = $transport->freeze_response($response);
  
      print $frozen_response;
  
      # no point calling $executor->update_stats(...) for pipeONE
  }
  
  1;
  __END__
  
  =head1 NAME
  
  DBI::Gofer::Transport::pipeone - DBD::Gofer server-side transport for pipeone
  
  =head1 SYNOPSIS
  
  See L<DBD::Gofer::Transport::pipeone>.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_PIPEONE

$fatpacked{"darwin-thread-multi-2level/DBI/Gofer/Transport/stream.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_STREAM';
  package DBI::Gofer::Transport::stream;
  
  #   $Id: stream.pm 12536 2009-02-24 22:37:09Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  use DBI qw(dbi_time);
  use DBI::Gofer::Execute;
  
  use base qw(DBI::Gofer::Transport::pipeone Exporter);
  
  our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
  
  our @EXPORT = qw(run_stdio_hex);
  
  my $executor = DBI::Gofer::Execute->new();
  
  sub run_stdio_hex {
  
      my $transport = DBI::Gofer::Transport::stream->new();
      local $| = 1;
  
      DBI->trace_msg("$0 started (pid $$)\n");
  
      local $\; # OUTPUT_RECORD_SEPARATOR
      local $/ = "\012"; # INPUT_RECORD_SEPARATOR
      while ( defined( my $encoded_request = <STDIN> ) ) {
          my $time_received = dbi_time();
          $encoded_request =~ s/\015?\012$//;
  
          my $frozen_request = pack "H*", $encoded_request;
          my $request = $transport->thaw_request( $frozen_request );
  
          my $response = $executor->execute_request( $request );
  
          my $frozen_response = $transport->freeze_response($response);
          my $encoded_response = unpack "H*", $frozen_response;
  
          print $encoded_response, "\015\012"; # autoflushed due to $|=1
  
          # there's no way to access the stats currently
          # so this just serves as a basic test and illustration of update_stats()
          $executor->update_stats($request, $response, $frozen_request, $frozen_response, $time_received, 1);
      }
      DBI->trace_msg("$0 ending (pid $$)\n");
  }
  
  1;
  __END__
  
  =head1 NAME
  
  DBI::Gofer::Transport::stream - DBD::Gofer server-side transport for stream
  
  =head1 SYNOPSIS
  
  See L<DBD::Gofer::Transport::stream>.
  
  =head1 AUTHOR
  
  Tim Bunce, L<http://www.tim.bunce.name>
  
  =head1 LICENCE AND COPYRIGHT
  
  Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
  
  This module is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself. See L<perlartistic>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_GOFER_TRANSPORT_STREAM

$fatpacked{"darwin-thread-multi-2level/DBI/Profile.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILE';
  package DBI::Profile;
  
  =head1 NAME
  
  DBI::Profile - Performance profiling and benchmarking for the DBI
  
  =head1 SYNOPSIS
  
  The easiest way to enable DBI profiling is to set the DBI_PROFILE
  environment variable to 2 and then run your code as usual:
  
    DBI_PROFILE=2 prog.pl
  
  This will profile your program and then output a textual summary
  grouped by query when the program exits.  You can also enable profiling by
  setting the Profile attribute of any DBI handle:
  
    $dbh->{Profile} = 2;
  
  Then the summary will be printed when the handle is destroyed.
  
  Many other values apart from are possible - see L<"ENABLING A PROFILE"> below.
  
  =head1 DESCRIPTION
  
  The DBI::Profile module provides a simple interface to collect and
  report performance and benchmarking data from the DBI.
  
  For a more elaborate interface, suitable for larger programs, see
  L<DBI::ProfileDumper|DBI::ProfileDumper> and L<dbiprof|dbiprof>.
  For Apache/mod_perl applications see
  L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
  
  =head1 OVERVIEW
  
  Performance data collection for the DBI is built around several
  concepts which are important to understand clearly.
  
  =over 4
  
  =item Method Dispatch
  
  Every method call on a DBI handle passes through a single 'dispatch'
  function which manages all the common aspects of DBI method calls,
  such as handling the RaiseError attribute.
  
  =item Data Collection
  
  If profiling is enabled for a handle then the dispatch code takes
  a high-resolution timestamp soon after it is entered. Then, after
  calling the appropriate method and just before returning, it takes
  another high-resolution timestamp and calls a function to record
  the information.  That function is passed the two timestamps
  plus the DBI handle and the name of the method that was called.
  That data about a single DBI method call is called a I<profile sample>.
  
  =item Data Filtering
  
  If the method call was invoked by the DBI or by a driver then the call is
  ignored for profiling because the time spent will be accounted for by the
  original 'outermost' call for your code.
  
  For example, the calls that the selectrow_arrayref() method makes
  to prepare() and execute() etc. are not counted individually
  because the time spent in those methods is going to be allocated
  to the selectrow_arrayref() method when it returns. If this was not
  done then it would be very easy to double count time spent inside
  the DBI.
  
  =item Data Storage Tree
  
  The profile data is accumulated as 'leaves on a tree'. The 'path' through the
  branches of the tree to a particular leaf is determined dynamically for each sample.
  This is a key feature of DBI profiliing.
  
  For each profiled method call the DBI walks along the Path and uses each value
  in the Path to step into and grow the Data tree.
  
  For example, if the Path is
  
    [ 'foo', 'bar', 'baz' ]
  
  then the new profile sample data will be I<merged> into the tree at
  
    $h->{Profile}->{Data}->{foo}->{bar}->{baz}
  
  But it's not very useful to merge all the call data into one leaf node (except
  to get an overall 'time spent inside the DBI' total).  It's more common to want
  the Path to include dynamic values such as the current statement text and/or
  the name of the method called to show what the time spent inside the DBI was for.
  
  The Path can contain some 'magic cookie' values that are automatically replaced
  by corresponding dynamic values when they're used. These magic cookies always
  start with a punctuation character.
  
  For example a value of 'C<!MethodName>' in the Path causes the corresponding
  entry in the Data to be the name of the method that was called.
  For example, if the Path was:
  
    [ 'foo', '!MethodName', 'bar' ]
  
  and the selectall_arrayref() method was called, then the profile sample data
  for that call will be merged into the tree at:
  
    $h->{Profile}->{Data}->{foo}->{selectall_arrayref}->{bar}
  
  =item Profile Data
  
  Profile data is stored at the 'leaves' of the tree as references
  to an array of numeric values. For example:
  
    [
      106,                  # 0: count of samples at this node
      0.0312958955764771,   # 1: total duration
      0.000490069389343262, # 2: first duration
      0.000176072120666504, # 3: shortest duration
      0.00140702724456787,  # 4: longest duration
      1023115819.83019,     # 5: time of first sample
      1023115819.86576,     # 6: time of last sample
    ]
  
  After the first sample, later samples always update elements 0, 1, and 6, and
  may update 3 or 4 depending on the duration of the sampled call.
  
  =back
  
  =head1 ENABLING A PROFILE
  
  Profiling is enabled for a handle by assigning to the Profile
  attribute. For example:
  
    $h->{Profile} = DBI::Profile->new();
  
  The Profile attribute holds a blessed reference to a hash object
  that contains the profile data and attributes relating to it.
  
  The class the Profile object is blessed into is expected to
  provide at least a DESTROY method which will dump the profile data
  to the DBI trace file handle (STDERR by default).
  
  All these examples have the same effect as each other:
  
    $h->{Profile} = 0;
    $h->{Profile} = "/DBI::Profile";
    $h->{Profile} = DBI::Profile->new();
    $h->{Profile} = {};
    $h->{Profile} = { Path => [] };
  
  Similarly, these examples have the same effect as each other:
  
    $h->{Profile} = 6;
    $h->{Profile} = "6/DBI::Profile";
    $h->{Profile} = "!Statement:!MethodName/DBI::Profile";
    $h->{Profile} = { Path => [ '!Statement', '!MethodName' ] };
  
  If a non-blessed hash reference is given then the DBI::Profile
  module is automatically C<require>'d and the reference is blessed
  into that class.
  
  If a string is given then it is processed like this:
  
      ($path, $module, $args) = split /\//, $string, 3
  
      @path = split /:/, $path
      @args = split /:/, $args
  
      eval "require $module" if $module
      $module ||= "DBI::Profile"
  
      $module->new( Path => \@Path, @args )
  
  So the first value is used to select the Path to be used (see below).
  The second value, if present, is used as the name of a module which
  will be loaded and it's C<new> method called. If not present it
  defaults to DBI::Profile. Any other values are passed as arguments
  to the C<new> method. For example: "C<2/DBIx::OtherProfile/Foo:42>".
  
  Numbers can be used as a shorthand way to enable common Path values.
  The simplest way to explain how the values are interpreted is to show the code:
  
      push @Path, "DBI"           if $path_elem & 0x01;
      push @Path, "!Statement"    if $path_elem & 0x02;
      push @Path, "!MethodName"   if $path_elem & 0x04;
      push @Path, "!MethodClass"  if $path_elem & 0x08;
      push @Path, "!Caller2"      if $path_elem & 0x10;
  
  So "2" is the same as "!Statement" and "6" (2+4) is the same as
  "!Statement:!Method".  Those are the two most commonly used values.  Using a
  negative number will reverse the path. Thus "-6" will group by method name then
  statement.
  
  The spliting and parsing of string values assigned to the Profile
  attribute may seem a little odd, but there's a good reason for it.
  Remember that attributes can be embedded in the Data Source Name
  string which can be passed in to a script as a parameter. For
  example:
  
      dbi:DriverName(Profile=>2):dbname
      dbi:DriverName(Profile=>{Username}:!Statement/MyProfiler/Foo:42):dbname
  
  And also, if the C<DBI_PROFILE> environment variable is set then
  The DBI arranges for every driver handle to share the same profile
  object. When perl exits a single profile summary will be generated
  that reflects (as nearly as practical) the total use of the DBI by
  the application.
  
  
  =head1 THE PROFILE OBJECT
  
  The DBI core expects the Profile attribute value to be a hash
  reference and if the following values don't exist it will create
  them as needed:
  
  =head2 Data
  
  A reference to a hash containing the collected profile data.
  
  =head2 Path
  
  The Path value is a reference to an array. Each element controls the
  value to use at the corresponding level of the profile Data tree.
  
  If the value of Path is anything other than an array reference,
  it is treated as if it was:
  
  	[ '!Statement' ]
  
  The elements of Path array can be one of the following types:
  
  =head3 Special Constant
  
  B<!Statement>
  
  Use the current Statement text. Typically that's the value of the Statement
  attribute for the handle the method was called with. Some methods, like
  commit() and rollback(), are unrelated to a particular statement. For those
  methods !Statement records an empty string.
  
  For statement handles this is always simply the string that was
  given to prepare() when the handle was created.  For database handles
  this is the statement that was last prepared or executed on that
  database handle. That can lead to a little 'fuzzyness' because, for
  example, calls to the quote() method to build a new statement will
  typically be associated with the previous statement. In practice
  this isn't a significant issue and the dynamic Path mechanism can
  be used to setup your own rules.
  
  B<!MethodName>
  
  Use the name of the DBI method that the profile sample relates to.
  
  B<!MethodClass>
  
  Use the fully qualified name of the DBI method, including
  the package, that the profile sample relates to. This shows you
  where the method was implemented. For example:
  
    'DBD::_::db::selectrow_arrayref' =>
        0.022902s
    'DBD::mysql::db::selectrow_arrayref' =>
        2.244521s / 99 = 0.022445s avg (first 0.022813s, min 0.022051s, max 0.028932s)
  
  The "DBD::_::db::selectrow_arrayref" shows that the driver has
  inherited the selectrow_arrayref method provided by the DBI.
  
  But you'll note that there is only one call to
  DBD::_::db::selectrow_arrayref but another 99 to
  DBD::mysql::db::selectrow_arrayref. Currently the first
  call Pern't record the true location. That may change.
  
  B<!Caller>
  
  Use a string showing the filename and line number of the code calling the method.
  
  B<!Caller2>
  
  Use a string showing the filename and line number of the code calling the
  method, as for !Caller, but also include filename and line number of the code
  that called that. Calls from DBI:: and DBD:: packages are skipped.
  
  B<!File>
  
  Same as !Caller above except that only the filename is included, not the line number.
  
  B<!File2>
  
  Same as !Caller2 above except that only the filenames are included, not the line number.
  
  B<!Time>
  
  Use the current value of time(). Rarely used. See the more useful C<!Time~N> below.
  
  B<!Time~N>
  
  Where C<N> is an integer. Use the current value of time() but with reduced precision.
  The value used is determined in this way:
  
      int( time() / N ) * N
  
  This is a useful way to segregate a profile into time slots. For example:
  
      [ '!Time~60', '!Statement' ]
  
  =head3 Code Reference
  
  The subroutine is passed the handle it was called on and the DBI method name.
  The current Statement is in $_. The statement string should not be modified,
  so most subs start with C<local $_ = $_;>.
  
  The list of values it returns is used at that point in the Profile Path.
  
  The sub can 'veto' (reject) a profile sample by including a reference to undef
  in the returned list. That can be useful when you want to only profile
  statements that match a certain pattern, or only profile certain methods.
  
  =head3 Subroutine Specifier
  
  A Path element that begins with 'C<&>' is treated as the name of a subroutine
  in the DBI::ProfileSubs namespace and replaced with the corresponding code reference.
  
  Currently this only works when the Path is specified by the C<DBI_PROFILE>
  environment variable.
  
  Also, currently, the only subroutine in the DBI::ProfileSubs namespace is
  C<'&norm_std_n3'>. That's a very handy subroutine when profiling code that
  doesn't use placeholders. See L<DBI::ProfileSubs> for more information.
  
  =head3 Attribute Specifier
  
  A string enclosed in braces, such as 'C<{Username}>', specifies that the current
  value of the corresponding database handle attribute should be used at that
  point in the Path.
  
  =head3 Reference to a Scalar
  
  Specifies that the current value of the referenced scalar be used at that point
  in the Path.  This provides an efficient way to get 'contextual' values into
  your profile.
  
  =head3 Other Values
  
  Any other values are stringified and used literally.
  
  (References, and values that begin with punctuation characters are reserved.)
  
  
  =head1 REPORTING
  
  =head2 Report Format
  
  The current accumulated profile data can be formatted and output using
  
      print $h->{Profile}->format;
  
  To discard the profile data and start collecting fresh data
  you can do:
  
      $h->{Profile}->{Data} = undef;
  
  
  The default results format looks like this:
  
    DBI::Profile: 0.001015s 42.7% (5 calls) programname @ YYYY-MM-DD HH:MM:SS
    '' =>
        0.000024s / 2 = 0.000012s avg (first 0.000015s, min 0.000009s, max 0.000015s)
    'SELECT mode,size,name FROM table' =>
        0.000991s / 3 = 0.000330s avg (first 0.000678s, min 0.000009s, max 0.000678s)
  
  Which shows the total time spent inside the DBI, with a count of
  the total number of method calls and the name of the script being
  run, then a formated version of the profile data tree.
  
  If the results are being formated when the perl process is exiting
  (which is usually the case when the DBI_PROFILE environment variable
  is used) then the percentage of time the process spent inside the
  DBI is also shown. If the process is not exiting then the percentage is
  calculated using the time between the first and last call to the DBI.
  
  In the example above the paths in the tree are only one level deep and
  use the Statement text as the value (that's the default behaviour).
  
  The merged profile data at the 'leaves' of the tree are presented
  as total time spent, count, average time spent (which is simply total
  time divided by the count), then the time spent on the first call,
  the time spent on the fastest call, and finally the time spent on
  the slowest call.
  
  The 'avg', 'first', 'min' and 'max' times are not particularly
  useful when the profile data path only contains the statement text.
  Here's an extract of a more detailed example using both statement
  text and method name in the path:
  
    'SELECT mode,size,name FROM table' =>
        'FETCH' =>
            0.000076s
        'fetchrow_hashref' =>
            0.036203s / 108 = 0.000335s avg (first 0.000490s, min 0.000152s, max 0.002786s)
  
  Here you can see the 'avg', 'first', 'min' and 'max' for the
  108 calls to fetchrow_hashref() become rather more interesting.
  Also the data for FETCH just shows a time value because it was only
  called once.
  
  Currently the profile data is output sorted by branch names. That
  may change in a later version so the leaf nodes are sorted by total
  time per leaf node.
  
  
  =head2 Report Destination
  
  The default method of reporting is for the DESTROY method of the
  Profile object to format the results and write them using:
  
      DBI->trace_msg($results, 0);  # see $ON_DESTROY_DUMP below
  
  to write them to the DBI trace() filehandle (which defaults to
  STDERR). To direct the DBI trace filehandle to write to a file
  without enabling tracing the trace() method can be called with a
  trace level of 0. For example:
  
      DBI->trace(0, $filename);
  
  The same effect can be achieved without changing the code by
  setting the C<DBI_TRACE> environment variable to C<0=filename>.
  
  The $DBI::Profile::ON_DESTROY_DUMP variable holds a code ref
  that's called to perform the output of the formatted results.
  The default value is:
  
    $ON_DESTROY_DUMP = sub { DBI->trace_msg($results, 0) };
  
  Apart from making it easy to send the dump elsewhere, it can also
  be useful as a simple way to disable dumping results.
  
  =head1 CHILD HANDLES
  
  Child handles inherit a reference to the Profile attribute value
  of their parent.  So if profiling is enabled for a database handle
  then by default the statement handles created from it all contribute
  to the same merged profile data tree.
  
  
  =head1 PROFILE OBJECT METHODS
  
  =head2 format
  
  See L</REPORTING>.
  
  =head2 as_node_path_list
  
    @ary = $dbh->{Profile}->as_node_path_list();
    @ary = $dbh->{Profile}->as_node_path_list($node, $path);
  
  Returns the collected data ($dbh->{Profile}{Data}) restructured into a list of
  array refs, one for each leaf node in the Data tree. This 'flat' structure is
  often much simpler for applications to work with.
  
  The first element of each array ref is a reference to the leaf node.
  The remaining elements are the 'path' through the data tree to that node.
  
  For example, given a data tree like this:
  
      {key1a}{key2a}[node1]
      {key1a}{key2b}[node2]
      {key1b}{key2a}{key3a}[node3]
  
  The as_node_path_list() method  will return this list:
  
      [ [node1], 'key1a', 'key2a' ]
      [ [node2], 'key1a', 'key2b' ]
      [ [node3], 'key1b', 'key2a', 'key3a' ]
  
  The nodes are ordered by key, depth-first.
  
  The $node argument can be used to focus on a sub-tree.
  If not specified it defaults to $dbh->{Profile}{Data}.
  
  The $path argument can be used to specify a list of path elements that will be
  added to each element of the returned list. If not specified it defaults to a a
  ref to an empty array.
  
  =head2 as_text
  
    @txt = $dbh->{Profile}->as_text();
    $txt = $dbh->{Profile}->as_text({
        node      => undef,
        path      => [],
        separator => " > ",
        format    => '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
        sortsub   => sub { ... },
    );
  
  Returns the collected data ($dbh->{Profile}{Data}) reformatted into a list of formatted strings.
  In scalar context the list is returned as a single contatenated string.
  
  A hashref can be used to pass in arguments, the default values are shown in the example above.
  
  The C<node> and <path> arguments are passed to as_node_path_list().
  
  The C<separator> argument is used to join the elemets of the path for each leaf node.
  
  The C<sortsub> argument is used to pass in a ref to a sub that will order the list.
  The subroutine will be passed a reference to the array returned by
  as_node_path_list() and should sort the contents of the array in place.
  The return value from the sub is ignored. For example, to sort the nodes by the
  second level key you could use:
  
    sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary }
  
  The C<format> argument is a C<sprintf> format string that specifies the format
  to use for each leaf node.  It uses the explicit format parameter index
  mechanism to specify which of the arguments should appear where in the string.
  The arguments to sprintf are:
  
       1:  path to node, joined with the separator
       2:  average duration (total duration/count)
           (3 thru 9 are currently unused)
      10:  count
      11:  total duration
      12:  first duration
      13:  smallest duration
      14:  largest duration
      15:  time of first call
      16:  time of first call
  
  =head1 CUSTOM DATA MANIPULATION
  
  Recall that C<< $h->{Profile}->{Data} >> is a reference to the collected data.
  Either to a 'leaf' array (when the Path is empty, i.e., DBI_PROFILE env var is 1),
  or a reference to hash containing values that are either further hash
  references or leaf array references.
  
  Sometimes it's useful to be able to summarise some or all of the collected data.
  The dbi_profile_merge_nodes() function can be used to merge leaf node values.
  
  =head2 dbi_profile_merge_nodes
  
    use DBI qw(dbi_profile_merge_nodes);
  
    $time_in_dbi = dbi_profile_merge_nodes(my $totals=[], @$leaves);
  
  Merges profile data node. Given a reference to a destination array, and zero or
  more references to profile data, merges the profile data into the destination array.
  For example:
  
    $time_in_dbi = dbi_profile_merge_nodes(
        my $totals=[],
        [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
        [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
    );        
  
  $totals will then contain
  
    [ 25, 0.93, 0.11, 0.01, 0.23, 1023110000, 1023110010 ]
  
  and $time_in_dbi will be 0.93;
  
  The second argument need not be just leaf nodes. If given a reference to a hash
  then the hash is recursively searched for for leaf nodes and all those found
  are merged.
  
  For example, to get the time spent 'inside' the DBI during an http request,
  your logging code run at the end of the request (i.e. mod_perl LogHandler)
  could use:
  
    my $time_in_dbi = 0;
    if (my $Profile = $dbh->{Profile}) { # if DBI profiling is enabled
        $time_in_dbi = dbi_profile_merge_nodes(my $total=[], $Profile->{Data});
        $Profile->{Data} = {}; # reset the profile data
    }
  
  If profiling has been enabled then $time_in_dbi will hold the time spent inside
  the DBI for that handle (and any other handles that share the same profile data)
  since the last request.
  
  Prior to DBI 1.56 the dbi_profile_merge_nodes() function was called dbi_profile_merge().
  That name still exists as an alias.
  
  =head1 CUSTOM DATA COLLECTION
  
  =head2 Using The Path Attribute
  
    XXX example to be added later using a selectall_arrayref call
    XXX nested inside a fetch loop where the first column of the
    XXX outer loop is bound to the profile Path using
    XXX bind_column(1, \${ $dbh->{Profile}->{Path}->[0] })
    XXX so you end up with separate profiles for each loop
    XXX (patches welcome to add this to the docs :)
  
  =head2 Adding Your Own Samples
  
  The dbi_profile() function can be used to add extra sample data
  into the profile data tree. For example:
  
      use DBI;
      use DBI::Profile (dbi_profile dbi_time);
  
      my $t1 = dbi_time(); # floating point high-resolution time
  
      ... execute code you want to profile here ...
  
      my $t2 = dbi_time();
      dbi_profile($h, $statement, $method, $t1, $t2);
  
  The $h parameter is the handle the extra profile sample should be
  associated with. The $statement parameter is the string to use where
  the Path specifies !Statement. If $statement is undef
  then $h->{Statement} will be used. Similarly $method is the string
  to use if the Path specifies !MethodName. There is no
  default value for $method.
  
  The $h->{Profile}{Path} attribute is processed by dbi_profile() in
  the usual way.
  
  The $h parameter is usually a DBI handle but it can also be a reference to a
  hash, in which case the dbi_profile() acts on each defined value in the hash.
  This is an efficient way to update multiple profiles with a single sample,
  and is used by the L<DashProfiler> module.
  
  =head1 SUBCLASSING
  
  Alternate profile modules must subclass DBI::Profile to help ensure
  they work with future versions of the DBI.
  
  
  =head1 CAVEATS
  
  Applications which generate many different statement strings
  (typically because they don't use placeholders) and profile with
  !Statement in the Path (the default) will consume memory
  in the Profile Data structure for each statement. Use a code ref
  in the Path to return an edited (simplified) form of the statement.
  
  If a method throws an exception itself (not via RaiseError) then
  it won't be counted in the profile.
  
  If a HandleError subroutine throws an exception (rather than returning
  0 and letting RaiseError do it) then the method call won't be counted
  in the profile.
  
  Time spent in DESTROY is added to the profile of the parent handle.
  
  Time spent in DBI->*() methods is not counted. The time spent in
  the driver connect method, $drh->connect(), when it's called by
  DBI->connect is counted if the DBI_PROFILE environment variable is set.
  
  Time spent fetching tied variables, $DBI::errstr, is counted.
  
  Time spent in FETCH for $h->{Profile} is not counted, so getting the profile
  data doesn't alter it.
  
  DBI::PurePerl does not support profiling (though it could in theory).
  
  A few platforms don't support the gettimeofday() high resolution
  time function used by the DBI (and available via the dbi_time() function).
  In which case you'll get integer resolution time which is mostly useless.
  
  On Windows platforms the dbi_time() function is limited to millisecond
  resolution. Which isn't sufficiently fine for our needs, but still
  much better than integer resolution. This limited resolution means
  that fast method calls will often register as taking 0 time. And
  timings in general will have much more 'jitter' depending on where
  within the 'current millisecond' the start and and timing was taken.
  
  This documentation could be more clear. Probably needs to be reordered
  to start with several examples and build from there.  Trying to
  explain the concepts first seems painful and to lead to just as
  many forward references.  (Patches welcome!)
  
  =cut
  
  
  use strict;
  use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  use Exporter ();
  use UNIVERSAL ();
  use Carp;
  
  use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge);
  
  $VERSION = sprintf("2.%06d", q$Revision: 13581 $ =~ /(\d+)/o);
  
  
  @ISA = qw(Exporter);
  @EXPORT = qw(
      DBIprofile_Statement
      DBIprofile_MethodName
      DBIprofile_MethodClass
      dbi_profile
      dbi_profile_merge_nodes
      dbi_profile_merge
      dbi_time
  );
  @EXPORT_OK = qw(
      format_profile_thingy
  );
  
  use constant DBIprofile_Statement	=> '!Statement';
  use constant DBIprofile_MethodName	=> '!MethodName';
  use constant DBIprofile_MethodClass	=> '!MethodClass';
  
  our $ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) };
  our $ON_FLUSH_DUMP   = sub { DBI->trace_msg(shift, 0) };
  
  sub new {
      my $class = shift;
      my $profile = { @_ };
      return bless $profile => $class;
  }
  
  
  sub _auto_new {
      my $class = shift;
      my ($arg) = @_;
  
      # This sub is called by DBI internals when a non-hash-ref is
      # assigned to the Profile attribute. For example
      #	dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname
      # This sub works out what to do and returns a suitable hash ref.
      
      $arg =~ s/^DBI::/2\/DBI::/
          and carp "Automatically changed old-style DBI::Profile specification to $arg";
  
      # it's a path/module/arg/arg/arg list
      my ($path, $package, $args) = split /\//, $arg, 3;
      my @args = (defined $args) ? split(/:/, $args, -1) : ();
      my @Path;
  
      for my $element (split /:/, $path) {
          if (DBI::looks_like_number($element)) {
              my $reverse = ($element < 0) ? ($element=-$element, 1) : 0;
              my @p;
              # a single "DBI" is special-cased in format()
              push @p, "DBI"			if $element & 0x01;
              push @p, DBIprofile_Statement	if $element & 0x02;
              push @p, DBIprofile_MethodName	if $element & 0x04;
              push @p, DBIprofile_MethodClass	if $element & 0x08;
              push @p, '!Caller2'            	if $element & 0x10;
              push @Path, ($reverse ? reverse @p : @p);
          }
          elsif ($element =~ m/^&(\w.*)/) {
              my $name = "DBI::ProfileSubs::$1"; # capture $1 early
              require DBI::ProfileSubs;
              my $code = do { no strict; *{$name}{CODE} };
              if (defined $code) {
                  push @Path, $code;
              }
              else {
                  warn "$name: subroutine not found\n";
                  push @Path, $element;
              }
          }
          else {
              push @Path, $element;
          }
      }
  
      eval "require $package" if $package; # sliently ignores errors
      $package ||= $class;
  
      return $package->new(Path => \@Path, @args);
  }
  
  
  sub empty {             # empty out profile data
      my $self = shift;
      DBI->trace_msg("profile data discarded\n",0) if $self->{Trace};
      $self->{Data} = undef;
  }   
  
  sub filename {          # baseclass method, see DBI::ProfileDumper
      return undef;
  }
  
  sub flush_to_disk {     # baseclass method, see DBI::ProfileDumper & DashProfiler::Core
      my $self = shift;
      return unless $ON_FLUSH_DUMP;
      return unless $self->{Data};
      my $detail = $self->format();
      $ON_FLUSH_DUMP->($detail) if $detail;
  }
  
  
  sub as_node_path_list {
      my ($self, $node, $path) = @_;
      # convert the tree into an array of arrays
      # from 
      #   {key1a}{key2a}[node1]
      #   {key1a}{key2b}[node2]
      #   {key1b}{key2a}{key3a}[node3]
      # to
      #   [ [node1], 'key1a', 'key2a' ]
      #   [ [node2], 'key1a', 'key2b' ]
      #   [ [node3], 'key1b', 'key2a', 'key3a' ]
  
      $node ||= $self->{Data} or return;
      $path ||= [];
      if (ref $node eq 'HASH') {    # recurse
          $path = [ @$path, undef ];
          return map {
              $path->[-1] = $_;
              ($node->{$_}) ? $self->as_node_path_list($node->{$_}, $path) : ()
          } sort keys %$node;
      }
      return [ $node, @$path ];
  }
  
  
  sub as_text {
      my ($self, $args_ref) = @_;
      my $separator = $args_ref->{separator} || " > ";
      my $format_path_element = $args_ref->{format_path_element}
          || "%s"; # or e.g., " key%2$d='%s'"
      my $format    = $args_ref->{format}
          || '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
      
      my @node_path_list = $self->as_node_path_list(undef, $args_ref->{path});
  
      $args_ref->{sortsub}->(\@node_path_list) if $args_ref->{sortsub};
  
      my $eval = "qr/".quotemeta($separator)."/";
      my $separator_re = eval($eval) || quotemeta($separator);
      #warn "[$eval] = [$separator_re]";
      my @text;
      my @spare_slots = (undef) x 7;
      for my $node_path (@node_path_list) {
          my ($node, @path) = @$node_path;
          my $idx = 0;
          for (@path) {
              s/[\r\n]+/ /g;
              s/$separator_re/ /g;
              $_ = sprintf $format_path_element, $_, ++$idx;
          }
          push @text, sprintf $format,
              join($separator, @path),                  # 1=path
              ($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg
              @spare_slots,
              @$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max, 15=first_called, 16=last_called
      }       
      return @text if wantarray;
      return join "", @text;
  }   
  
  
  sub format {
      my $self = shift;
      my $class = ref($self) || $self;
      
      my $prologue = "$class: ";
      my $detail = $self->format_profile_thingy(
  	$self->{Data}, 0, "    ",
  	my $path = [],
  	my $leaves = [],
      )."\n";
  
      if (@$leaves) {
  	dbi_profile_merge_nodes(my $totals=[], @$leaves);
  	my ($count, $time_in_dbi, undef, undef, undef, $t1, $t2) = @$totals;
  	(my $progname = $0) =~ s:.*/::;
  	if ($count) {
  	    $prologue .= sprintf "%fs ", $time_in_dbi;
  	    my $perl_time = ($DBI::PERL_ENDING) ? time() - $^T : $t2-$t1;
  	    $prologue .= sprintf "%.2f%% ", $time_in_dbi/$perl_time*100 if $perl_time;
  	    my @lt = localtime(time);
  	    my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d",
  		1900+$lt[5], $lt[4]+1, @lt[3,2,1,0];
  	    $prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count;
  	}
  	if (@$leaves == 1 && ref($self->{Data}) eq 'HASH' && $self->{Data}->{DBI}) {
  	    $detail = "";	# hide the "DBI" from DBI_PROFILE=1
  	}
      }
      return ($prologue, $detail) if wantarray;
      return $prologue.$detail;
  }
  
  
  sub format_profile_leaf {
      my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
      croak "format_profile_leaf called on non-leaf ($thingy)"
  	unless UNIVERSAL::isa($thingy,'ARRAY');
  
      push @$leaves, $thingy if $leaves;
      my ($count, $total_time, $first_time, $min, $max, $first_called, $last_called) = @$thingy;
      return sprintf "%s%fs\n", ($pad x $depth), $total_time
  	if $count <= 1;
      return sprintf "%s%fs / %d = %fs avg (first %fs, min %fs, max %fs)\n",
  	($pad x $depth), $total_time, $count, $count ? $total_time/$count : 0,
  	$first_time, $min, $max;
  }
  
  
  sub format_profile_branch {
      my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
      croak "format_profile_branch called on non-branch ($thingy)"
  	unless UNIVERSAL::isa($thingy,'HASH');
      my @chunk;
      my @keys = sort keys %$thingy;
      while ( @keys ) {
  	my $k = shift @keys;
  	my $v = $thingy->{$k};
  	push @$path, $k;
  	push @chunk, sprintf "%s'%s' =>\n%s",
  	    ($pad x $depth), $k,
  	    $self->format_profile_thingy($v, $depth+1, $pad, $path, $leaves);
  	pop @$path;
      }
      return join "", @chunk;
  }
  
  
  sub format_profile_thingy {
      my ($self, $thingy, $depth, $pad, $path, $leaves) = @_;
      return "undef" if not defined $thingy;
      return $self->format_profile_leaf(  $thingy, $depth, $pad, $path, $leaves)
  	if UNIVERSAL::isa($thingy,'ARRAY');
      return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves)
  	if UNIVERSAL::isa($thingy,'HASH');
      return "$thingy\n";
  }
  
  
  sub on_destroy {
      my $self = shift;
      return unless $ON_DESTROY_DUMP;
      return unless $self->{Data};
      my $detail = $self->format();
      $ON_DESTROY_DUMP->($detail) if $detail;
  }
  
  sub DESTROY {
      my $self = shift;
      local $@;
      eval { $self->on_destroy };
      if ($@) {
          chomp $@;
          my $class = ref($self) || $self;
          DBI->trace_msg("$class on_destroy failed: $@", 0);
      }
  }
  
  1;
  
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILE

$fatpacked{"darwin-thread-multi-2level/DBI/ProfileData.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDATA';
  package DBI::ProfileData;
  use strict;
  
  =head1 NAME
  
  DBI::ProfileData - manipulate DBI::ProfileDumper data dumps
  
  =head1 SYNOPSIS
  
  The easiest way to use this module is through the dbiprof frontend
  (see L<dbiprof> for details):
  
    dbiprof --number 15 --sort count
  
  This module can also be used to roll your own profile analysis:
  
    # load data from dbi.prof
    $prof = DBI::ProfileData->new(File => "dbi.prof");
  
    # get a count of the records (unique paths) in the data set
    $count = $prof->count();
  
    # sort by longest overall time
    $prof->sort(field => "longest");
  
    # sort by longest overall time, least to greatest
    $prof->sort(field => "longest", reverse => 1);
  
    # exclude records with key2 eq 'disconnect'
    $prof->exclude(key2 => 'disconnect');
  
    # exclude records with key1 matching /^UPDATE/i
    $prof->exclude(key1 => qr/^UPDATE/i);
  
    # remove all records except those where key1 matches /^SELECT/i
    $prof->match(key1 => qr/^SELECT/i);
  
    # produce a formatted report with the given number of items
    $report = $prof->report(number => 10); 
  
    # clone the profile data set
    $clone = $prof->clone();
  
    # get access to hash of header values
    $header = $prof->header();
  
    # get access to sorted array of nodes
    $nodes = $prof->nodes();
  
    # format a single node in the same style as report()
    $text = $prof->format($nodes->[0]);
  
    # get access to Data hash in DBI::Profile format
    $Data = $prof->Data();
  
  =head1 DESCRIPTION
  
  This module offers the ability to read, manipulate and format
  DBI::ProfileDumper profile data.  
  
  Conceptually, a profile consists of a series of records, or nodes,
  each of each has a set of statistics and set of keys.  Each record
  must have a unique set of keys, but there is no requirement that every
  record have the same number of keys.
  
  =head1 METHODS
  
  The following methods are supported by DBI::ProfileData objects.
  
  =cut
  
  
  our $VERSION = sprintf("2.%06d", q$Revision: 10007 $ =~ /(\d+)/o);
  
  use Carp qw(croak);
  use Symbol;
  use Fcntl qw(:flock);
  
  use DBI::Profile qw(dbi_profile_merge);
  
  # some constants for use with node data arrays
  sub COUNT     () { 0 };
  sub TOTAL     () { 1 };
  sub FIRST     () { 2 };
  sub SHORTEST  () { 3 };
  sub LONGEST   () { 4 };
  sub FIRST_AT  () { 5 };
  sub LAST_AT   () { 6 };
  sub PATH      () { 7 };
  
  
  my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK})
      ? $ENV{DBI_PROFILE_FLOCK}
      : do { local $@; eval { flock STDOUT, 0; 1 } };
  
  
  =head2 $prof = DBI::ProfileData->new(File => "dbi.prof")
  
  =head2 $prof = DBI::ProfileData->new(File => "dbi.prof", Filter => sub { ... })
  
  =head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ])
  
  Creates a a new DBI::ProfileData object.  Takes either a single file
  through the File option or a list of Files in an array ref.  If
  multiple files are specified then the header data from the first file
  is used.
  
  =head3 Files
  
  Reference to an array of file names to read.
  
  =head3 File
  
  Name of file to read. Takes precedence over C<Files>.
  
  =head3 DeleteFiles
  
  If true, the files are deleted after being read.
  
  Actually the files are renamed with a C.deleteme> suffix before being read,
  and then, after reading all the files, they're all deleted together.
  
  The files are locked while being read which, combined with the rename, makes it
  safe to 'consume' files that are still being generated by L<DBI::ProfileDumper>.
  
  =head3 Filter
  
  The C<Filter> parameter can be used to supply a code reference that can
  manipulate the profile data as it is being read. This is most useful for
  editing SQL statements so that slightly different statements in the raw data
  will be merged and aggregated in the loaded data. For example:
  
    Filter => sub {
        my ($path_ref, $data_ref) = @_;
        s/foo = '.*?'/foo = '...'/ for @$path_ref;
    }
  
  Here's an example that performs some normalization on the SQL. It converts all
  numbers to C<N> and all quoted strings to C<S>.  It can also convert digits to
  N within names. Finally, it summarizes long "IN (...)" clauses.
  
  It's aggressive and simplistic, but it's often sufficient, and serves as an
  example that you can tailor to suit your own needs:
  
    Filter => sub {
        my ($path_ref, $data_ref) = @_;
        local $_ = $path_ref->[0]; # whichever element contains the SQL Statement
        s/\b\d+\b/N/g;             # 42 -> N
        s/\b0x[0-9A-Fa-f]+\b/N/g;  # 0xFE -> N
        s/'.*?'/'S'/g;             # single quoted strings (doesn't handle escapes)
        s/".*?"/"S"/g;             # double quoted strings (doesn't handle escapes)
        # convert names like log_20001231 into log_NNNNNNNN, controlled by $opt{n}
        s/([a-z_]+)(\d{$opt{n},})/$1.('N' x length($2))/ieg if $opt{n};
        # abbreviate massive "in (...)" statements and similar
        s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg;
    }
  
  It's often better to perform this kinds of normalization in the DBI while the
  data is being collected, to avoid too much memory being used by storing profile
  data for many different SQL statement. See L<DBI::Profile>.
  
  =cut
  
  sub new {
      my $pkg = shift;
      my $self = {                
                  Files        => [ "dbi.prof" ],
  		Filter       => undef,
                  DeleteFiles  => 0,
                  LockFile     => $HAS_FLOCK,
                  _header      => {},
                  _nodes       => [],
                  _node_lookup => {},
                  _sort        => 'none',
                  @_
                 };
      bless $self, $pkg;
      
      # File (singular) overrides Files (plural)
      $self->{Files} = [ $self->{File} ] if exists $self->{File};
  
      $self->_read_files();
      return $self;
  }
  
  # read files into _header and _nodes
  sub _read_files {
      my $self = shift;
      my $files  = $self->{Files};
      my $read_header = 0;
      my @files_to_delete;
    
      my $fh = gensym;
      foreach (@$files) {
          my $filename = $_;
  
          if ($self->{DeleteFiles}) {
              my $newfilename = $filename . ".deleteme";
  	    if ($^O eq 'VMS') {
  		# VMS default filesystem can only have one period
  		$newfilename = $filename . 'deleteme';
  	    }
              # will clobber an existing $newfilename
              rename($filename, $newfilename)
                  or croak "Can't rename($filename, $newfilename): $!";
  	    # On a versioned filesystem we want old versions to be removed
  	    1 while (unlink $filename);
              $filename = $newfilename;
          }
  
          open($fh, "<", $filename)
            or croak("Unable to read profile file '$filename': $!");
  
          # lock the file in case it's still being written to
          # (we'll be foced to wait till the write is complete)
          flock($fh, LOCK_SH) if $self->{LockFile};
  
          if (-s $fh) {   # not empty
              $self->_read_header($fh, $filename, $read_header ? 0 : 1);
              $read_header = 1;
              $self->_read_body($fh, $filename);
          }
          close($fh); # and release lock
          
          push @files_to_delete, $filename
              if $self->{DeleteFiles};
      }
      for (@files_to_delete){
  	# for versioned file systems
  	1 while (unlink $_);
  	if(-e $_){
  	    warn "Can't delete '$_': $!";
  	}
      }
      
      # discard node_lookup now that all files are read
      delete $self->{_node_lookup};
  }
  
  # read the header from the given $fh named $filename.  Discards the
  # data unless $keep.
  sub _read_header {
      my ($self, $fh, $filename, $keep) = @_;
  
      # get profiler module id
      my $first = <$fh>;
      chomp $first;
      $self->{_profiler} = $first if $keep;
  
      # collect variables from the header
      local $_;
      while (<$fh>) {
          chomp;
          last unless length $_;
          /^(\S+)\s*=\s*(.*)/
            or croak("Syntax error in header in $filename line $.: $_");
          # XXX should compare new with existing (from previous file)
          # and warn if they differ (diferent program or path)
          $self->{_header}{$1} = unescape_key($2) if $keep;
      }
  }
  
  
  sub unescape_key {  # inverse of escape_key() in DBI::ProfileDumper
      local $_ = shift;
      s/(?<!\\)\\n/\n/g; # expand \n, unless it's a \\n
      s/(?<!\\)\\r/\r/g; # expand \r, unless it's a \\r
      s/\\\\/\\/g;       # \\ to \
      return $_;
  }
  
  
  # reads the body of the profile data
  sub _read_body {
      my ($self, $fh, $filename) = @_;
      my $nodes = $self->{_nodes};
      my $lookup = $self->{_node_lookup};
      my $filter = $self->{Filter};
  
      # build up node array
      my @path = ("");
      my (@data, $path_key);
      local $_;
      while (<$fh>) {
          chomp;
          if (/^\+\s+(\d+)\s?(.*)/) {
              # it's a key
              my ($key, $index) = ($2, $1 - 1);
  
              $#path = $index;      # truncate path to new length
              $path[$index] = unescape_key($key); # place new key at end
  
          }
  	elsif (s/^=\s+//) {
              # it's data - file in the node array with the path in index 0
  	    # (the optional minus is to make it more robust against systems
  	    # with unstable high-res clocks - typically due to poor NTP config
  	    # of kernel SMP behaviour, i.e. min time may be -0.000008))
  
              @data = split / /, $_;
  
              # corrupt data?
              croak("Invalid number of fields in $filename line $.: $_")
                  unless @data == 7;
              croak("Invalid leaf node characters $filename line $.: $_")
                  unless m/^[-+ 0-9eE\.]+$/;
  
  	    # hook to enable pre-processing of the data - such as mangling SQL
  	    # so that slightly different statements get treated as the same
  	    # and so merged in the results
  	    $filter->(\@path, \@data) if $filter;
  
              # elements of @path can't have NULLs in them, so this
              # forms a unique string per @path.  If there's some way I
              # can get this without arbitrarily stripping out a
              # character I'd be happy to hear it!
              $path_key = join("\0",@path);
  
              # look for previous entry
              if (exists $lookup->{$path_key}) {
                  # merge in the new data
  		dbi_profile_merge($nodes->[$lookup->{$path_key}], \@data);
              } else {
                  # insert a new node - nodes are arrays with data in 0-6
                  # and path data after that
                  push(@$nodes, [ @data, @path ]);
  
                  # record node in %seen
                  $lookup->{$path_key} = $#$nodes;
              }
          }
  	else {
              croak("Invalid line type syntax error in $filename line $.: $_");
  	}
      }
  }
  
  
  
  =head2 $copy = $prof->clone();
  
  Clone a profile data set creating a new object.
  
  =cut
  
  sub clone {
      my $self = shift;
  
      # start with a simple copy
      my $clone = bless { %$self }, ref($self);
  
      # deep copy nodes
      $clone->{_nodes}  = [ map { [ @$_ ] } @{$self->{_nodes}} ];
  
      # deep copy header
      $clone->{_header} = { %{$self->{_header}} };
  
      return $clone;
  }
  
  =head2 $header = $prof->header();
  
  Returns a reference to a hash of header values.  These are the key
  value pairs included in the header section of the DBI::ProfileDumper
  data format.  For example:
  
    $header = {
      Path    => [ '!Statement', '!MethodName' ],
      Program => 't/42profile_data.t',
    };
  
  Note that modifying this hash will modify the header data stored
  inside the profile object.
  
  =cut
  
  sub header { shift->{_header} }
  
  
  =head2 $nodes = $prof->nodes()
  
  Returns a reference the sorted nodes array.  Each element in the array
  is a single record in the data set.  The first seven elements are the
  same as the elements provided by DBI::Profile.  After that each key is
  in a separate element.  For example:
  
   $nodes = [
              [
                2,                      # 0, count
                0.0312958955764771,     # 1, total duration
                0.000490069389343262,   # 2, first duration
                0.000176072120666504,   # 3, shortest duration
                0.00140702724456787,    # 4, longest duration
                1023115819.83019,       # 5, time of first event
                1023115819.86576,       # 6, time of last event
                'SELECT foo FROM bar'   # 7, key1
                'execute'               # 8, key2
                                        # 6+N, keyN
              ],
                                        # ...
            ];
  
  Note that modifying this array will modify the node data stored inside
  the profile object.
  
  =cut
  
  sub nodes { shift->{_nodes} }
  
  
  =head2 $count = $prof->count()
  
  Returns the number of items in the profile data set.
  
  =cut
  
  sub count { scalar @{shift->{_nodes}} }
  
  
  =head2 $prof->sort(field => "field")
  
  =head2 $prof->sort(field => "field", reverse => 1)
  
  Sorts data by the given field.  Available fields are:
  
    longest
    total
    count
    shortest
  
  The default sort is greatest to smallest, which is the opposite of the
  normal Perl meaning.  This, however, matches the expected behavior of
  the dbiprof frontend.
  
  =cut
  
  
  # sorts data by one of the available fields
  {
      my %FIELDS = (
                    longest  => LONGEST,
                    total    => TOTAL,
                    count    => COUNT,
                    shortest => SHORTEST,
                    key1     => PATH+0,
                    key2     => PATH+1,
                    key3     => PATH+2,
                   );
      sub sort {
          my $self = shift;
          my $nodes = $self->{_nodes};
          my %opt = @_;
          
          croak("Missing required field option.") unless $opt{field};
  
          my $index = $FIELDS{$opt{field}};
          
          croak("Unrecognized sort field '$opt{field}'.")
            unless defined $index;
  
          # sort over index
          if ($opt{reverse}) {
              @$nodes = sort { 
                  $a->[$index] <=> $b->[$index] 
              } @$nodes;
          } else {
              @$nodes = sort { 
                  $b->[$index] <=> $a->[$index] 
              } @$nodes;
          }
  
          # remember how we're sorted
          $self->{_sort} = $opt{field};
  
          return $self;
      }
  }
  
  
  =head2 $count = $prof->exclude(key2 => "disconnect")
  
  =head2 $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1)
  
  =head2 $count = $prof->exclude(key1 => qr/^SELECT/i)
  
  Removes records from the data set that match the given string or
  regular expression.  This method modifies the data in a permanent
  fashion - use clone() first to maintain the original data after
  exclude().  Returns the number of nodes left in the profile data set.
  
  =cut
  
  sub exclude {
      my $self = shift;
      my $nodes = $self->{_nodes};
      my %opt = @_;
  
      # find key index number
      my ($index, $val);
      foreach (keys %opt) {
          if (/^key(\d+)$/) {
              $index   = PATH + $1 - 1;
              $val     = $opt{$_};
              last;
          }
      }
      croak("Missing required keyN option.") unless $index;
  
      if (UNIVERSAL::isa($val,"Regexp")) {
          # regex match
          @$nodes = grep {
              $#$_ < $index or $_->[$index] !~ /$val/ 
          } @$nodes;
      } else {
          if ($opt{case_sensitive}) {
              @$nodes = grep { 
                  $#$_ < $index or $_->[$index] ne $val;
              } @$nodes;
          } else {
              $val = lc $val;
              @$nodes = grep { 
                  $#$_ < $index or lc($_->[$index]) ne $val;
              } @$nodes;
          }
      }
  
      return scalar @$nodes;
  }
  
  
  =head2 $count = $prof->match(key2 => "disconnect")
  
  =head2 $count = $prof->match(key2 => "disconnect", case_sensitive => 1)
  
  =head2 $count = $prof->match(key1 => qr/^SELECT/i)
  
  Removes records from the data set that do not match the given string
  or regular expression.  This method modifies the data in a permanent
  fashion - use clone() first to maintain the original data after
  match().  Returns the number of nodes left in the profile data set.
  
  =cut
  
  sub match {
      my $self = shift;
      my $nodes = $self->{_nodes};
      my %opt = @_;
  
      # find key index number
      my ($index, $val);
      foreach (keys %opt) {
          if (/^key(\d+)$/) {
              $index   = PATH + $1 - 1;
              $val     = $opt{$_};
              last;
          }
      }
      croak("Missing required keyN option.") unless $index;
  
      if (UNIVERSAL::isa($val,"Regexp")) {
          # regex match
          @$nodes = grep {
              $#$_ >= $index and $_->[$index] =~ /$val/ 
          } @$nodes;
      } else {
          if ($opt{case_sensitive}) {
              @$nodes = grep { 
                  $#$_ >= $index and $_->[$index] eq $val;
              } @$nodes;
          } else {
              $val = lc $val;
              @$nodes = grep { 
                  $#$_ >= $index and lc($_->[$index]) eq $val;
              } @$nodes;
          }
      }
  
      return scalar @$nodes;
  }
  
  
  =head2 $Data = $prof->Data()
  
  Returns the same Data hash structure as seen in DBI::Profile.  This
  structure is not sorted.  The nodes() structure probably makes more
  sense for most analysis.
  
  =cut
  
  sub Data {
      my $self = shift;
      my (%Data, @data, $ptr);
  
      foreach my $node (@{$self->{_nodes}}) {
          # traverse to key location
          $ptr = \%Data;
          foreach my $key (@{$node}[PATH .. $#$node - 1]) {
              $ptr->{$key} = {} unless exists $ptr->{$key};
              $ptr = $ptr->{$key};
          }
  
          # slice out node data
          $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ];
      }
  
      return \%Data;
  }
  
  
  =head2 $text = $prof->format($nodes->[0])
  
  Formats a single node into a human-readable block of text.
  
  =cut
  
  sub format {
      my ($self, $node) = @_;
      my $format;
      
      # setup keys
      my $keys = "";
      for (my $i = PATH; $i <= $#$node; $i++) {
          my $key = $node->[$i];
          
          # remove leading and trailing space
          $key =~ s/^\s+//;
          $key =~ s/\s+$//;
  
          # if key has newlines or is long take special precautions
          if (length($key) > 72 or $key =~ /\n/) {
              $keys .= "  Key " . ($i - PATH + 1) . "         :\n\n$key\n\n";
          } else {
              $keys .= "  Key " . ($i - PATH + 1) . "         : $key\n";
          }
      }
  
      # nodes with multiple runs get the long entry format, nodes with
      # just one run get a single count.
      if ($node->[COUNT] > 1) {
          $format = <<END;
    Count         : %d
    Total Time    : %3.6f seconds
    Longest Time  : %3.6f seconds
    Shortest Time : %3.6f seconds
    Average Time  : %3.6f seconds
  END
          return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST], 
                         $node->[TOTAL] / $node->[COUNT]) . $keys;
      } else {
          $format = <<END;
    Count         : %d
    Time          : %3.6f seconds
  END
  
          return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys;
  
      }
  }
  
  
  =head2 $text = $prof->report(number => 10)
  
  Produces a report with the given number of items.
  
  =cut
  
  sub report {
      my $self  = shift;
      my $nodes = $self->{_nodes};
      my %opt   = @_;
  
      croak("Missing required number option") unless exists $opt{number};
  
      $opt{number} = @$nodes if @$nodes < $opt{number};
  
      my $report = $self->_report_header($opt{number});
      for (0 .. $opt{number} - 1) {
          $report .= sprintf("#" x 5  . "[ %d ]". "#" x 59 . "\n", 
                             $_ + 1);
          $report .= $self->format($nodes->[$_]);
          $report .= "\n";
      }
      return $report;
  }
  
  # format the header for report()
  sub _report_header {
      my ($self, $number) = @_;
      my $nodes = $self->{_nodes};
      my $node_count = @$nodes;
  
      # find total runtime and method count
      my ($time, $count) = (0,0);
      foreach my $node (@$nodes) {
          $time  += $node->[TOTAL];
          $count += $node->[COUNT];
      }
  
      my $header = <<END;
  
  DBI Profile Data ($self->{_profiler})
  
  END
  
      # output header fields
      while (my ($key, $value) = each %{$self->{_header}}) {
          $header .= sprintf("  %-13s : %s\n", $key, $value);
      }
  
      # output summary data fields
      $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time);
    Total Records : %d (showing %d, sorted by %s)
    Total Count   : %d
    Total Runtime : %3.6f seconds  
  
  END
  
      return $header;
  }
  
  
  1;
  
  __END__
  
  =head1 AUTHOR
  
  Sam Tregar <sam@tregar.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2002 Sam Tregar
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl 5 itself.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDATA

$fatpacked{"darwin-thread-multi-2level/DBI/ProfileDumper.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDUMPER';
  package DBI::ProfileDumper;
  use strict;
  
  =head1 NAME
  
  DBI::ProfileDumper - profile DBI usage and output data to a file
  
  =head1 SYNOPSIS
  
  To profile an existing program using DBI::ProfileDumper, set the
  DBI_PROFILE environment variable and run your program as usual.  For
  example, using bash:
  
    DBI_PROFILE=2/DBI::ProfileDumper program.pl
  
  Then analyze the generated file (F<dbi.prof>) with L<dbiprof|dbiprof>:
  
    dbiprof
  
  You can also activate DBI::ProfileDumper from within your code:
  
    use DBI;
  
    # profile with default path (2) and output file (dbi.prof)
    $dbh->{Profile} = "!Statement/DBI::ProfileDumper";
  
    # same thing, spelled out
    $dbh->{Profile} = "!Statement/DBI::ProfileDumper/File:dbi.prof";
  
    # another way to say it
    use DBI::ProfileDumper;
    $dbh->{Profile} = DBI::ProfileDumper->new(
                          Path => [ '!Statement' ]
                          File => 'dbi.prof' );
  
    # using a custom path
    $dbh->{Profile} = DBI::ProfileDumper->new(
        Path => [ "foo", "bar" ],
        File => 'dbi.prof',
    );
  
  
  =head1 DESCRIPTION
  
  DBI::ProfileDumper is a subclass of L<DBI::Profile|DBI::Profile> which
  dumps profile data to disk instead of printing a summary to your
  screen.  You can then use L<dbiprof|dbiprof> to analyze the data in
  a number of interesting ways, or you can roll your own analysis using
  L<DBI::ProfileData|DBI::ProfileData>.
  
  B<NOTE:> For Apache/mod_perl applications, use
  L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>.
  
  =head1 USAGE
  
  One way to use this module is just to enable it in your C<$dbh>:
  
    $dbh->{Profile} = "1/DBI::ProfileDumper";
  
  This will write out profile data by statement into a file called
  F<dbi.prof>.  If you want to modify either of these properties, you
  can construct the DBI::ProfileDumper object yourself:
  
    use DBI::ProfileDumper;
    $dbh->{Profile} = DBI::ProfileDumper->new(
        Path => [ '!Statement' ],
        File => 'dbi.prof'
    );
  
  The C<Path> option takes the same values as in
  L<DBI::Profile>.  The C<File> option gives the name of the
  file where results will be collected.  If it already exists it will be
  overwritten.
  
  You can also activate this module by setting the DBI_PROFILE
  environment variable:
  
    $ENV{DBI_PROFILE} = "!Statement/DBI::ProfileDumper";
  
  This will cause all DBI handles to share the same profiling object.
  
  =head1 METHODS
  
  The following methods are available to be called using the profile
  object.  You can get access to the profile object from the Profile key
  in any DBI handle:
  
    my $profile = $dbh->{Profile};
  
  =head2 flush_to_disk
  
    $profile->flush_to_disk()
  
  Flushes all collected profile data to disk and empties the Data hash.  Returns
  the filename writen to.  If no profile data has been collected then the file is
  not written and flush_to_disk() returns undef.
  
  The file is locked while it's being written. A process 'consuming' the files
  while they're being written to, should rename the file first, then lock it,
  then read it, then close and delete it. The C<DeleteFiles> option to
  L<DBI::ProfileData> does the right thing.
  
  This method may be called multiple times during a program run.
  
  =head2 empty
  
    $profile->empty()
  
  Clears the Data hash without writing to disk.
  
  =head2 filename
  
    $filename = $profile->filename();
  
  Get or set the filename.
  
  The filename can be specified as a CODE reference, in which case the referenced
  code should return the filename to be used. The code will be called with the
  profile object as its first argument.
  
  =head1 DATA FORMAT
  
  The data format written by DBI::ProfileDumper starts with a header
  containing the version number of the module used to generate it.  Then
  a block of variable declarations describes the profile.  After two
  newlines, the profile data forms the body of the file.  For example:
  
    DBI::ProfileDumper 2.003762
    Path = [ '!Statement', '!MethodName' ]
    Program = t/42profile_data.t
  
    + 1 SELECT name FROM users WHERE id = ?
    + 2 prepare
    = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
    + 2 execute
    1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
    + 2 fetchrow_hashref
    = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
    + 1 UPDATE users SET name = ? WHERE id = ?
    + 2 prepare
    = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
    + 2 execute
    = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576
  
  The lines beginning with C<+> signs signify keys.  The number after
  the C<+> sign shows the nesting level of the key.  Lines beginning
  with C<=> are the actual profile data, in the same order as
  in DBI::Profile.
  
  Note that the same path may be present multiple times in the data file
  since C<format()> may be called more than once.  When read by
  DBI::ProfileData the data points will be merged to produce a single
  data set for each distinct path.
  
  The key strings are transformed in three ways.  First, all backslashes
  are doubled.  Then all newlines and carriage-returns are transformed
  into C<\n> and C<\r> respectively.  Finally, any NULL bytes (C<\0>)
  are entirely removed.  When DBI::ProfileData reads the file the first
  two transformations will be reversed, but NULL bytes will not be
  restored.
  
  =head1 AUTHOR
  
  Sam Tregar <sam@tregar.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2002 Sam Tregar
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl 5 itself.
  
  =cut
  
  # inherit from DBI::Profile
  use DBI::Profile;
  
  our @ISA = ("DBI::Profile");
  
  our $VERSION = sprintf("2.%06d", q$Revision: 9894 $ =~ /(\d+)/o);
  
  use Carp qw(croak);
  use Fcntl qw(:flock);
  use Symbol;
  
  my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK})
      ? $ENV{DBI_PROFILE_FLOCK}
      : do { local $@; eval { flock STDOUT, 0; 1 } };
  
  my $program_header;
  
  
  # validate params and setup default
  sub new {
      my $pkg = shift;
      my $self = $pkg->SUPER::new(
          LockFile => $HAS_FLOCK,
          @_,
      );
  
      # provide a default filename
      $self->filename("dbi.prof") unless $self->filename;
  
      return $self;
  }
  
  
  # get/set filename to use
  sub filename {
      my $self = shift;
      $self->{File} = shift if @_;
      my $filename = $self->{File};
      $filename = $filename->($self) if ref($filename) eq 'CODE';
      return $filename;
  }
  
  
  # flush available data to disk
  sub flush_to_disk {
      my $self = shift;
      my $class = ref $self;
      my $filename = $self->filename;
      my $data = $self->{Data};
  
      if (1) { # make an option
          if (not $data or ref $data eq 'HASH' && !%$data) {
              DBI->trace_msg("flush_to_disk skipped for empty profile\n",0) if $self->{Trace};
              return undef;
          }
      }
  
      my $fh = gensym;
      if (($self->{_wrote_header}||'') eq $filename) {
          # append more data to the file
          # XXX assumes that Path hasn't changed
          open($fh, ">>", $filename) 
            or croak("Unable to open '$filename' for $class output: $!");
      } else {
          # create new file (or overwrite existing)
          open($fh, ">", $filename) 
            or croak("Unable to open '$filename' for $class output: $!");
      }
      # lock the file (before checking size and writing the header)
      flock($fh, LOCK_EX) if $self->{LockFile};
      # write header if file is empty - typically because we just opened it
      # in '>' mode, or perhaps we used '>>' but the file had been truncated externally.
      if (-s $fh == 0) {
          DBI->trace_msg("flush_to_disk wrote header to $filename\n",0) if $self->{Trace};
          $self->write_header($fh);
          $self->{_wrote_header} = $filename;
      }
  
      my $lines = $self->write_data($fh, $self->{Data}, 1);
      DBI->trace_msg("flush_to_disk wrote $lines lines to $filename\n",0) if $self->{Trace};
  
      close($fh)  # unlocks the file
          or croak("Error closing '$filename': $!");
  
      $self->empty();
  
  
      return $filename;
  }
  
  
  # write header to a filehandle
  sub write_header {
      my ($self, $fh) = @_;
  
      # isolate us against globals which effect print
      local($\, $,);
  
      # $self->VERSION can return undef during global destruction
      my $version = $self->VERSION || $VERSION;
  
      # module name and version number
      print $fh ref($self)." $version\n";
  
      # print out Path (may contain CODE refs etc)
      my @path_words = map { escape_key($_) } @{ $self->{Path} || [] };
      print $fh "Path = [ ", join(', ', @path_words), " ]\n";
  
      # print out $0 and @ARGV
      if (!$program_header) {
          # XXX should really quote as well as escape
          $program_header = "Program = "
              . join(" ", map { escape_key($_) } $0, @ARGV)
              . "\n";
      }
      print $fh $program_header;
  
      # all done
      print $fh "\n";
  }
  
  
  # write data in the proscribed format
  sub write_data {
      my ($self, $fh, $data, $level) = @_;
  
      # XXX it's valid for $data to be an ARRAY ref, i.e., Path is empty.
      # produce an empty profile for invalid $data
      return 0 unless $data and UNIVERSAL::isa($data,'HASH');
      
      # isolate us against globals which affect print
      local ($\, $,);
  
      my $lines = 0;
      while (my ($key, $value) = each(%$data)) {
          # output a key
          print $fh "+ $level ". escape_key($key). "\n";
          if (UNIVERSAL::isa($value,'ARRAY')) {
              # output a data set for a leaf node
              print $fh "= ".join(' ', @$value)."\n";
              $lines += 1;
          } else {
              # recurse through keys - this could be rewritten to use a
              # stack for some small performance gain
              $lines += $self->write_data($fh, $value, $level + 1);
          }
      }
      return $lines;
  }
  
  
  # escape a key for output
  sub escape_key {
      my $key = shift;
      $key =~ s!\\!\\\\!g;
      $key =~ s!\n!\\n!g;
      $key =~ s!\r!\\r!g;
      $key =~ s!\0!!g;
      return $key;
  }
  
  
  # flush data to disk when profile object goes out of scope
  sub on_destroy {
      shift->flush_to_disk();
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDUMPER

$fatpacked{"darwin-thread-multi-2level/DBI/ProfileDumper/Apache.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDUMPER_APACHE';
  package DBI::ProfileDumper::Apache;
  
  use strict;
  
  =head1 NAME
  
  DBI::ProfileDumper::Apache - capture DBI profiling data from Apache/mod_perl
  
  =head1 SYNOPSIS
  
  Add this line to your F<httpd.conf>:
  
    PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
  
  (If you're using mod_perl2, see L</When using mod_perl2> for some additional notes.)
  
  Then restart your server.  Access the code you wish to test using a
  web browser, then shutdown your server.  This will create a set of
  F<dbi.prof.*> files in your Apache log directory.
  
  Get a profiling report with L<dbiprof|dbiprof>:
  
    dbiprof /path/to/your/apache/logs/dbi.prof.*
  
  When you're ready to perform another profiling run, delete the old files and start again.
  
  =head1 DESCRIPTION
  
  This module interfaces DBI::ProfileDumper to Apache/mod_perl.  Using
  this module you can collect profiling data from mod_perl applications.
  It works by creating a DBI::ProfileDumper data file for each Apache
  process.  These files are created in your Apache log directory.  You
  can then use the dbiprof utility to analyze the profile files.
  
  =head1 USAGE
  
  =head2 LOADING THE MODULE
  
  The easiest way to use this module is just to set the DBI_PROFILE
  environment variable in your F<httpd.conf>:
  
    PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache
  
  The DBI will look after loading and using the module when the first DBI handle
  is created.
  
  It's also possible to use this module by setting the Profile attribute
  of any DBI handle:
  
    $dbh->{Profile} = "2/DBI::ProfileDumper::Apache";
  
  See L<DBI::ProfileDumper> for more possibilities, and L<DBI::Profile> for full
  details of the DBI's profiling mechanism.
  
  =head2 WRITING PROFILE DATA
  
  The profile data files will be written to your Apache log directory by default.
  
  The user that the httpd processes run as will need write access to the
  directory.  So, for example, if you're running the child httpds as user 'nobody'
  and using chronolog to write to the logs directory, then you'll need to change
  the default.
  
  You can change the destination directory either by secifying a C<Dir> value
  when creating the profile (like C<File> in the L<DBI::ProfileDumper> docs),
  or you can use the C<DBI_PROFILE_APACHE_LOG_DIR> env var to change that. For example:
  
    PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs
  
  =head3 When using mod_perl2
  
  Under mod_perl2 you'll need to either set the C<DBI_PROFILE_APACHE_LOG_DIR> env var,
  or enable the mod_perl2 C<GlobalRequest> option, like this:
  
    PerlOptions +GlobalRequest
  
  to the global config section you're about test with DBI::ProfileDumper::Apache.
  If you don't do one of those then you'll see messages in your error_log similar to:
  
    DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not available. Set:
      PerlOptions +GlobalRequest in httpd.conf at ..../DBI/ProfileDumper/Apache.pm line 144
  
  =head3 Naming the files
  
  The default file name is inherited from L<DBI::ProfileDumper> via the
  filename() method, but DBI::ProfileDumper::Apache appends the parent pid and
  the current pid, separated by dots, to that name.
  
  =head3 Silencing the log
  
  By default a message is written to STDERR (i.e., the apache error_log file)
  when flush_to_disk() is called (either explicitly, or implicitly via DESTROY).
  
  That's usually very useful. If you don't want the log message you can silence
  it by setting the C<Quiet> attribute true.
  
    PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache/Quiet:1
  
    $dbh->{Profile} = "!Statement/DBI::ProfileDumper/Quiet:1";
  
    $dbh->{Profile} = DBI::ProfileDumper->new(
        Path => [ '!Statement' ]
        Quiet => 1
    );
  
  
  =head2 GATHERING PROFILE DATA
  
  Once you have the module loaded, use your application as you normally
  would.  Stop the webserver when your tests are complete.  Profile data
  files will be produced when Apache exits and you'll see something like
  this in your error_log:
  
    DBI::ProfileDumper::Apache writing to /usr/local/apache/logs/dbi.prof.2604.2619
  
  Now you can use dbiprof to examine the data:
  
    dbiprof /usr/local/apache/logs/dbi.prof.2604.*
  
  By passing dbiprof a list of all generated files, dbiprof will
  automatically merge them into one result set.  You can also pass
  dbiprof sorting and querying options, see L<dbiprof> for details.
  
  =head2 CLEANING UP
  
  Once you've made some code changes, you're ready to start again.
  First, delete the old profile data files:
  
    rm /usr/local/apache/logs/dbi.prof.*
  
  Then restart your server and get back to work.
  
  =head1 OTHER ISSUES
  
  =head2 Memory usage
  
  DBI::Profile can use a lot of memory for very active applications because it
  collects profiling data in memory for each distinct query run.
  Calling C<flush_to_disk()> will write the current data to disk and free the
  memory it's using. For example:
  
    $dbh->{Profile}->flush_to_disk() if $dbh->{Profile};
  
  or, rather than flush every time, you could flush less often:
  
    $dbh->{Profile}->flush_to_disk()
      if $dbh->{Profile} and ++$i % 100;
  
  =head1 AUTHOR
  
  Sam Tregar <sam@tregar.com>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2002 Sam Tregar
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl 5 itself.
  
  =cut
  
  our $VERSION = sprintf("2.%06d", q$Revision: 9618 $ =~ /(\d+)/o);
  
  our @ISA = qw(DBI::ProfileDumper);
  
  use DBI::ProfileDumper;
  use File::Spec;
  
  my $parent_pid = $$; # init to pid because we are currently the parent of the children-to-be
  
  use constant MP2 => ($ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
  
  my $apache_server;
  my $server_root_dir;
  
  if (MP2) {
      require Apache2::Const;
      Apache2::Const->import(-compile => qw(OK DECLINED));
      require Apache2::ServerUtil;
      $apache_server = Apache2::ServerUtil->server;
      $server_root_dir = Apache2::ServerUtil::server_root();
  }
  else {
      require Apache;
      require Apache::Constants;
      Apache::Constants->import(qw(OK DECLINED));
      $apache_server = "Apache";
      $server_root_dir = eval { Apache->server_root_relative('') } || "/tmp";
  }
  
  
  if (UNIVERSAL::can($apache_server, "push_handlers")) {
      $apache_server->push_handlers(PerlChildInitHandler => sub {
          $parent_pid = getppid();
          #warn "PerlChildInitHandler pid$$ has ppid $parent_pid";
          OK();
      });
  }
  
  sub dirname {
      my $self = shift;
      return $self->{Dir} if $self->{Dir};
      $self->{Dir} ||= $ENV{DBI_PROFILE_APACHE_LOG_DIR};
      return $self->{Dir} || File::Spec->catdir($server_root_dir, "logs");
  }
  
  sub filename {
      my $self = shift;
      my $filename = $self->SUPER::filename(@_);
      # to be able to identify groups of profile files from the same set of
      # apache processes, we include the parent pid in the file name
      # as well as the pid.
      $filename .= ".$parent_pid.$$";
      return $filename if File::Spec->file_name_is_absolute($filename);
      return File::Spec->catfile($self->dirname, $filename);
  }
  
  
  sub flush_to_disk {
      my $self = shift;
  
      my $filename = $self->SUPER::flush_to_disk(@_);
  
      print STDERR ref($self)." pid$$ written to $filename\n"
          if $filename && not $self->{Quiet};
  
      return $filename;
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILEDUMPER_APACHE

$fatpacked{"darwin-thread-multi-2level/DBI/ProfileSubs.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILESUBS';
  package DBI::ProfileSubs;
  
  our $VERSION = sprintf("0.%06d", q$Revision: 9395 $ =~ /(\d+)/o);
  
  =head1 NAME
  
  DBI::ProfileSubs - Subroutines for dynamic profile Path
  
  =head1 SYNOPSIS
  
    DBI_PROFILE='&norm_std_n3' prog.pl
  
  This is new and still experimental.
  
  =head1 TO DO
  
  Define come kind of naming convention for the subs.
  
  =cut
  
  use strict;
  use warnings;
  
  
  # would be good to refactor these regex into separate subs and find some
  # way to compose them in various combinations into multiple subs.
  # Perhaps via AUTOLOAD where \&auto_X_Y_Z creates a sub that does X, Y, and Z.
  # The final subs always need to be very fast.
  # 
  
  sub norm_std_n3 {
      # my ($h, $method_name) = @_;
      local $_ = $_;
  
      s/\b\d+\b/<N>/g;             # 42 -> <N>
      s/\b0x[0-9A-Fa-f]+\b/<N>/g;  # 0xFE -> <N>
  
      s/'.*?'/'<S>'/g;             # single quoted strings (doesn't handle escapes)
      s/".*?"/"<S>"/g;             # double quoted strings (doesn't handle escapes)
  
      # convert names like log20001231 into log<N>
      s/([a-z_]+)(\d{3,})\b/${1}<N>/ig;
  
      # abbreviate massive "in (...)" statements and similar
      s!((\s*<[NS]>\s*,\s*){100,})!sprintf("$2,<repeated %d times>",length($1)/2)!eg;
  
      return $_;
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROFILESUBS

$fatpacked{"darwin-thread-multi-2level/DBI/ProxyServer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PROXYSERVER';
  #	$Header: /home/timbo/dbi/lib/DBI/RCS/ProxyServer.pm,v 11.9 2003/05/14 11:08:17 timbo Exp $
  # -*- perl -*-
  #
  #   DBI::ProxyServer - a proxy server for DBI drivers
  #
  #   Copyright (c) 1997  Jochen Wiedmann
  #
  #   The DBD::Proxy module is free software; you can redistribute it and/or
  #   modify it under the same terms as Perl itself. In particular permission
  #   is granted to Tim Bunce for distributing this as a part of the DBI.
  #
  #
  #   Author: Jochen Wiedmann
  #           Am Eisteich 9
  #           72555 Metzingen
  #           Germany
  #
  #           Email: joe@ispsoft.de
  #           Phone: +49 7123 14881
  #
  #
  ##############################################################################
  
  
  require 5.004;
  use strict;
  
  use RPC::PlServer 0.2001;
  # require DBI; # deferred till AcceptVersion() to aid threading
  require Config;
  
  
  package DBI::ProxyServer;
  
  
  
  ############################################################################
  #
  #   Constants
  #
  ############################################################################
  
  use vars qw($VERSION @ISA);
  
  $VERSION = "0.3005";
  @ISA = qw(RPC::PlServer DBI);
  
  
  # Most of the options below are set to default values, we note them here
  # just for the sake of documentation.
  my %DEFAULT_SERVER_OPTIONS;
  {
      my $o = \%DEFAULT_SERVER_OPTIONS;
      $o->{'chroot'}     = undef,		# To be used in the initfile,
      					# after loading the required
      					# DBI drivers.
      $o->{'clients'} =
  	[ { 'mask' => '.*',
  	    'accept' => 1,
  	    'cipher' => undef
  	    }
  	  ];
      $o->{'configfile'} = '/etc/dbiproxy.conf' if -f '/etc/dbiproxy.conf';
      $o->{'debug'}      = 0;
      $o->{'facility'}   = 'daemon';
      $o->{'group'}      = undef;
      $o->{'localaddr'}  = undef;		# Bind to any local IP number
      $o->{'localport'}  = undef;         # Must set port number on the
  					# command line.
      $o->{'logfile'}    = undef;         # Use syslog or EventLog.
  
      # XXX don't restrict methods that can be called (trust users once connected)
      $o->{'XXX_methods'}    = {
  	'DBI::ProxyServer' => {
  	    'Version' => 1,
  	    'NewHandle' => 1,
  	    'CallMethod' => 1,
  	    'DestroyHandle' => 1
  	    },
  	'DBI::ProxyServer::db' => {
  	    'prepare' => 1,
  	    'commit' => 1,
  	    'rollback' => 1,
  	    'STORE' => 1,
  	    'FETCH' => 1,
  	    'func' => 1,
  	    'quote' => 1,
  	    'type_info_all' => 1,
  	    'table_info' => 1,
  	    'disconnect' => 1,
  	    },
  	'DBI::ProxyServer::st' => {
  	    'execute' => 1,
  	    'STORE' => 1,
  	    'FETCH' => 1,
  	    'func' => 1,
  	    'fetch' => 1,
  	    'finish' => 1
  	    }
      };
      if ($Config::Config{'usethreads'} eq 'define') {
  	$o->{'mode'} = 'threads';
      } elsif ($Config::Config{'d_fork'} eq 'define') {
  	$o->{'mode'} = 'fork';
      } else {
  	$o->{'mode'} = 'single';
      }
      # No pidfile by default, configuration must provide one if needed
      $o->{'pidfile'}    = 'none';
      $o->{'user'}       = undef;
  };
  
  
  ############################################################################
  #
  #   Name:    Version
  #
  #   Purpose: Return version string
  #
  #   Inputs:  $class - This class
  #
  #   Result:  Version string; suitable for printing by "--version"
  #
  ############################################################################
  
  sub Version {
      my $version = $DBI::ProxyServer::VERSION;
      "DBI::ProxyServer $version, Copyright (C) 1998, Jochen Wiedmann";
  }
  
  
  ############################################################################
  #
  #   Name:    AcceptApplication
  #
  #   Purpose: Verify DBI DSN
  #
  #   Inputs:  $self - This instance
  #            $dsn - DBI dsn
  #
  #   Returns: TRUE for a valid DSN, FALSE otherwise
  #
  ############################################################################
  
  sub AcceptApplication {
      my $self = shift; my $dsn = shift;
      $dsn =~ /^dbi:\w+:/i;
  }
  
  
  ############################################################################
  #
  #   Name:    AcceptVersion
  #
  #   Purpose: Verify requested DBI version
  #
  #   Inputs:  $self - Instance
  #            $version - DBI version being requested
  #
  #   Returns: TRUE for ok, FALSE otherwise
  #
  ############################################################################
  
  sub AcceptVersion {
      my $self = shift; my $version = shift;
      require DBI;
      DBI::ProxyServer->init_rootclass();
      $DBI::VERSION >= $version;
  }
  
  
  ############################################################################
  #
  #   Name:    AcceptUser
  #
  #   Purpose: Verify user and password by connecting to the client and
  #            creating a database connection
  #
  #   Inputs:  $self - Instance
  #            $user - User name
  #            $password - Password
  #
  ############################################################################
  
  sub AcceptUser {
      my $self = shift; my $user = shift; my $password = shift;
      return 0 if (!$self->SUPER::AcceptUser($user, $password));
      my $dsn = $self->{'application'};
      $self->Debug("Connecting to $dsn as $user");
      local $ENV{DBI_AUTOPROXY} = ''; # :-)
      $self->{'dbh'} = eval {
          DBI::ProxyServer->connect($dsn, $user, $password,
  				  { 'PrintError' => 0, 
  				    'Warn' => 0,
  				    'RaiseError' => 1,
  				    'HandleError' => sub {
  				        my $err = $_[1]->err;
  					my $state = $_[1]->state || '';
  					$_[0] .= " [err=$err,state=$state]";
  					return 0;
  				    } })
      };
      if ($@) {
  	$self->Error("Error while connecting to $dsn as $user: $@");
  	return 0;
      }
      [1, $self->StoreHandle($self->{'dbh'}) ];
  }
  
  
  sub CallMethod {
      my $server = shift;
      my $dbh = $server->{'dbh'};
      # We could store the private_server attribute permanently in
      # $dbh. However, we'd have a reference loop in that case and
      # I would be concerned about garbage collection. :-(
      $dbh->{'private_server'} = $server;
      $server->Debug("CallMethod: => " . do { local $^W; join(",", @_)});
      my @result = eval { $server->SUPER::CallMethod(@_) };
      my $msg = $@;
      undef $dbh->{'private_server'};
      if ($msg) {
  	$server->Debug("CallMethod died with: $@");
  	die $msg;
      } else {
  	$server->Debug("CallMethod: <= " . do { local $^W; join(",", @result) });
      }
      @result;
  }
  
  
  sub main {
      my $server = DBI::ProxyServer->new(\%DEFAULT_SERVER_OPTIONS, \@_);
      $server->Bind();
  }
  
  
  ############################################################################
  #
  #   The DBI part of the proxyserver is implemented as a DBI subclass.
  #   Thus we can reuse some of the DBI methods and overwrite only
  #   those that need additional handling.
  #
  ############################################################################
  
  package DBI::ProxyServer::dr;
  
  @DBI::ProxyServer::dr::ISA = qw(DBI::dr);
  
  
  package DBI::ProxyServer::db;
  
  @DBI::ProxyServer::db::ISA = qw(DBI::db);
  
  sub prepare {
      my($dbh, $statement, $attr, $params, $proto_ver) = @_;
      my $server = $dbh->{'private_server'};
      if (my $client = $server->{'client'}) {
  	if ($client->{'sql'}) {
  	    if ($statement =~ /^\s*(\S+)/) {
  		my $st = $1;
  		if (!($statement = $client->{'sql'}->{$st})) {
  		    die "Unknown SQL query: $st";
  		}
  	    } else {
  		die "Cannot parse restricted SQL statement: $statement";
  	    }
  	}
      }
      my $sth = $dbh->SUPER::prepare($statement, $attr);
      my $handle = $server->StoreHandle($sth);
  
      if ( $proto_ver and $proto_ver > 1 ) {
        $sth->{private_proxyserver_described} = 0;
        return $handle;
  
      } else {
        # The difference between the usual prepare and ours is that we implement
        # a combined prepare/execute. The DBD::Proxy driver doesn't call us for
        # prepare. Only if an execute happens, then we are called with method
        # "prepare". Further execute's are called as "execute".
        my @result = $sth->execute($params);
        my ($NAME, $TYPE);
        my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS};
        if ($NUM_OF_FIELDS) {	# is a SELECT
  	$NAME = $sth->{NAME};
  	$TYPE = $sth->{TYPE};
        }
        ($handle, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'},
         $NAME, $TYPE, @result);
      }
  }
  
  sub table_info {
      my $dbh = shift;
      my $sth = $dbh->SUPER::table_info();
      my $numFields = $sth->{'NUM_OF_FIELDS'};
      my $names = $sth->{'NAME'};
      my $types = $sth->{'TYPE'};
  
      # We wouldn't need to send all the rows at this point, instead we could
      # make use of $rsth->fetch() on the client as usual.
      # The problem is that some drivers (namely DBD::ExampleP, DBD::mysql and
      # DBD::mSQL) are returning foreign sth's here, thus an instance of
      # DBI::st and not DBI::ProxyServer::st. We could fix this by permitting
      # the client to execute method DBI::st, but I don't like this.
      my @rows;
      while (my ($row) = $sth->fetch()) {
          last unless defined $row;
  	push(@rows, [@$row]);
      }
      ($numFields, $names, $types, @rows);
  }
  
  
  package DBI::ProxyServer::st;
  
  @DBI::ProxyServer::st::ISA = qw(DBI::st);
  
  sub execute {
      my $sth = shift; my $params = shift; my $proto_ver = shift;
      my @outParams;
      if ($params) {
  	for (my $i = 0;  $i < @$params;) {
  	    my $param = $params->[$i++];
  	    if (!ref($param)) {
  		$sth->bind_param($i, $param);
  	    }
  	    else {	
  		if (!ref(@$param[0])) {#It's not a reference
  		    $sth->bind_param($i, @$param);
  		}
  		else {
  		    $sth->bind_param_inout($i, @$param);
  		    my $ref = shift @$param;
  		    push(@outParams, $ref);
  		}
  	    }
  	}
      }
      my $rows = $sth->SUPER::execute();
      if ( $proto_ver and $proto_ver > 1 and not $sth->{private_proxyserver_described} ) {
        my ($NAME, $TYPE);
        my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS};
        if ($NUM_OF_FIELDS) {	# is a SELECT
  	$NAME = $sth->{NAME};
  	$TYPE = $sth->{TYPE};
        }
        $sth->{private_proxyserver_described} = 1;
        # First execution, we ship back description.
        return ($rows, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, $NAME, $TYPE, @outParams);
      }
      ($rows, @outParams);
  }
  
  sub fetch {
      my $sth = shift; my $numRows = shift || 1;
      my($ref, @rows);
      while ($numRows--  &&  ($ref = $sth->SUPER::fetch())) {
  	push(@rows, [@$ref]);
      }
      @rows;
  }
  
  
  1;
  
  
  __END__
  
  =head1 NAME
  
  DBI::ProxyServer - a server for the DBD::Proxy driver
  
  =head1 SYNOPSIS
  
      use DBI::ProxyServer;
      DBI::ProxyServer::main(@ARGV);
  
  =head1 DESCRIPTION
  
  DBI::Proxy Server is a module for implementing a proxy for the DBI proxy
  driver, DBD::Proxy. It allows access to databases over the network if the
  DBMS does not offer networked operations. But the proxy server might be
  useful for you, even if you have a DBMS with integrated network
  functionality: It can be used as a DBI proxy in a firewalled environment.
  
  DBI::ProxyServer runs as a daemon on the machine with the DBMS or on the
  firewall. The client connects to the agent using the DBI driver DBD::Proxy,
  thus in the exactly same way than using DBD::mysql, DBD::mSQL or any other
  DBI driver.
  
  The agent is implemented as a RPC::PlServer application. Thus you have
  access to all the possibilities of this module, in particular encryption
  and a similar configuration file. DBI::ProxyServer adds the possibility of
  query restrictions: You can define a set of queries that a client may
  execute and restrict access to those. (Requires a DBI driver that supports
  parameter binding.) See L</CONFIGURATION FILE>.
  
  The provided driver script, L<dbiproxy>, may either be used as it is or
  used as the basis for a local version modified to meet your needs.
  
  =head1 OPTIONS
  
  When calling the DBI::ProxyServer::main() function, you supply an
  array of options. These options are parsed by the Getopt::Long module.
  The ProxyServer inherits all of RPC::PlServer's and hence Net::Daemon's
  options and option handling, in particular the ability to read
  options from either the command line or a config file. See
  L<RPC::PlServer>. See L<Net::Daemon>. Available options include
  
  =over 4
  
  =item I<chroot> (B<--chroot=dir>)
  
  (UNIX only)  After doing a bind(), change root directory to the given
  directory by doing a chroot(). This is useful for security, but it
  restricts the environment a lot. For example, you need to load DBI
  drivers in the config file or you have to create hard links to Unix
  sockets, if your drivers are using them. For example, with MySQL, a
  config file might contain the following lines:
  
      my $rootdir = '/var/dbiproxy';
      my $unixsockdir = '/tmp';
      my $unixsockfile = 'mysql.sock';
      foreach $dir ($rootdir, "$rootdir$unixsockdir") {
  	mkdir 0755, $dir;
      }
      link("$unixsockdir/$unixsockfile",
  	 "$rootdir$unixsockdir/$unixsockfile");
      require DBD::mysql;
  
      {
  	'chroot' => $rootdir,
  	...
      }
  
  If you don't know chroot(), think of an FTP server where you can see a
  certain directory tree only after logging in. See also the --group and
  --user options.
  
  =item I<clients>
  
  An array ref with a list of clients. Clients are hash refs, the attributes
  I<accept> (0 for denying access and 1 for permitting) and I<mask>, a Perl
  regular expression for the clients IP number or its host name.
  
  =item I<configfile> (B<--configfile=file>)
  
  Config files are assumed to return a single hash ref that overrides the
  arguments of the new method. However, command line arguments in turn take
  precedence over the config file. See the L<"CONFIGURATION FILE"> section
  below for details on the config file.
  
  =item I<debug> (B<--debug>)
  
  Turn debugging mode on. Mainly this asserts that logging messages of
  level "debug" are created.
  
  =item I<facility> (B<--facility=mode>)
  
  (UNIX only) Facility to use for L<Sys::Syslog>. The default is
  B<daemon>.
  
  =item I<group> (B<--group=gid>)
  
  After doing a bind(), change the real and effective GID to the given.
  This is useful, if you want your server to bind to a privileged port
  (<1024), but don't want the server to execute as root. See also
  the --user option.
  
  GID's can be passed as group names or numeric values.
  
  =item I<localaddr> (B<--localaddr=ip>)
  
  By default a daemon is listening to any IP number that a machine
  has. This attribute allows to restrict the server to the given
  IP number.
  
  =item I<localport> (B<--localport=port>)
  
  This attribute sets the port on which the daemon is listening. It
  must be given somehow, as there's no default.
  
  =item I<logfile> (B<--logfile=file>)
  
  Be default logging messages will be written to the syslog (Unix) or
  to the event log (Windows NT). On other operating systems you need to
  specify a log file. The special value "STDERR" forces logging to
  stderr. See L<Net::Daemon::Log> for details.
  
  =item I<mode> (B<--mode=modename>)
  
  The server can run in three different modes, depending on the environment.
  
  If you are running Perl 5.005 and did compile it for threads, then the
  server will create a new thread for each connection. The thread will
  execute the server's Run() method and then terminate. This mode is the
  default, you can force it with "--mode=threads".
  
  If threads are not available, but you have a working fork(), then the
  server will behave similar by creating a new process for each connection.
  This mode will be used automatically in the absence of threads or if
  you use the "--mode=fork" option.
  
  Finally there's a single-connection mode: If the server has accepted a
  connection, he will enter the Run() method. No other connections are
  accepted until the Run() method returns (if the client disconnects).
  This operation mode is useful if you have neither threads nor fork(),
  for example on the Macintosh. For debugging purposes you can force this
  mode with "--mode=single".
  
  =item I<pidfile> (B<--pidfile=file>)
  
  (UNIX only) If this option is present, a PID file will be created at the
  given location. Default is to not create a pidfile.
  
  =item I<user> (B<--user=uid>)
  
  After doing a bind(), change the real and effective UID to the given.
  This is useful, if you want your server to bind to a privileged port
  (<1024), but don't want the server to execute as root. See also
  the --group and the --chroot options.
  
  UID's can be passed as group names or numeric values.
  
  =item I<version> (B<--version>)
  
  Supresses startup of the server; instead the version string will
  be printed and the program exits immediately.
  
  =back
  
  =head1 SHUTDOWN
  
  DBI::ProxyServer is built on L<RPC::PlServer> which is, in turn, built on L<Net::Daemon>.
  
  You should refer to L<Net::Daemon> for how to shutdown the server, except that
  you can't because it's not currently documented there (as of v0.43).
  The bottom-line is that it seems that there's no support for graceful shutdown.
  
  =head1 CONFIGURATION FILE
  
  The configuration file is just that of I<RPC::PlServer> or I<Net::Daemon>
  with some additional attributes in the client list.
  
  The config file is a Perl script. At the top of the file you may include
  arbitraty Perl source, for example load drivers at the start (useful
  to enhance performance), prepare a chroot environment and so on.
  
  The important thing is that you finally return a hash ref of option
  name/value pairs. The possible options are listed above.
  
  All possibilities of Net::Daemon and RPC::PlServer apply, in particular
  
  =over 4
  
  =item Host and/or User dependent access control
  
  =item Host and/or User dependent encryption
  
  =item Changing UID and/or GID after binding to the port
  
  =item Running in a chroot() environment
  
  =back
  
  Additionally the server offers you query restrictions. Suggest the
  following client list:
  
      'clients' => [
  	{ 'mask' => '^admin\.company\.com$',
            'accept' => 1,
            'users' => [ 'root', 'wwwrun' ],
          },
          {
  	  'mask' => '^admin\.company\.com$',
            'accept' => 1,
            'users' => [ 'root', 'wwwrun' ],
            'sql' => {
                 'select' => 'SELECT * FROM foo',
                 'insert' => 'INSERT INTO foo VALUES (?, ?, ?)'
                 }
          }
  
  then only the users root and wwwrun may connect from admin.company.com,
  executing arbitrary queries, but only wwwrun may connect from other
  hosts and is restricted to
  
      $sth->prepare("select");
  
  or
  
      $sth->prepare("insert");
  
  which in fact are "SELECT * FROM foo" or "INSERT INTO foo VALUES (?, ?, ?)".
  
  
  =head1 Proxyserver Configuration file (bigger example)
  
  This section tells you how to restrict a DBI-Proxy: Not every user from
  every workstation shall be able to execute every query.
  
  There is a perl program "dbiproxy" which runs on a machine which is able
  to connect to all the databases we wish to reach. All Perl-DBD-drivers must
  be installed on this machine. You can also reach databases for which drivers 
  are not available on the machine where you run the programm querying the 
  database, e.g. ask MS-Access-database from Linux.
  
  Create a configuration file "proxy_oracle.cfg" at the dbproxy-server:
  
      {
  	# This shall run in a shell or a DOS-window 
  	# facility => 'daemon',
  	pidfile => 'your_dbiproxy.pid',
  	logfile => 1,
  	debug => 0,
  	mode => 'single',
  	localport => '12400',
  
  	# Access control, the first match in this list wins!
  	# So the order is important
  	clients => [
  		# hint to organize:
  		# the most specialized rules for single machines/users are 1st
  		# then the denying rules
  		# the the rules about whole networks
  
  		# rule: internal_webserver
  		# desc: to get statistical information
  		{
  			# this IP-address only is meant
  			mask => '^10\.95\.81\.243$',
  			# accept (not defer) connections like this
  			accept => 1,
  			# only users from this list 
  			# are allowed to log on
  			users => [ 'informationdesk' ],
  			# only this statistical query is allowed
  			# to get results for a web-query
  			sql => {
  				alive => 'select count(*) from dual',
  				statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?',
  			}
  		},
  
  		# rule: internal_bad_guy_1
  		{
  			mask => '^10\.95\.81\.1$',
  			accept => 0,
  		},
  
  		# rule: employee_workplace
  		# desc: get detailled informations
  		{
  			# any IP-address is meant here
  			mask => '^10\.95\.81\.(\d+)$',
  			# accept (not defer) connections like this
  			accept => 1,
  			# only users from this list 
  			# are allowed to log on
  			users => [ 'informationdesk', 'lippmann' ],
  			# all these queries are allowed:
  			sql => {
  				search_city => 'select ort_nr, plz, ort from e01admin.e01e200 where plz like ?',
  				search_area => 'select gebiettyp, geb_bezei from e01admin.e01e203 where geb_bezei like ? or geb_bezei like ?',
  			}
  		},
  
  		# rule: internal_bad_guy_2 
  		# This does NOT work, because rule "employee_workplace" hits
  		# with its ip-address-mask of the whole network
  		{
  			# don't accept connection from this ip-address
  			mask => '^10\.95\.81\.5$',
  			accept => 0,
  		}
  	]
      }
  
  Start the proxyserver like this:
  
  	rem well-set Oracle_home needed for Oracle
  	set ORACLE_HOME=d:\oracle\ora81
  	dbiproxy --configfile proxy_oracle.cfg
  
  
  =head2 Testing the connection from a remote machine
  
  Call a programm "dbish" from your commandline. I take the machine from rule "internal_webserver"
  
  	dbish "dbi:Proxy:hostname=oracle.zdf;port=12400;dsn=dbi:Oracle:e01" informationdesk xxx
  
  There will be a shell-prompt:
  
  	informationdesk@dbi...> alive
  
  	Current statement buffer (enter '/'...):
  	alive
  
  	informationdesk@dbi...> /
  	COUNT(*)
  	'1'
  	[1 rows of 1 fields returned]
  
  
  =head2 Testing the connection with a perl-script
  
  Create a perl-script like this:
  
  	# file: oratest.pl
  	# call me like this: perl oratest.pl user password
  
  	use strict;
  	use DBI;
  
  	my $user = shift || die "Usage: $0 user password";
  	my $pass = shift || die "Usage: $0 user password";
  	my $config = {
  		dsn_at_proxy => "dbi:Oracle:e01",
  		proxy => "hostname=oechsle.zdf;port=12400",
  	};
  	my $dsn = sprintf "dbi:Proxy:%s;dsn=%s",
  		$config->{proxy},
  		$config->{dsn_at_proxy};
  
  	my $dbh = DBI->connect( $dsn, $user, $pass )
  		|| die "connect did not work: $DBI::errstr";
  
  	my $sql = "search_city";
  	printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
  	my $cur = $dbh->prepare($sql);
  	$cur->bind_param(1,'905%');
  	&show_result ($cur);
  
  	my $sql = "search_area";
  	printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
  	my $cur = $dbh->prepare($sql);
  	$cur->bind_param(1,'Pfarr%');
  	$cur->bind_param(2,'Bronnamberg%');
  	&show_result ($cur);
  
  	my $sql = "statistic_area";
  	printf "%s\n%s\n%s\n", "="x40, $sql, "="x40;
  	my $cur = $dbh->prepare($sql);
  	$cur->bind_param(1,'Pfarr%');
  	&show_result ($cur);
  
  	$dbh->disconnect;
  	exit;
  
  
  	sub show_result {
  		my $cur = shift;
  		unless ($cur->execute()) {
  			print "Could not execute\n"; 
  			return; 
  		}
  
  		my $rownum = 0;
  		while (my @row = $cur->fetchrow_array()) {
  			printf "Row is: %s\n", join(", ",@row);
  			if ($rownum++ > 5) {
  				print "... and so on\n";
  				last;
  			}	
  		}
  		$cur->finish;
  	}
  
  The result
  
  	C:\>perl oratest.pl informationdesk xxx
  	========================================
  	search_city
  	========================================
  	Row is: 3322, 9050, Chemnitz
  	Row is: 3678, 9051, Chemnitz
  	Row is: 10447, 9051, Chemnitz
  	Row is: 12128, 9051, Chemnitz
  	Row is: 10954, 90513, Zirndorf
  	Row is: 5808, 90513, Zirndorf
  	Row is: 5715, 90513, Zirndorf
  	... and so on
  	========================================
  	search_area
  	========================================
  	Row is: 101, Bronnamberg
  	Row is: 400, Pfarramt Zirndorf
  	Row is: 400, Pfarramt Rosstal
  	Row is: 400, Pfarramt Oberasbach
  	Row is: 401, Pfarramt Zirndorf
  	Row is: 401, Pfarramt Rosstal
  	========================================
  	statistic_area
  	========================================
  	DBD::Proxy::st execute failed: Server returned error: Failed to execute method CallMethod: Unknown SQL query: statistic_area at E:/Perl/site/lib/DBI/ProxyServer.pm line 258.
  	Could not execute
  
  
  =head2 How the configuration works
  
  The most important section to control access to your dbi-proxy is "client=>"
  in the file "proxy_oracle.cfg":
  
  Controlling which person at which machine is allowed to access
  
  =over 4
  
  =item * "mask" is a perl regular expression against the plain ip-address of the machine which wishes to connect _or_ the reverse-lookup from a nameserver.
  
  =item * "accept" tells the dbiproxy-server wether ip-adresse like in "mask" are allowed to connect or not (0/1)
  
  =item * "users" is a reference to a list of usernames which must be matched, this is NOT a regular expression.
  
  =back
  
  Controlling which SQL-statements are allowed
  
  You can put every SQL-statement you like in simply ommiting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible.
  
  If you include an sql-section in your config-file like this:
  
  	sql => {
  		alive => 'select count(*) from dual',
  		statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?',
  	}
  
  The user is allowed to put two queries against the dbi-proxy. The queries are _not_ "select count(*)...", the queries are "alive" and "statistic_area"! These keywords are replaced by the real query. So you can run a query for "alive":
  
  	my $sql = "alive";
  	my $cur = $dbh->prepare($sql);
  	...
  
  The flexibility is that you can put parameters in the where-part of the query so the query are not static. Simply replace a value in the where-part of the query through a question mark and bind it as a parameter to the query. 
  
  	my $sql = "statistic_area";
  	my $cur = $dbh->prepare($sql);
  	$cur->bind_param(1,'905%');
  	# A second parameter would be called like this:
  	# $cur->bind_param(2,'98%');
  
  The result is this query:
  
  	select count(*) from e01admin.e01e203 
  	where geb_bezei like '905%'
  
  Don't try to put parameters into the sql-query like this:
  
  	# Does not work like you think.
  	# Only the first word of the query is parsed,
  	# so it's changed to "statistic_area", the rest is omitted.
  	# You _have_ to work with $cur->bind_param.
  	my $sql = "statistic_area 905%";
  	my $cur = $dbh->prepare($sql);
  	...
  
  
  =head2 Problems
  
  =over 4
  
  =item * I don't know how to restrict users to special databases.
  
  =item * I don't know how to pass query-parameters via dbish
  
  =back
  
  
  =head1 AUTHOR
  
      Copyright (c) 1997    Jochen Wiedmann
                            Am Eisteich 9
                            72555 Metzingen
                            Germany
  
                            Email: joe@ispsoft.de
                            Phone: +49 7123 14881
  
  The DBI::ProxyServer module is free software; you can redistribute it
  and/or modify it under the same terms as Perl itself. In particular
  permission is granted to Tim Bunce for distributing this as a part of
  the DBI.
  
  
  =head1 SEE ALSO
  
  L<dbiproxy>, L<DBD::Proxy>, L<DBI>, L<RPC::PlServer>,
  L<RPC::PlClient>, L<Net::Daemon>, L<Net::Daemon::Log>,
  L<Sys::Syslog>, L<Win32::EventLog>, L<syslog>
DARWIN-THREAD-MULTI-2LEVEL_DBI_PROXYSERVER

$fatpacked{"darwin-thread-multi-2level/DBI/PurePerl.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_PUREPERL';
  ########################################################################
  package		# hide from PAUSE
  	DBI;
  # vim: ts=8:sw=4
  ########################################################################
  #
  # Copyright (c) 2002,2003  Tim Bunce  Ireland.
  #
  # See COPYRIGHT section in DBI.pm for usage and distribution rights.
  #
  ########################################################################
  #
  # Please send patches and bug reports to
  #
  # Jeff Zucker <jeff@vpservices.com>  with cc to <dbi-dev@perl.org>
  #
  ########################################################################
  
  use strict;
  use Carp;
  require Symbol;
  
  require utf8;
  *utf8::is_utf8 = sub { # hack for perl 5.6
      require bytes;
      return unless defined $_[0];
      return !(length($_[0]) == bytes::length($_[0]))
  } unless defined &utf8::is_utf8;
  
  $DBI::PurePerl = $ENV{DBI_PUREPERL} || 1;
  $DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 13911 $ =~ /(\d+)/o);
  
  $DBI::neat_maxlen ||= 400;
  
  $DBI::tfh = Symbol::gensym();
  open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
  select( (select($DBI::tfh), $| = 1)[0] );  # autoflush
  
  # check for weaken support, used by ChildHandles
  my $HAS_WEAKEN = eval {
      require Scalar::Util;
      # this will croak() if this Scalar::Util doesn't have a working weaken().
      Scalar::Util::weaken( my $test = [] );
      1;
  };
  
  %DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err);
  
  use constant SQL_ALL_TYPES => 0;
  use constant SQL_ARRAY => 50;
  use constant SQL_ARRAY_LOCATOR => 51;
  use constant SQL_BIGINT => (-5);
  use constant SQL_BINARY => (-2);
  use constant SQL_BIT => (-7);
  use constant SQL_BLOB => 30;
  use constant SQL_BLOB_LOCATOR => 31;
  use constant SQL_BOOLEAN => 16;
  use constant SQL_CHAR => 1;
  use constant SQL_CLOB => 40;
  use constant SQL_CLOB_LOCATOR => 41;
  use constant SQL_DATE => 9;
  use constant SQL_DATETIME => 9;
  use constant SQL_DECIMAL => 3;
  use constant SQL_DOUBLE => 8;
  use constant SQL_FLOAT => 6;
  use constant SQL_GUID => (-11);
  use constant SQL_INTEGER => 4;
  use constant SQL_INTERVAL => 10;
  use constant SQL_INTERVAL_DAY => 103;
  use constant SQL_INTERVAL_DAY_TO_HOUR => 108;
  use constant SQL_INTERVAL_DAY_TO_MINUTE => 109;
  use constant SQL_INTERVAL_DAY_TO_SECOND => 110;
  use constant SQL_INTERVAL_HOUR => 104;
  use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111;
  use constant SQL_INTERVAL_HOUR_TO_SECOND => 112;
  use constant SQL_INTERVAL_MINUTE => 105;
  use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113;
  use constant SQL_INTERVAL_MONTH => 102;
  use constant SQL_INTERVAL_SECOND => 106;
  use constant SQL_INTERVAL_YEAR => 101;
  use constant SQL_INTERVAL_YEAR_TO_MONTH => 107;
  use constant SQL_LONGVARBINARY => (-4);
  use constant SQL_LONGVARCHAR => (-1);
  use constant SQL_MULTISET => 55;
  use constant SQL_MULTISET_LOCATOR => 56;
  use constant SQL_NUMERIC => 2;
  use constant SQL_REAL => 7;
  use constant SQL_REF => 20;
  use constant SQL_ROW => 19;
  use constant SQL_SMALLINT => 5;
  use constant SQL_TIME => 10;
  use constant SQL_TIMESTAMP => 11;
  use constant SQL_TINYINT => (-6);
  use constant SQL_TYPE_DATE => 91;
  use constant SQL_TYPE_TIME => 92;
  use constant SQL_TYPE_TIMESTAMP => 93;
  use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95;
  use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94;
  use constant SQL_UDT => 17;
  use constant SQL_UDT_LOCATOR => 18;
  use constant SQL_UNKNOWN_TYPE => 0;
  use constant SQL_VARBINARY => (-3);
  use constant SQL_VARCHAR => 12;
  use constant SQL_WCHAR => (-8);
  use constant SQL_WLONGVARCHAR => (-10);
  use constant SQL_WVARCHAR => (-9);
  
  # for Cursor types
  use constant SQL_CURSOR_FORWARD_ONLY  => 0;
  use constant SQL_CURSOR_KEYSET_DRIVEN => 1;
  use constant SQL_CURSOR_DYNAMIC       => 2;
  use constant SQL_CURSOR_STATIC        => 3;
  use constant SQL_CURSOR_TYPE_DEFAULT  => SQL_CURSOR_FORWARD_ONLY;
  
  use constant IMA_HAS_USAGE	=> 0x0001; #/* check parameter usage	*/
  use constant IMA_FUNC_REDIRECT	=> 0x0002; #/* is $h->func(..., "method")*/
  use constant IMA_KEEP_ERR	=> 0x0004; #/* don't reset err & errstr	*/
  use constant IMA_KEEP_ERR_SUB	=> 0x0008; #/*  '' if in nested call */
  use constant IMA_NO_TAINT_IN   	=> 0x0010; #/* don't check for tainted args*/
  use constant IMA_NO_TAINT_OUT   => 0x0020; #/* don't taint results	*/
  use constant IMA_COPY_UP_STMT   => 0x0040; #/* copy sth Statement to dbh */
  use constant IMA_END_WORK	=> 0x0080; #/* set on commit & rollback	*/
  use constant IMA_STUB		=> 0x0100; #/* donothing eg $dbh->connected */
  use constant IMA_CLEAR_STMT     => 0x0200; #/* clear Statement before call  */
  use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement   */
  use constant IMA_NOT_FOUND_OKAY	=> 0x0800; #/* not error if not found */
  use constant IMA_EXECUTE	=> 0x1000; #/* do/execute: DBIcf_Executed   */
  use constant IMA_SHOW_ERR_STMT  => 0x2000; #/* dbh meth relates to Statement*/
  use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */
  use constant IMA_IS_FACTORY     => 0x8000; #/* new h ie connect & prepare */
  use constant IMA_CLEAR_CACHED_KIDS    => 0x10000; #/* clear CachedKids before call */
  
  use constant DBIstcf_STRICT           => 0x0001;
  use constant DBIstcf_DISCARD_STRING   => 0x0002;
  
  my %is_flag_attribute = map {$_ =>1 } qw(
  	Active
  	AutoCommit
  	ChopBlanks
  	CompatMode
  	Executed
  	Taint
  	TaintIn
  	TaintOut
  	InactiveDestroy
  	LongTruncOk
  	MultiThread
  	PrintError
  	PrintWarn
  	RaiseError
  	ShowErrorStatement
  	Warn
  );
  my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw(
  	ActiveKids
  	Attribution
  	BegunWork
  	CachedKids
          Callbacks
  	ChildHandles
  	CursorName
  	Database
  	DebugDispatch
  	Driver
          Err
          Errstr
  	ErrCount
  	FetchHashKeyName
  	HandleError
  	HandleSetErr
  	ImplementorClass
  	Kids
  	LongReadLen
  	NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash
  	NULLABLE
  	NUM_OF_FIELDS
  	NUM_OF_PARAMS
  	Name
  	PRECISION
  	ParamValues
  	Profile
  	Provider
          ReadOnly
  	RootClass
  	RowCacheSize
  	RowsInCache
  	SCALE
          State
  	Statement
  	TYPE
          Type
  	TraceLevel
  	Username
  	Version
  ));
  
  sub valid_attribute {
      my $attr = shift;
      return 1 if $is_valid_attribute{$attr};
      return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter
      return 0
  }
  
  my $initial_setup;
  sub initial_setup {
      $initial_setup = 1;
      print $DBI::tfh  __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n"
  	if $DBI::dbi_debug & 0xF;
      untie $DBI::err;
      untie $DBI::errstr;
      untie $DBI::state;
      untie $DBI::rows;
      #tie $DBI::lasth,  'DBI::var', '!lasth';  # special case: return boolean
  }
  
  sub  _install_method {
      my ( $caller, $method, $from, $param_hash ) = @_;
      initial_setup() unless $initial_setup;
  
      my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/;
      my $bitmask = $param_hash->{'O'} || 0;
      my @pre_call_frag;
  
      return if $method_name eq 'can';
  
      push @pre_call_frag, q{
  	return if $h_inner; # ignore DESTROY for outer handle
  	# copy err/errstr/state up to driver so $DBI::err etc still work
  	if ($h->{err} and my $drh = $h->{Driver}) {
  	    $drh->{$_} = $h->{$_} for ('err','errstr','state');
  	}
      } if $method_name eq 'DESTROY';
  
      push @pre_call_frag, q{
  	return $h->{$_[0]} if exists $h->{$_[0]};
      } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ?
  
      push @pre_call_frag, "return;"
  	if IMA_STUB & $bitmask;
  
      push @pre_call_frag, q{
  	$method_name = pop @_;
      } if IMA_FUNC_REDIRECT & $bitmask;
  
      push @pre_call_frag, q{
  	my $parent_dbh = $h->{Database};
      } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask;
  
      push @pre_call_frag, q{
  	warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems
  	$parent_dbh->{Statement} = $h->{Statement} if $parent_dbh;
      } if IMA_COPY_UP_STMT & $bitmask;
  
      push @pre_call_frag, q{
  	$h->{Executed} = 1;
  	$parent_dbh->{Executed} = 1 if $parent_dbh;
      } if IMA_EXECUTE & $bitmask;
  
      push @pre_call_frag, q{
  	%{ $h->{CachedKids} } = () if $h->{CachedKids};
      } if IMA_CLEAR_CACHED_KIDS & $bitmask;
  
      if (IMA_KEEP_ERR & $bitmask) {
  	push @pre_call_frag, q{
  	    my $keep_error = 1;
  	};
      }
      else {
  	my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask)
  		? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} }
  		: "";
  	push @pre_call_frag, qq{
  	    my \$keep_error $ke_init;
  	};
  	my $keep_error_code = q{
  	    #warn "$method_name cleared err";
  	    $h->{err}    = $DBI::err    = undef;
  	    $h->{errstr} = $DBI::errstr = undef;
  	    $h->{state}  = $DBI::state  = '';
  	};
  	$keep_error_code = q{
  	    printf $DBI::tfh "    !! %s: %s CLEARED by call to }.$method_name.q{ method\n".
  		    $h->{err}, $h->{err}
  		if defined $h->{err} && $DBI::dbi_debug & 0xF;
  	}. $keep_error_code
  	    if exists $ENV{DBI_TRACE};
  	push @pre_call_frag, ($ke_init)
  		? qq{ unless (\$keep_error) { $keep_error_code }}
  		: $keep_error_code
  	    unless $method_name eq 'set_err';
      }
  
      push @pre_call_frag, q{
  	my $ErrCount = $h->{ErrCount};
      };
  
      push @pre_call_frag, q{
          if (($DBI::dbi_debug & 0xF) >= 2) {
  	    local $^W;
  	    my $args = join " ", map { DBI::neat($_) } ($h, @_);
  	    printf $DBI::tfh "    > $method_name in $imp ($args) [$@]\n";
  	}
      } if exists $ENV{DBI_TRACE};	# note use of 'exists'
  
      push @pre_call_frag, q{
          $h->{'dbi_pp_last_method'} = $method_name;
      } unless exists $DBI::last_method_except{$method_name};
  
      # --- post method call code fragments ---
      my @post_call_frag;
  
      push @post_call_frag, q{
          if (my $trace_level = ($DBI::dbi_debug & 0xF)) {
  	    if ($h->{err}) {
  		printf $DBI::tfh "    !! ERROR: %s %s\n", $h->{err}, $h->{errstr};
  	    }
  	    my $ret = join " ", map { DBI::neat($_) } @ret;
  	    my $msg = "    < $method_name= $ret";
  	    $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n";
  	    print $DBI::tfh $msg;
  	}
      } if exists $ENV{DBI_TRACE}; # note use of exists
  
      push @post_call_frag, q{
  	$h->{Executed} = 0;
  	if ($h->{BegunWork}) {
  	    $h->{BegunWork}  = 0;
  	    $h->{AutoCommit} = 1;
  	}
      } if IMA_END_WORK & $bitmask;
  
      push @post_call_frag, q{
          if ( ref $ret[0] and
              UNIVERSAL::isa($ret[0], 'DBI::_::common') and
              defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} )
          ) {
              # copy up info/warn to drh so PrintWarn on connect is triggered
              $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state})
          }
      } if IMA_IS_FACTORY & $bitmask;
  
      push @post_call_frag, q{
  	$keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;
  
  	$DBI::err    = $h->{err};
  	$DBI::errstr = $h->{errstr};
  	$DBI::state  = $h->{state};
  
          if ( !$keep_error
  	&& defined(my $err = $h->{err})
  	&& ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth})
  	) {
  
  	    my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)};
  	    my $msg;
  
  	    if ($err && ($pe || $re || $he)	# error
  	    or (!$err && length($err) && $pw)	# warning
  	    ) {
  		my $last = ($DBI::last_method_except{$method_name})
  		    ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name;
  		my $errstr = $h->{errstr} || $DBI::errstr || $err || '';
  		my $msg = sprintf "%s %s %s: %s", $imp, $last,
  			($err eq "0") ? "warning" : "failed", $errstr;
  
  		if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) {
  		    $msg .= ' [for Statement "' . $Statement;
  		    if (my $ParamValues = $h->FETCH('ParamValues')) {
  			$msg .= '" with ParamValues: ';
  			$msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef);
                          $msg .= "]";
  		    }
                      else {
                          $msg .= '"]';
                      }
  		}
  		if ($err eq "0") { # is 'warning' (not info)
  		    carp $msg if $pw;
  		}
  		else {
  		    my $do_croak = 1;
  		    if (my $subsub = $h->{'HandleError'}) {
  			$do_croak = 0 if &$subsub($msg,$h,$ret[0]);
  		    }
  		    if ($do_croak) {
  			printf $DBI::tfh "    $method_name has failed ($h->{PrintError},$h->{RaiseError})\n"
  				if ($DBI::dbi_debug & 0xF) >= 4;
  			carp  $msg if $pe;
  			die $msg if $h->{RaiseError};
  		    }
  		}
  	    }
  	}
      };
  
  
      my $method_code = q[
        sub {
          my $h = shift;
  	my $h_inner = tied(%$h);
  	$h = $h_inner if $h_inner;
  
          my $imp;
  	if ($method_name eq 'DESTROY') {
  	    # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value"
  	    # implying that tied() above lied to us, so we need to use eval
  	    local $@;	 # protect $@
  	    $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction
  	}
  	else {
  	    $imp = $h->{"ImplementorClass"} or do {
                  warn "Can't call $method_name method on handle $h after take_imp_data()\n"
                      if not exists $h->{Active};
                  return; # or, more likely, global destruction
              };
  	}
  
  	] . join("\n", '', @pre_call_frag, '') . q[
  
  	my $call_depth = $h->{'dbi_pp_call_depth'} + 1;
  	local ($h->{'dbi_pp_call_depth'}) = $call_depth;
  
  	my @ret;
          my $sub = $imp->can($method_name);
          if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) {
              push @_, $method_name;
          }
  	if ($sub) {
  	    (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_));
  	}
  	else {
  	    # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc
  	    # which would then let Multiplex pass PurePerl tests, but some
  	    # hook into install_method may be better.
  	    croak "Can't locate DBI object method \"$method_name\" via package \"$imp\""
  		if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[;
  	}
  
  	] . join("\n", '', @post_call_frag, '') . q[
  
  	return (wantarray) ? @ret : $ret[0];
        }
      ];
      no strict qw(refs);
      my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code};
      warn "$@\n$method_code\n" if $@;
      die "$@\n$method_code\n" if $@;
      *$method = $code_ref;
      if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool
  	my $l=0; # show line-numbered code for method
  	warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code);
      }
  }
  
  
  sub _new_handle {
      my ($class, $parent, $attr, $imp_data, $imp_class) = @_;
  
      DBI->trace_msg("    New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n")
          if $DBI::dbi_debug >= 3;
  
      $attr->{ImplementorClass} = $imp_class
          or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given");
  
      # This is how we create a DBI style Object:
      # %outer gets tied to %$attr (which becomes the 'inner' handle)
      my (%outer, $i, $h);
      $i = tie    %outer, $class, $attr;  # ref to inner hash (for driver)
      $h = bless \%outer, $class;         # ref to outer hash (for application)
      # The above tie and bless may migrate down into _setup_handle()...
      # Now add magic so DBI method dispatch works
      DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
      return $h unless wantarray;
      return ($h, $i);
  }
  
  sub _setup_handle {
      my($h, $imp_class, $parent, $imp_data) = @_;
      my $h_inner = tied(%$h) || $h;
      if (($DBI::dbi_debug & 0xF) >= 4) {
  	local $^W;
  	print $DBI::tfh "      _setup_handle(@_)\n";
      }
      $h_inner->{"imp_data"} = $imp_data;
      $h_inner->{"ImplementorClass"} = $imp_class;
      $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0;	# XXX not maintained
      if ($parent) {
  	foreach (qw(
  	    RaiseError PrintError PrintWarn HandleError HandleSetErr
  	    Warn LongTruncOk ChopBlanks AutoCommit ReadOnly
  	    ShowErrorStatement FetchHashKeyName LongReadLen CompatMode
  	)) {
  	    $h_inner->{$_} = $parent->{$_}
  		if exists $parent->{$_} && !exists $h_inner->{$_};
  	}
  	if (ref($parent) =~ /::db$/) {
  	    $h_inner->{Database} = $parent;
  	    $parent->{Statement} = $h_inner->{Statement};
  	    $h_inner->{NUM_OF_PARAMS} = 0;
  	}
  	elsif (ref($parent) =~ /::dr$/){
  	    $h_inner->{Driver} = $parent;
  	}
  	$h_inner->{dbi_pp_parent} = $parent;
  
  	# add to the parent's ChildHandles
  	if ($HAS_WEAKEN) {
  	    my $handles = $parent->{ChildHandles} ||= [];
  	    push @$handles, $h;
  	    Scalar::Util::weaken($handles->[-1]);
  	    # purge destroyed handles occasionally
  	    if (@$handles % 120 == 0) {
  		@$handles = grep { defined } @$handles;
  		Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
  	    }
  	}
      }
      else {	# setting up a driver handle
          $h_inner->{Warn}		= 1;
          $h_inner->{PrintWarn}		= $^W;
          $h_inner->{AutoCommit}		= 1;
          $h_inner->{TraceLevel}		= 0;
          $h_inner->{CompatMode}		= (1==0);
  	$h_inner->{FetchHashKeyName}	||= 'NAME';
  	$h_inner->{LongReadLen}		||= 80;
  	$h_inner->{ChildHandles}        ||= [] if $HAS_WEAKEN;
  	$h_inner->{Type}                ||= 'dr';
      }
      $h_inner->{"dbi_pp_call_depth"} = 0;
      $h_inner->{ErrCount} = 0;
      $h_inner->{Active} = 1;
  }
  
  sub constant {
      warn "constant(@_) called unexpectedly"; return undef;
  }
  
  sub trace {
      my ($h, $level, $file) = @_;
      $level = $h->parse_trace_flags($level)
  	if defined $level and !DBI::looks_like_number($level);
      my $old_level = $DBI::dbi_debug;
      _set_trace_file($file) if $level;
      if (defined $level) {
  	$DBI::dbi_debug = $level;
  	print $DBI::tfh "    DBI $DBI::VERSION (PurePerl) "
                  . "dispatch trace level set to $DBI::dbi_debug\n"
  		if $DBI::dbi_debug & 0xF;
      }
      _set_trace_file($file) if !$level;
      return $old_level;
  }
  
  sub _set_trace_file {
      my ($file) = @_;
      #
      #   DAA add support for filehandle inputs
      #
      # DAA required to avoid closing a prior fh trace()
      $DBI::tfh = undef unless $DBI::tfh_needs_close;
  
      if (ref $file eq 'GLOB') {
  	$DBI::tfh = $file;
          select((select($DBI::tfh), $| = 1)[0]);
          $DBI::tfh_needs_close = 0;
          return 1;
      }
      if ($file && ref \$file eq 'GLOB') {
  	$DBI::tfh = *{$file}{IO};
          select((select($DBI::tfh), $| = 1)[0]);
          $DBI::tfh_needs_close = 0;
          return 1;
      }
      $DBI::tfh_needs_close = 1;
      if (!$file || $file eq 'STDERR') {
  	open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!";
      }
      elsif ($file eq 'STDOUT') {
  	open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!";
      }
      else {
          open $DBI::tfh, ">>$file" or carp "Can't open $file: $!";
      }
      select((select($DBI::tfh), $| = 1)[0]);
      return 1;
  }
  sub _get_imp_data {  shift->{"imp_data"}; }
  sub _svdump       { }
  sub dump_handle   {
      my ($h,$msg,$level) = @_;
      $msg||="dump_handle $h";
      print $DBI::tfh "$msg:\n";
      for my $attrib (sort keys %$h) {
  	print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n";
      }
  }
  
  sub _handles {
      my $h = shift;
      my $h_inner = tied %$h;
      if ($h_inner) {	# this is okay
  	return $h unless wantarray;
  	return ($h, $h_inner);
      }
      # XXX this isn't okay... we have an inner handle but
      # currently have no way to get at its outer handle,
      # so we just warn and return the inner one for both...
      Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl");
      return $h unless wantarray;
      return ($h,$h);
  }
  
  sub hash {
      my ($key, $type) = @_;
      my ($hash);
      if (!$type) {
          $hash = 0;
          # XXX The C version uses the "char" type, which could be either
          # signed or unsigned.  I use signed because so do the two
          # compilers on my system.
          for my $char (unpack ("c*", $key)) {
              $hash = $hash * 33 + $char;
          }
          $hash &= 0x7FFFFFFF;    # limit to 31 bits
          $hash |= 0x40000000;    # set bit 31
          return -$hash;          # return negative int
      }
      elsif ($type == 1) {	# Fowler/Noll/Vo hash
          # see http://www.isthe.com/chongo/tech/comp/fnv/
          require Math::BigInt;   # feel free to reimplement w/o BigInt!
  	(my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01"
  	if ($version >= 1.56) {
  	    $hash = Math::BigInt->new(0x811c9dc5);
  	    for my $uchar (unpack ("C*", $key)) {
  		# multiply by the 32 bit FNV magic prime mod 2^64
  		$hash = ($hash * 0x01000193) & 0xffffffff;
  		# xor the bottom with the current octet
  		$hash ^= $uchar;
  	    }
  	    # cast to int
  	    return unpack "i", pack "i", $hash;
  	}
  	croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)");
      }
      else {
          croak("bad hash type $type");
      }
  }
  
  sub looks_like_number {
      my @new = ();
      for my $thing(@_) {
          if (!defined $thing or $thing eq '') {
              push @new, undef;
          }
          else {
              push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0;
          }
      }
      return (@_ >1) ? @new : $new[0];
  }
  
  sub neat {
      my $v = shift;
      return "undef" unless defined $v;
      my $quote = q{"};
      if (not utf8::is_utf8($v)) {
          return $v if (($v & ~ $v) eq "0"); # is SvNIOK
          $quote = q{'};
      }
      my $maxlen = shift || $DBI::neat_maxlen;
      if ($maxlen && $maxlen < length($v) + 2) {
  	$v = substr($v,0,$maxlen-5);
  	$v .= '...';
      }
      $v =~ s/[^[:print:]]/./g;
      return "$quote$v$quote";
  }
  
  sub sql_type_cast {
      my (undef, $sql_type, $flags) = @_;
  
      return -1 unless defined $_[0];
  
      my $cast_ok = 1;
  
      my $evalret = eval {
          use warnings FATAL => qw(numeric);
          if ($sql_type == SQL_INTEGER) {
              my $dummy = $_[0] + 0;
              return 1;
          }
          elsif ($sql_type == SQL_DOUBLE) {
              my $dummy = $_[0] + 0.0;
              return 1;
          }
          elsif ($sql_type == SQL_NUMERIC) {
              my $dummy = $_[0] + 0.0;
              return 1;
          }
          else {
              return -2;
          }
      } or $^W && warn $@; # XXX warnings::warnif("numeric", $@) ?
  
      return $evalret if defined($evalret) && ($evalret == -2);
      $cast_ok = 0 unless $evalret;
  
      # DBIstcf_DISCARD_STRING not supported for PurePerl currently
  
      return 2 if $cast_ok;
      return 0 if $flags & DBIstcf_STRICT;
      return 1;
  }
  
  sub dbi_time {
      return time();
  }
  
  sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
  
  sub _concat_hash_sorted {
      my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_;
      # $num_sort: 0=lexical, 1=numeric, undef=try to guess
  
      return undef unless defined $hash_ref;
      die "hash is not a hash reference" unless ref $hash_ref eq 'HASH';
      my $keys = _get_sorted_hash_keys($hash_ref, $num_sort);
      my $string = '';
      for my $key (@$keys) {
          $string .= $pair_separator if length $string > 0;
          my $value = $hash_ref->{$key};
          if ($use_neat) {
              $value = DBI::neat($value, 0);
          }
          else {
              $value = (defined $value) ? "'$value'" : 'undef';
          }
          $string .= $key . $kv_separator . $value;
      }
      return $string;
  }
  
  sub _get_sorted_hash_keys {
      my ($hash_ref, $num_sort) = @_;
      if (not defined $num_sort) {
          my $sort_guess = 1;
          $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess
              for keys %$hash_ref;
          $num_sort = $sort_guess;
      }
      
      my @keys = keys %$hash_ref;
      no warnings 'numeric';
      my @sorted = ($num_sort)
          ? sort { $a <=> $b or $a cmp $b } @keys
          : sort    @keys;
      return \@sorted;
  }
  
  
  
  package
  	DBI::var;
  
  sub FETCH {
      my($key)=shift;
      return $DBI::err     if $$key eq '*err';
      return $DBI::errstr  if $$key eq '&errstr';
      Carp::confess("FETCH $key not supported when using DBI::PurePerl");
  }
  
  package
  	DBD::_::common;
  
  sub swap_inner_handle {
      my ($h1, $h2) = @_;
      # can't make this work till we can get the outer handle from the inner one
      # probably via a WeakRef
      return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl");
  }
  
  sub trace {	# XXX should set per-handle level, not global
      my ($h, $level, $file) = @_;
      $level = $h->parse_trace_flags($level)
  	if defined $level and !DBI::looks_like_number($level);
      my $old_level = $DBI::dbi_debug;
      DBI::_set_trace_file($file) if defined $file;
      if (defined $level) {
  	$DBI::dbi_debug = $level;
  	if ($DBI::dbi_debug) {
  	    printf $DBI::tfh
  		"    %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n",
  		$h, $DBI::dbi_debug;
  	    print $DBI::tfh "    Full trace not available because DBI_TRACE is not in environment\n"
  		unless exists $ENV{DBI_TRACE};
  	}
      }
      return $old_level;
  }
  *debug = \&trace; *debug = \&trace; # twice to avoid typo warning
  
  sub FETCH {
      my($h,$key)= @_;
      my $v = $h->{$key};
      #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n");
      return $v if defined $v;
      if ($key =~ /^NAME_.c$/) {
          my $cols = $h->FETCH('NAME');
          return undef unless $cols;
          my @lcols = map { lc $_ } @$cols;
          $h->{NAME_lc} = \@lcols;
          my @ucols = map { uc $_ } @$cols;
          $h->{NAME_uc} = \@ucols;
          return $h->FETCH($key);
      }
      if ($key =~ /^NAME.*_hash$/) {
          my $i=0;
          for my $c(@{$h->FETCH('NAME')||[]}) {
              $h->{'NAME_hash'}->{$c}    = $i;
              $h->{'NAME_lc_hash'}->{"\L$c"} = $i;
              $h->{'NAME_uc_hash'}->{"\U$c"} = $i;
              $i++;
          }
          return $h->{$key};
      }
      if (!defined $v && !exists $h->{$key}) {
  	return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint';
  	return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef
  	return $DBI::dbi_debug if $key eq 'TraceLevel';
          return [] if $key eq 'ChildHandles' && $HAS_WEAKEN;
          if ($key eq 'Type') {
              return "dr" if $h->isa('DBI::dr');
              return "db" if $h->isa('DBI::db');
              return "st" if $h->isa('DBI::st');
              Carp::carp( sprintf "Can't determine Type for %s",$h );
          }
  	if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
  	    local $^W; # hide undef warnings
  	    Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key )
  	}
      }
      return $v;
  }
  sub STORE {
      my ($h,$key,$value) = @_;
      if ($key eq 'AutoCommit') {
          Carp::croak("DBD driver has not implemented the AutoCommit attribute")
  	    unless $value == -900 || $value == -901;
  	$value = ($value == -901);
      }
      elsif ($key =~ /^Taint/ ) {
  	Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key)
  		if $value;
      }
      elsif ($key eq 'TraceLevel') {
  	$h->trace($value);
  	return 1;
      }
      elsif ($key eq 'NUM_OF_FIELDS') {
          $h->{$key} = $value;
          if ($value) {
              my $fbav = DBD::_::st::dbih_setup_fbav($h);
              @$fbav = (undef) x $value if @$fbav != $value;
          }
  	return 1;
      }
      elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) {
         Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s",
  	    $h,$key,$value);
      }
      $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value;
      return 1;
  }
  sub err    { return shift->{err}    }
  sub errstr { return shift->{errstr} }
  sub state  { return shift->{state}  }
  sub set_err {
      my ($h, $errnum,$msg,$state, $method, $rv) = @_;
      $h = tied(%$h) || $h;
  
      if (my $hss = $h->{HandleSetErr}) {
  	return if $hss->($h, $errnum, $msg, $state, $method);
      }
  
      if (!defined $errnum) {
  	$h->{err}    = $DBI::err    = undef;
  	$h->{errstr} = $DBI::errstr = undef;
  	$h->{state}  = $DBI::state  = '';
          return;
      }
  
      if ($h->{errstr}) {
  	$h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum
  		if $h->{err} && $errnum && $h->{err} ne $errnum;
  	$h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state
  		if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state;
  	$h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg;
  	$DBI::errstr = $h->{errstr};
      }
      else {
  	$h->{errstr} = $DBI::errstr = $msg;
      }
  
      # assign if higher priority: err > "0" > "" > undef
      my $err_changed;
      if ($errnum			# new error: so assign
  	or !defined $h->{err}	# no existing warn/info: so assign
             # new warn ("0" len 1) > info ("" len 0): so assign
  	or defined $errnum && length($errnum) > length($h->{err})
      ) {
          $h->{err} = $DBI::err = $errnum;
  	++$h->{ErrCount} if $errnum;
  	++$err_changed;
      }
  
      if ($err_changed) {
  	$state ||= "S1000" if $DBI::err;
  	$h->{state} = $DBI::state = ($state eq "00000") ? "" : $state
  	    if $state;
      }
  
      if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY)
  	$p->{err}    = $DBI::err;
  	$p->{errstr} = $DBI::errstr;
  	$p->{state}  = $DBI::state;
      }
  
      $h->{'dbi_pp_last_method'} = $method;
      return $rv; # usually undef
  }
  sub trace_msg {
      my ($h, $msg, $minlevel)=@_;
      $minlevel = 1 unless defined $minlevel;
      return unless $minlevel <= ($DBI::dbi_debug & 0xF);
      print $DBI::tfh $msg;
      return 1;
  }
  sub private_data {
      warn "private_data @_";
  }
  sub take_imp_data {
      my $dbh = shift;
      # A reasonable default implementation based on the one in DBI.xs.
      # Typically a pure-perl driver would have their own take_imp_data method
      # that would delete all but the essential items in the hash before einding with:
      #      return $dbh->SUPER::take_imp_data();
      # Of course it's useless if the driver doesn't also implement support for
      # the dbi_imp_data attribute to the connect() method.
      require Storable;
      croak("Can't take_imp_data from handle that's not Active")
          unless $dbh->{Active};
      for my $sth (@{ $dbh->{ChildHandles} || [] }) {
          next unless $sth;
          $sth->finish if $sth->{Active};
          bless $sth, 'DBI::zombie';
      }
      delete $dbh->{$_} for (keys %is_valid_attribute);
      delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh;
      # warn "@{[ %$dbh ]}";
      local $Storable::forgive_me = 1; # in case there are some CODE refs
      my $imp_data = Storable::freeze($dbh);
      # XXX um, should probably untie here - need to check dispatch behaviour
      return $imp_data;
  }
  sub rows {
      return -1; # always returns -1 here, see DBD::_::st::rows below
  }
  sub DESTROY {
  }
  
  package
  	DBD::_::dr;
  
  sub dbixs_revision {
      return 0;
  }
  
  package
  	DBD::_::db;
  
  sub connected {
  }
  
  
  package
  	DBD::_::st;
  
  sub fetchrow_arrayref	{
      my $h = shift;
      # if we're here then driver hasn't implemented fetch/fetchrow_arrayref
      # so we assume they've implemented fetchrow_array and call that instead
      my @row = $h->fetchrow_array or return;
      return $h->_set_fbav(\@row);
  }
  # twice to avoid typo warning
  *fetch = \&fetchrow_arrayref;  *fetch = \&fetchrow_arrayref;
  
  sub fetchrow_array	{
      my $h = shift;
      # if we're here then driver hasn't implemented fetchrow_array
      # so we assume they've implemented fetch/fetchrow_arrayref
      my $row = $h->fetch or return;
      return @$row;
  }
  *fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array;
  
  sub fetchrow_hashref {
      my $h         = shift;
      my $row       = $h->fetch or return;
      my $FetchCase = shift;
      my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME';
      my $FetchHashKeys    = $h->FETCH($FetchHashKeyName);
      my %rowhash;
      @rowhash{ @$FetchHashKeys } = @$row;
      return \%rowhash;
  }
  sub dbih_setup_fbav {
      my $h = shift;
      return $h->{'_fbav'} || do {
          $DBI::rows = $h->{'_rows'} = 0;
          my $fields = $h->{'NUM_OF_FIELDS'}
                    or DBI::croak("NUM_OF_FIELDS not set");
          my @row = (undef) x $fields;
          \@row;
      };
  }
  sub _get_fbav {
      my $h = shift;
      my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h);
      $DBI::rows = ++$h->{'_rows'};
      return $av;
  }
  sub _set_fbav {
      my $h = shift;
      my $fbav = $h->{'_fbav'};
      if ($fbav) {
  	$DBI::rows = ++$h->{'_rows'};
      }
      else {
  	$fbav = $h->_get_fbav;
      }
      my $row = shift;
      if (my $bc = $h->{'_bound_cols'}) {
          for my $i (0..@$row-1) {
              my $bound = $bc->[$i];
              $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i];
          }
      }
      else {
          @$fbav = @$row;
      }
      return $fbav;
  }
  sub bind_col {
      my ($h, $col, $value_ref,$from_bind_columns) = @_;
      my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav()
      my $num_of_fields = @$fbav;
      DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)")
          if $col < 1 or $col > $num_of_fields;
      return 1 if not defined $value_ref; # ie caller is just trying to set TYPE
      DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar")
  	unless ref $value_ref eq 'SCALAR';
      $h->{'_bound_cols'}->[$col-1] = $value_ref;
      return 1;
  }
  sub finish {
      my $h = shift;
      $h->{'_fbav'} = undef;
      $h->{'Active'} = 0;
      return 1;
  }
  sub rows {
      my $h = shift;
      my $rows = $h->{'_rows'};
      return -1 unless defined $rows;
      return $rows;
  }
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  DBI::PurePerl -- a DBI emulation using pure perl (no C/XS compilation required)
  
  =head1 SYNOPSIS
  
   BEGIN { $ENV{DBI_PUREPERL} = 2 }
   use DBI;
  
  =head1 DESCRIPTION
  
  This is a pure perl emulation of the DBI internals.  In almost all
  cases you will be better off using standard DBI since the portions
  of the standard version written in C make it *much* faster.
  
  However, if you are in a situation where it isn't possible to install
  a compiled version of standard DBI, and you're using pure-perl DBD
  drivers, then this module allows you to use most common features
  of DBI without needing any changes in your scripts.
  
  =head1 EXPERIMENTAL STATUS
  
  DBI::PurePerl is new so please treat it as experimental pending
  more extensive testing.  So far it has passed all tests with DBD::CSV,
  DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP.  Please send
  bug reports to Jeff Zucker at <jeff@vpservices.com> with a cc to
  <dbi-dev@perl.org>.
  
  =head1 USAGE
  
  The usage is the same as for standard DBI with the exception
  that you need to set the enviornment variable DBI_PUREPERL if
  you want to use the PurePerl version.
  
   DBI_PUREPERL == 0 (the default) Always use compiled DBI, die
                     if it isn't properly compiled & installed
  
   DBI_PUREPERL == 1 Use compiled DBI if it is properly compiled
                     & installed, otherwise use PurePerl
  
   DBI_PUREPERL == 2 Always use PurePerl
  
  You may set the enviornment variable in your shell (e.g. with
  set or setenv or export, etc) or else set it in your script like
  this:
  
   BEGIN { $ENV{DBI_PUREPERL}=2 }
  
  before you C<use DBI;>.
  
  =head1 INSTALLATION
  
  In most situations simply install DBI (see the DBI pod for details).
  
  In the situation in which you can not install DBI itself, you
  may manually copy DBI.pm and PurePerl.pm into the appropriate
  directories.
  
  For example:
  
   cp DBI.pm      /usr/jdoe/mylibs/.
   cp PurePerl.pm /usr/jdoe/mylibs/DBI/.
  
  Then add this to the top of scripts:
  
   BEGIN {
     $ENV{DBI_PUREPERL} = 1;	# or =2
     unshift @INC, '/usr/jdoe/mylibs';
   }
  
  (Or should we perhaps patch Makefile.PL so that if DBI_PUREPERL
  is set to 2 prior to make, the normal compile process is skipped
  and the files are installed automatically?)
  
  =head1 DIFFERENCES BETWEEN DBI AND DBI::PurePerl
  
  =head2 Attributes
  
  Boolean attributes still return boolean values but the actual values
  used may be different, i.e., 0 or undef instead of an empty string.
  
  Some handle attributes are either not supported or have very limited
  functionality:
  
    ActiveKids
    InactiveDestroy
    Kids
    Taint
    TaintIn
    TaintOut
  
  (and probably others)
  
  =head2 Tracing
  
  Trace functionality is more limited and the code to handle tracing is
  only embeded into DBI:PurePerl if the DBI_TRACE environment variable
  is defined.  To enable total tracing you can set the DBI_TRACE
  environment variable as usual.  But to enable individual handle
  tracing using the trace() method you also need to set the DBI_TRACE
  environment variable, but set it to 0.
  
  =head2 Parameter Usage Checking
  
  The DBI does some basic parameter count checking on method calls.
  DBI::PurePerl doesn't.
  
  =head2 Speed
  
  DBI::PurePerl is slower. Although, with some drivers in some
  contexts this may not be very significant for you.
  
  By way of example... the test.pl script in the DBI source
  distribution has a simple benchmark that just does:
  
      my $null_dbh = DBI->connect('dbi:NullP:','','');
      my $i = 10_000;
      $null_dbh->prepare('') while $i--;
  
  In other words just prepares a statement, creating and destroying
  a statement handle, over and over again.  Using the real DBI this
  runs at ~4550 handles per second whereas DBI::PurePerl manages
  ~2800 per second on the same machine (not too bad really).
  
  =head2 May not fully support hash()
  
  If you want to use type 1 hash, i.e., C<hash($string,1)> with
  DBI::PurePerl, you'll need version 1.56 or higher of Math::BigInt
  (available on CPAN).
  
  =head2 Doesn't support preparse()
  
  The DBI->preparse() method isn't supported in DBI::PurePerl.
  
  =head2 Doesn't support DBD::Proxy
  
  There's a subtle problem somewhere I've not been able to identify.
  DBI::ProxyServer seem to work fine with DBI::PurePerl but DBD::Proxy
  does not work 100% (which is sad because that would be far more useful :)
  Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem
  that remains will affect you're usage.
  
  =head2 Others
  
    can() - doesn't have any special behaviour
  
  Please let us know if you find any other differences between DBI
  and DBI::PurePerl.
  
  =head1 AUTHORS
  
  Tim Bunce and Jeff Zucker.
  
  Tim provided the direction and basis for the code.  The original
  idea for the module and most of the brute force porting from C to
  Perl was by Jeff. Tim then reworked some core parts to boost the
  performance and accuracy of the emulation. Thanks also to Randal
  Schwartz and John Tobey for patches.
  
  =head1 COPYRIGHT
  
  Copyright (c) 2002  Tim Bunce  Ireland.
  
  See COPYRIGHT section in DBI.pm for usage and distribution rights.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_PUREPERL

$fatpacked{"darwin-thread-multi-2level/DBI/Roadmap.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_ROADMAP';
  =head1 NAME
  
  DBI::Roadmap - Planned Enhancements for the DBI
  
  Tim Bunce - 12th November 2004
  
  =head1 SYNOPSIS
  
  This document gives a high level overview of the future of the Perl
  DBI module.
  
  The DBI module is the standard database interface for Perl applications.
  It is used worldwide in countless applications, in every kind of
  business, and on platforms from clustered super-computers to PDAs.
  Database interface drivers are available for all common databases
  and many not-so-common ones.
  
  The planned enhancements cover testing, performance, high availability
  and load balancing, batch statements, Unicode, database portability,
  and more.
  
  Addressing these issues together, in coordinated way, will help
  ensure maximum future functionality with minimal disruptive
  (incompatible) upgrades.
  
  =head1 SCOPE
  
  Broad categories of changes are outlined here along with some
  rationale, but implementation details and minor planned enhancements
  are omitted.  More details can be found in:
  L<http://svn.perl.org/modules/dbi/trunk/ToDo>
  
  
  =head1 CHANGES AND ENHANCEMENTS
  
  These are grouped into categories and are not listed in any particular order.
  
  =head2 Performance
  
  The DBI has always treated performance as a priority. Some parts
  of the implementation, however, remain unoptimized, especially in
  relation to threads.
  
  * When the DBI is used with a Perl built with thread support enabled
  (such as for Apache mod_perl 2, and some common Linux distributions)
  it runs significantly slower. There are two reasons for this and
  both can be fixed but require non-trivial changes to both the DBI
  and drivers.
  
  * Connection pooling in a threaded application, such as mod_perl,
  is difficult because DBI handles cannot be passed between threads.
  An alternative mechanism for passing connections between threads
  has been defined, and an experimental connection pool module
  implemented using it, but development has stalled.
  
  * The majority of DBI handle creation code is implemented in Perl.
  Moving most of this to C will speed up handle creation significantly.
  
  * The popular fetchrow_hashref() method is many times slower than
  fetchrow_arrayref(). It has to get the names of the columns, then
  create and load a new hash each time. A $h->{FetchHashReuse} attribute
  would allow the same hash to be reused each time making fetchrow_hashref()
  about the same speed as fetchrow_arrayref().
  
  * Support for asynchronous (non-blocking) DBI method calls would
  enable applications to continue processing in parallel with database
  activity.  This is also relevant for GUI and other event-driven
  applications.  The DBI needs to define a standard interface for
  this so drivers can implement it in a portable way, where possible.
  
  These changes would significantly enhance the performance of the
  DBI and many applications which use the DBI.
  
  
  =head2 Testing
  
  The DBI has a test suite. Every driver has a test suite.  Each is
  limited in its scope.  The driver test suite is testing for behavior
  that the driver author I<thinks> the DBI specifies, but may be
  subtly incorrect.  These test suites are poorly maintained because
  the return on investment for a single driver is too low to provide
  sufficient incentive.
  
  A common test suite that can be reused by all the drivers is needed.
  It would:
  
  * Improve the quality of the DBI and drivers.
  
  * Ensure all drivers conform to the DBI specification.  Easing the
  porting of applications between databases, and the implementation
  of database independent modules layered over the DBI.
  
  * Improve the DBI specification by clarifying unclear issues in
  order to implement test cases.
  
  * Encourage expansion of the test suite as driver authors and others
  will be motivated by the greater benefits of their contributions.
  
  * Detect and record optional functionality that a driver has not
  yet implemented.
  
  * Improve the testing of DBI subclassing, DBI::PurePerl and the
  various "transparent" drivers, such as DBD::Proxy and DBD::Multiplex,
  by automatically running the test suite through them.
  
  These changes would improve the quality of all applications using
  the DBI.
  
  
  =head2 High Availability and Load Balancing
  
  * The DBD::Multiplex driver provides a framework to enable a wide
  range of dynamic functionality, including support for high-availability,
  failover, load-balancing, caching, and access to distributed data.
  It is currently being enhanced but development has stalled.
  
  * The DBD::Proxy module is complex and relatively inefficient because
  it's trying to be a complete proxy for most DBI method calls.  For
  many applications a simpler proxy architecture that operates with
  a single round-trip to the server would be simpler, faster, and more
  flexible.
  
  New proxy client and server classes are needed, which could be
  subclassed to support specific client to server transport mechanisms
  (such as HTTP and Spread::Queue).  Apart from the efficiency gains,
  this would also enable the use of a load-balanced pool of stateless
  servers for greater scalability and reliability.
  
  * The DBI currently offers no support for distributed transactions.
  The most useful elements of the standard XA distributed transaction
  interface standard could be included in the DBI specification.
  Drivers for databases which support distributed transactions could
  then be extended to support it.
  
  These changes would enable new kinds of DBI applications for critical
  environments.
  
  
  =head2 Unicode
  
  Use of Unicode with the DBI is growing rapidly. The DBI should do
  more to help drivers support Unicode and help applications work
  with drivers that don't yet support Unicode directly.
  
  * Define expected behavior for fetching data and binding parameters.
  
  * Provide interfaces to support Unicode issues for XS and pure Perl
  drivers and applications.
  
  * Provide functions for applications to help diagnose inconsistencies
  between byte string contents and setting of the SvUTF8 flag.
  
  These changes would smooth the transition to Unicode for many
  applications and drivers.
  
  
  =head2 Batch Statements
  
  Batch statements are a sequence of SQL statements, or a stored
  procedure containing a sequence of SQL statements, which can be
  executed as a whole.
  
  Currently the DBI has no standard interface for dealing with multiple
  results from batch statements.  After considerable discussion, an
  interface design has been agreed upon with driver authors, but has
  not yet been implemented.
  
  These changes would enable greater application portability between
  databases, and greater performance for databases that directly
  support batch statements.
  
  
  =head2 Introspection
  
  * The methods of the DBI API are installed dynamically when the DBI
  is loaded.  The data structure used to define the methods and their
  dispatch behavior should be made part of the DBI API. This would
  enable more flexible and correct behavior by modules subclassing
  the DBI and by dynamic drivers such as DBD::Proxy and DBD::Multiplex.
  
  * Handle attribute information should also be made available, for
  the same reasons.
  
  * Currently is it not possible to discover all the child statement
  handles that belong to a database handle (or all database handles
  that belong to a driver handle).  This makes certain tasks more
  difficult, especially some debugging scenarios.  A cache of weak
  references to child handles would solve the problem without creating
  reference loops.
  
  * It is often useful to know which handle attributes have been
  changed since the handle was created (e.g., in mod_perl where a
  handle needs to be reset or cloned). This will become more important
  as developers start exploring use of the newly added
  $h1->swap_inner_handle($h2) method.
  
  These changes would simplify and improve the stability of many
  advanced uses of the DBI.
  
  
  =head2 Extensibility
  
  The DBI can be extended in three main dimensions: subclassing the
  DBI, subclassing a driver, and callback hooks. Each has different
  pros and cons, each is applicable in different situations, and
  all need enhancing.
  
  * Subclassing the DBI is functional but not well defined and some
  key elements are incomplete, particularly the DbTypeSubclass mechanism
  (that automatically subclasses to a class tree according to the
  type of database being used).  It also needs more thorough testing.
  
  * Subclassing a driver is undocumented, poorly tested and very
  probably incomplete. However it's a powerful way to embed certain
  kinds of functionality 'below' applications while avoiding some of
  the side-effects of subclassing the DBI (especially in relation to
  error handling).
  
  * Callbacks are currently limited to error handling (the HandleError
  and HandleSetError attributes).  Providing callback hooks for more
  events, such as a row being fetched, would enable utility modules,
  for example, to modify the behavior of a handle independent of any
  subclassing in use.
  
  These changes would enable cleaner and more powerful integration
  between applications, layered modules, and the DBI.
  
  
  =head2 Debugability
  
  * Enabling DBI trace output at a high level of detail causes a large
  volume of output, much of it probably unrelated to the problem being
  investigated. Trace output should be controlled by the new named-topic
  mechanism instead of just the trace level.
  
  * Calls to XS functions (such as many DBI and driver methods) don't
  normally appear in the call stack.  Optionally enabling that would
  enable more useful diagnostics to be produced.
  
  * Integration with the Perl debugger would make it simpler to perform
  actions on a per-handle basis (such as breakpoint on execute,
  breakpoint on error).
  
  These changes would enable more rapid application development and
  fault finding.
  
  
  =head2 Database Portability
  
  * The DBI has not yet addressed the issue of portability among SQL
  dialects.  This is the main hurdle limiting database portability
  for DBI applications.
  
  The goal is I<not> to fully parse the SQL and rewrite it in a
  different dialect.  That's well beyond the scope of the DBI and
  should be left to layered modules.  A simple token rewriting mechanism
  for five comment styles, two quoting styles, four placeholder styles,
  plus the ODBC "{foo ...}" escape syntax, is sufficient to significantly
  raise the level of SQL portability.
  
  * Another problem area is date/time formatting.  Since version 1.41
  the DBI has defined a way to express that dates should be fetched
  in SQL standard date format (YYYY-MM-DD).  This is one example of
  the more general case where bind_col() needs to be called with
  particular attributes on all columns of a particular type.
  
  A mechanism is needed whereby an application can specify default
  bind_col() attributes to be applied automatically for each column
  type. With a single step, all DATE type columns, for example, can
  be set to be returned in the standard format.
  
  These changes would enable greater database portability for
  applications and greater functionality for layered modules.
  
  
  =head2 Intellectual Property
  
  * Clarify current intellectual property status, including a review
    of past contributions to ensure the DBI is unemcumbered.
  
  * Establish a procedure for vetting future contributions for any
    intellectual property issues.
  
  These changes are important for companies taking a formal approach
  to assessing their risks in using Open Source software.
  
  
  =head2 Other Enhancements
  
  * Reduce the work needed to create new database interface drivers.
  
  * Definition of an interface to support scrollable cursors.
  
  
  =head2 Parrot and Perl 6
  
  The current DBI implementation in C code is unlikely to run on Perl 6.
  Perl 6 will target the Parrot virtual machine and so the internal
  architecture will be radically different from Perl 5.
  
  One of the goals of the Parrot project is to be a platform for many
  dynamic languages (including Python, PHP, Ruby, etc) and to enable
  those languages to reuse each others modules. A database interface
  for Parrot is also a database interface for any and all languages
  that run on Parrot.
  
  The Perl DBI would make an excellent base for a Parrot database
  interface because it has more functionality, and is more mature and
  extensible, than the database interfaces of the other dynamic
  languages.
  
  I plan to better define the API between the DBI and the drivers and
  use that API as the primary API for the 'raw' Parrot database
  interface.  This project is known a Parrot DBDI (for "DataBase
  Driver Interface").  The announcement can be read in
  <http://groups.google.com/groups?selm=20040127225639.GF38394@dansat.data-plan.com>
  
  The bulk of the work will be translating the DBI C and Perl base
  class code into Parrot PIR, or a suitable language that generates
  PIR.  The project stalled, due to Parrot not having key functionality
  at the time.  That has been resolved but the project has not yet
  restarted.
  
  Each language targeting Parrot would implement their own small
  'thin' language-specific method dispatcher (a "Perl6 DBI", "Python
  DBI", "PHP DBI" etc) layered over the common Parrot DBDI interface
  and drivers.
  
  The major benefit of the DBDI project is that a much wider community
  of developers share the same database drivers. There would be more
  developers maintaining less code so the benefits of the Open Source
  model are magnified.
  
  
  =head1 PRIORITIES
  
  =head2 Transition Drivers
  
  The first priority is to make all the infrastructure changes that
  impact drivers and make an alpha release available for driver authors.
  
  As far as possible, the changes will be implemented in a way that
  enables driver authors use the same code base for DBI v1 and DBI v2.
  
  The main changes required by driver authors are:
  
  * Code changes for PERL_NO_GET_CONTEXT, plus removing PERL_POLLUTE
  and DBIS
  
  * Code changes in DBI/DBD interface (new way to create handles, new
  callbacks etc)
  
  * Common test suite infrastructure (driver-specific test base class)
  
  =head2 Transition Applications
  
  A small set of incompatible changes that may impact some applications
  will also be made in v2.0. See http://svn.perl.org/modules/dbi/trunk/ToDo
  
  =head2 Incremental Developments
  
  Once DBI v2.0 is available, the other enhancements can be implemented
  incrementally on the updated foundations. Priorities for those
  changes have not been set.
  
  =head2 DBI v1 
  
  DBI v1 will continue to be maintained on a separate branch for
  bug fixes and any enhancements that ease the transition to DBI v2.
  
  =head1 RESOURCES AND CONTRIBUTIONS
  
  See L<http://dbi.perl.org/contributing> for I<how you can help>.
  
  If your company has benefited from the DBI, please consider if
  it could make a donation to The Perl Foundation "DBI Development"
  fund at L<http://dbi.perl.org/donate> to secure future development.
  
  Alternatively, if your company would benefit from a specific new
  DBI feature, please consider sponsoring its development through my
  consulting company, Data Plan Services. Work is performed rapidly
  on a fixed-price payment-on-delivery basis. Contact me for details.
  
  Using such targeted financing allows you to contribute to DBI
  development and rapidly get something specific and directly valuable
  to you in return.
  
  My company also offers annual support contracts for the DBI, which
  provide another way to support the DBI and get something specific
  in return. Contact me for details.
  
  Thank you.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_DBI_ROADMAP

$fatpacked{"darwin-thread-multi-2level/DBI/SQL/Nano.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_SQL_NANO';
  #######################################################################
  #
  #  DBI::SQL::Nano - a very tiny SQL engine
  #
  #  Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
  #
  #  All rights reserved.
  #
  #  You may freely distribute and/or modify this  module under the terms
  #  of either the GNU  General Public License (GPL) or the Artistic License,
  #  as specified in the Perl README file.
  #
  #  See the pod at the bottom of this file for help information
  #
  #######################################################################
  
  #######################
  package DBI::SQL::Nano;
  #######################
  use strict;
  use warnings;
  require DBI; # for looks_like_number()
  use vars qw( $VERSION $versions );
  BEGIN {
      $VERSION = sprintf("1.%06d", q$Revision: 9744 $ =~ /(\d+)/o);
  
      $versions->{nano_version} = $VERSION;
      if ($ENV{DBI_SQL_NANO} || !eval { require "SQL/Statement.pm" }) {
          @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
          @DBI::SQL::Nano::Table::ISA     = qw(DBI::SQL::Nano::Table_);
      }
      else {
          @DBI::SQL::Nano::Statement::ISA = qw( SQL::Statement );
          @DBI::SQL::Nano::Table::ISA     = qw( SQL::Eval::Table);
          $versions->{statement_version}  = $SQL::Statement::VERSION;
      }
  }
  
  ###################################
  package DBI::SQL::Nano::Statement_;
  ###################################
  
  sub new {
      my($class,$sql) = @_;
      my $self = {};
      bless $self, $class;
      return $self->prepare($sql);
  }
  
  #####################################################################
  # PREPARE
  #####################################################################
  sub prepare {
      my($self,$sql) = @_;
      $sql =~ s/\s+$//;
      for ($sql) {
          /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is
              &&do{
                  $self->{command}      = 'CREATE';
                  $self->{table_name}   = $1;
                  $self->{column_names} = parse_coldef_list($2) if $2;
                  die "Can't find columns\n" unless $self->{column_names};
              };
          /^\s*DROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.*?)\s*$/is
              &&do{
                  $self->{command}      = 'DROP';
                  $self->{table_name}   = $2;
                  $self->{ignore_missing_table} = 1 if $1;
              };
          /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is
              &&do{
                  $self->{command}      = 'SELECT';
                  $self->{column_names} = parse_comma_list($1) if $1;
                  die "Can't find columns\n" unless $self->{column_names};
                  $self->{table_name}   = $2;
                  if ( my $clauses = $4) {
  		    if ($clauses =~ /^(.*)\s+ORDER\s+BY\s+(.*)$/is) {
                          $clauses = $1;
                          $self->{order_clause} = $self->parse_order_clause($2);
  		    }
                      $self->{where_clause}=$self->parse_where_clause($clauses)
                          if $clauses;
  		}
              };
          /^\s*INSERT\s+INTO\s+(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
              &&do{
                  $self->{command}      = 'INSERT';
                  $self->{table_name}   = $1;
                  $self->{column_names} = parse_comma_list($2) if $2;
                  $self->{values}       = $self->parse_values_list($4) if $4;
                  die "Can't parse values\n" unless $self->{values};
              };
          /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is
              &&do{
                  $self->{command}      = 'DELETE';
                  $self->{table_name}   = $1;
                  $self->{where_clause} = $self->parse_where_clause($3) if $3;
              };
          /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is
              &&do{
                  $self->{command}      = 'UPDATE';
                  $self->{table_name}   = $1;
                  $self->parse_set_clause($2) if $2;
                  $self->{where_clause} = $self->parse_where_clause($3) if $3;
              };
      }
      die "Couldn't parse\n"
  	unless $self->{command} and $self->{table_name};
      return $self;
  }
  sub parse_order_clause {
      my($self,$str) = @_;
      my @clause = split /\s+/,$str;
      return { $clause[0] => 'ASC' } if @clause == 1;
      die "Bad ORDER BY clause '$str'\n" if @clause > 2;
      $clause[1] ||= '';
      return { $clause[0] => uc $clause[1] } if $clause[1] =~ /^ASC$/i
                                             or $clause[1] =~ /^DESC$/i;
      die "Bad ORDER BY clause '$clause[1]'\n";
  }
  sub parse_coldef_list  {                # check column definitions
      my @col_defs;
      for ( split',',shift ) {
          my $col = clean_parse_str($_);
          if ( $col =~ /^(\S+?)\s+.+/ ) { # doesn't check what it is
              $col = $1;                  # just checks if it exists
  	}
          else {
   	    die "No column definition for '$_'\n";
  	}
          push @col_defs,$col;
      }
      return \@col_defs;
  }
  sub parse_comma_list  {[map{clean_parse_str($_)} split(',',shift)]}
  sub clean_parse_str { local $_ = shift; s/\(//;s/\)//;s/^\s+//; s/\s+$//; $_; }
  sub parse_values_list {
      my($self,$str) = @_;
      [map{$self->parse_value(clean_parse_str($_))}split(',',$str)]
  }
  sub parse_set_clause {
      my $self = shift;
      my @cols = split /,/, shift;
      my $set_clause;
      for my $col(@cols) {
          my($col_name,$value)= $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s;
          push @{$self->{column_names}}, $col_name;
          push @{$self->{values}}, $self->parse_value($value);
      }
      die "Can't parse set clause\n"
          unless $self->{column_names}
             and $self->{values};
  }
  sub parse_value {
      my($self,$str) = @_;
      return undef unless defined $str;
      $str =~ s/\s+$//;
      $str =~ s/^\s+//;
      if ($str =~ /^\?$/) {
          push @{$self->{params}},'?';
          return { value=>'?'  ,type=> 'placeholder' };
      }
      return { value=>undef,type=> 'NULL'   } if $str =~ /^NULL$/i;
      return { value=>$1   ,type=> 'string' } if $str =~ /^'(.+)'$/s;
      return { value=>$str ,type=> 'number' } if DBI::looks_like_number($str);
      return { value=>$str ,type=> 'column' };
  }
  sub parse_where_clause {
      my($self,$str) = @_;
      $str =~ s/\s+$//;
      if ($str =~ /^\s*WHERE\s+(.*)/i) {
          $str = $1;
      }
      else {
          die "Couldn't find WHERE clause in '$str'\n";
      }
      my($neg) = $str =~ s/^\s*(NOT)\s+//is;
      my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS';
      my($val1,$op,$val2) = $str =~ /^(.+?)\s*($opexp)\s*(.+)\s*$/iso;
      die "Couldn't parse WHERE expression '$str'\n"
         unless defined $val1 and defined $op and defined $val2;
      return {
          arg1 => $self->parse_value($val1),
          arg2 => $self->parse_value($val2),
          op   => $op,
          neg  => $neg,
      }
  }
  
  #####################################################################
  # EXECUTE
  #####################################################################
  sub execute {
      my($self, $data, $params) = @_;
      my $num_placeholders = $self->params;
      my $num_params       = scalar @$params || 0;
      die "Number of params '$num_params' does not match "
        . "number of placeholders '$num_placeholders'\n"
        unless $num_placeholders == $num_params;
      if (scalar @$params) {
          for my $i(0..$#{$self->{values}}) {
              if ($self->{values}->[$i]->{type} eq 'placeholder') {
                  $self->{values}->[$i]->{value} = shift @$params;
              }
          }
          if ($self->{where_clause}) {
              if ($self->{where_clause}->{arg1}->{type} eq 'placeholder') {
                  $self->{where_clause}->{arg1}->{value} = shift @$params;
              }
              if ($self->{where_clause}->{arg2}->{type} eq 'placeholder') {
                  $self->{where_clause}->{arg2}->{value} = shift @$params;
              }
          }
      }
      my $command = $self->{command};
      ( $self->{'NUM_OF_ROWS'},
        $self->{'NUM_OF_FIELDS'},
        $self->{'data'},
      ) = $self->$command($data, $params);
      $self->{NAME} ||= $self->{column_names};
      $self->{'NUM_OF_ROWS'} || '0E0';
  }
  sub DROP ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 0, 0);
      $table->drop($data);
      (-1, 0);
  }
  sub CREATE ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 1, 1);
      $table->push_names($data, $self->{column_names});
      (0, 0);
  }
  sub INSERT ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 0, 1);
      $self->verify_columns($table);
      $table->seek($data, 0, 2);
      my($array) = [];
      my($val, $col, $i);
      $self->{column_names}=$table->{col_names} unless $self->{column_names};
      my $cNum = scalar(@{$self->{column_names}}) if $self->{column_names};
      my $param_num = 0;
      if ($cNum) {
          for ($i = 0;  $i < $cNum;  $i++) {
              $col = $self->{column_names}->[$i];
              $array->[$self->column_nums($table,$col)] = $self->row_values($i);
          }
      } else {
          die "Bad col names in INSERT";
      }
      $table->push_row($data, $array);
      (1, 0);
  }
  sub DELETE ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 0, 1);
      $self->verify_columns($table);
      my($affected) = 0;
      my(@rows, $array);
      if ( $table->can('delete_one_row') ) {
          while (my $array = $table->fetch_row($data)) {
              if ($self->eval_where($table,$array)) {
                  ++$affected;
                  $array = $self->{fetched_value} if $self->{fetched_from_key};
                  $table->delete_one_row($data,$array);
                  return ($affected, 0) if $self->{fetched_from_key};
              }
          }
          return ($affected, 0);
      }
      while ($array = $table->fetch_row($data)) {
          if ($self->eval_where($table,$array)) {
              ++$affected;
          } else {
              push(@rows, $array);
          }
      }
      $table->seek($data, 0, 0);
      foreach $array (@rows) {
          $table->push_row($data, $array);
      }
      $table->truncate($data);
      return ($affected, 0);
  }
  sub SELECT ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 0, 0);
      $self->verify_columns($table);
      my $tname = $self->{table_name};
      my($affected) = 0;
      my(@rows, $array, $val, $col, $i);
      while ($array = $table->fetch_row($data)) {
          if ($self->eval_where($table,$array)) {
              $array = $self->{fetched_value} if $self->{fetched_from_key};
              my $col_nums = $self->column_nums($table);
              my %cols   = reverse %{ $col_nums };
              my $rowhash;
              for (sort keys %cols) {
                  $rowhash->{$cols{$_}} = $array->[$_];
              }
              my @newarray;
              for ($i = 0;  $i < @{$self->{column_names}};  $i++) {
                 $col = $self->{column_names}->[$i];
                 push @newarray,$rowhash->{$col};
              }
              push(@rows, \@newarray);
              return (scalar(@rows),scalar @{$self->{column_names}},\@rows)
   	        if $self->{fetched_from_key};
          }
      }
      if ( $self->{order_clause} ) {
          my( $sort_col, $desc ) = each %{$self->{order_clause}};
          undef $desc unless $desc eq 'DESC';
          my @sortCols = ( $self->column_nums($table,$sort_col,1) );
          my($c, $d, $colNum);
          my $sortFunc = sub {
              my $result;
              $i = 0;
              do {
                  $colNum = $sortCols[$i++];
                  # $desc = $sortCols[$i++];
                  $c = $a->[$colNum];
                  $d = $b->[$colNum];
                  if (!defined($c)) {
                      $result = defined $d ? -1 : 0;
                  } elsif (!defined($d)) {
                      $result = 1;
  	        } elsif ( DBI::looks_like_number($c) && DBI::looks_like_number($d) ) {
                      $result = ($c <=> $d);
                  } else {
    		    if ($self->{"case_fold"}) {
                          $result = lc $c cmp lc $d || $c cmp $d;
  		    }
                      else {
                          $result = $c cmp $d;
  		    }
                  }
                  if ($desc) {
                      $result = -$result;
                  }
              } while (!$result  &&  $i < @sortCols);
              $result;
          };
          @rows = (sort $sortFunc @rows);
      }
      (scalar(@rows), scalar @{$self->{column_names}}, \@rows);
  }
  sub UPDATE ($$$) {
      my($self, $data, $params) = @_;
      my $table = $self->open_tables($data, 0, 1);
      $self->verify_columns($table);
      return undef unless $table;
      my($affected) = 0;
      my(@rows, $array, $f_array, $val, $col, $i);
      while ($array = $table->fetch_row($data)) {
          if ($self->eval_where($table,$array)) {
              $array = $self->{fetched_value} if $self->{fetched_from_key}
                                               and $table->can('update_one_row');
              my $col_nums = $self->column_nums($table);
              my %cols   = reverse %{ $col_nums };
              my $rowhash;
              for (sort keys %cols) {
                  $rowhash->{$cols{$_}} = $array->[$_];
              }
              for ($i = 0;  $i < @{$self->{column_names}};  $i++) {
                 $col = $self->{column_names}->[$i];
                 $array->[$self->column_nums($table,$col)]=$self->row_values($i);
              }
              $affected++;
              if ($self->{fetched_from_key}){
                  $table->update_one_row($data,$array);
                  return ($affected, 0);
  	    }
              push(@rows, $array);
  	}
          else {
              push(@rows, $array);
          }
      }
      $table->seek($data, 0, 0);
      foreach my $array (@rows) {
          $table->push_row($data, $array);
      }
      $table->truncate($data);
      ($affected, 0);
  }
  sub verify_columns {
     my($self,$table) = @_;
     my @cols = @{$self->{column_names}};
     if ($self->{where_clause}) {
        if (my $col = $self->{where_clause}->{arg1}) {
            push @cols, $col->{value} if $col->{type} eq 'column';
        }
        if (my $col = $self->{where_clause}->{arg2}) {
            push @cols, $col->{value} if $col->{type} eq 'column';
        }
     }
     for (@cols) {
         $self->column_nums($table,$_);
     }
  }
  sub column_nums {
      my($self,$table,$stmt_col_name,$find_in_stmt)=@_;
      my %dbd_nums = %{ $table->{col_nums} };
      my @dbd_cols = @{ $table->{col_names} };
      my %stmt_nums;
      if ($stmt_col_name and !$find_in_stmt) {
          while(my($k,$v)=each %dbd_nums) {
              return $v if uc $k eq uc $stmt_col_name;
          }
          die "No such column '$stmt_col_name'\n";
      }
      if ($stmt_col_name and $find_in_stmt) {
          for my $i(0..@{$self->{column_names}}) {
              return $i if uc $stmt_col_name eq uc $self->{column_names}->[$i];
          }
          die "No such column '$stmt_col_name'\n";
      }
      for my $i(0 .. $#dbd_cols) {
          for my $stmt_col(@{$self->{column_names}}) {
              $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col;
          }
      }
      return \%stmt_nums;
  }
  sub eval_where {
      my $self   = shift;
      my $table  = shift;
      my $rowary = shift;
      my $where = $self->{"where_clause"} || return 1;
      my $col_nums = $table->{"col_nums"} ;
      my %cols   = reverse %{ $col_nums };
      my $rowhash;
      for (sort keys %cols) {
          $rowhash->{uc $cols{$_}} = $rowary->[$_];
      }
      return $self->process_predicate($where,$table,$rowhash);
  }
  sub process_predicate {
      my($self,$pred,$table,$rowhash) = @_;
      my $val1 = $pred->{arg1};
      if ($val1->{type} eq 'column') {
          $val1 = $rowhash->{ uc $val1->{value}};
      }
      else {
          $val1 = $val1->{value};
      }
      my $val2 = $pred->{arg2};
      if ($val2->{type}eq 'column') {
          $val2 = $rowhash->{uc $val2->{value}};
      }
      else {
          $val2 = $val2->{value};
      }
      my $op   = $pred->{op};
      my $neg  = $pred->{neg};
      my $match;
      if ( $op eq '=' and !$neg and $table->can('fetch_one_row')
         ) {
          my $key_col = $table->fetch_one_row(1,1);
          if ($pred->{arg1}->{value} =~ /^$key_col$/i) {
              $self->{fetched_from_key}=1;
              $self->{fetched_value} = $table->fetch_one_row(
                  0,$pred->{arg2}->{value}
              );
              return 1;
  	}
      }
      $match = $self->is_matched($val1,$op,$val2) || 0;
      if ($neg) { $match = $match ? 0 : 1; }
      return $match;
  }
  sub is_matched {
      my($self,$val1,$op,$val2)=@_;
      if ($op eq 'IS') {
          return 1 if (!defined $val1 or $val1 eq '');
          return 0;
      }
      $val1 = '' unless defined $val1;
      $val2 = '' unless defined $val2;
      if ($op =~ /LIKE|CLIKE/i) {
          $val2 = quotemeta($val2);
          $val2 =~ s/\\%/.*/g;
          $val2 =~ s/_/./g;
      }
      if ($op eq 'LIKE' )  { return $val1 =~ /^$val2$/s;  }
      if ($op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
      if ( DBI::looks_like_number($val1) && DBI::looks_like_number($val2) ) {
          if ($op eq '<'  ) { return $val1 <  $val2; }
          if ($op eq '>'  ) { return $val1 >  $val2; }
          if ($op eq '='  ) { return $val1 == $val2; }
          if ($op eq '<>' ) { return $val1 != $val2; }
          if ($op eq '<=' ) { return $val1 <= $val2; }
          if ($op eq '>=' ) { return $val1 >= $val2; }
      }
      else {
          if ($op eq '<'  ) { return $val1 lt $val2; }
          if ($op eq '>'  ) { return $val1 gt $val2; }
          if ($op eq '='  ) { return $val1 eq $val2; }
          if ($op eq '<>' ) { return $val1 ne $val2; }
          if ($op eq '<=' ) { return $val1 ge $val2; }
          if ($op eq '>=' ) { return $val1 le $val2; }
      }
  }
  sub params {
      my $self = shift;
      my $val_num = shift;
      if (!$self->{"params"}) { return 0; }
      if (defined $val_num) {
          return $self->{"params"}->[$val_num];
      }
      if (wantarray) {
          return @{$self->{"params"}};
      }
      else {
          return scalar @{ $self->{"params"} };
      }
  
  }
  sub open_tables {
      my($self, $data, $createMode, $lockMode) = @_;
      my $table_name = $self->{table_name};
      my $table;
      eval{$table = $self->open_table($data,$table_name,$createMode,$lockMode)};
      die $@ if $@;
      die "Couldn't open table '$table_name'" unless $table;
      if (!$self->{column_names} or $self->{column_names}->[0] eq '*') {
          $self->{column_names} = $table->{col_names};
      }
      return $table;
  }
  sub row_values {
      my $self = shift;
      my $val_num = shift;
      if (!$self->{"values"}) { return 0; }
      if (defined $val_num) {
          return $self->{"values"}->[$val_num]->{value};
      }
      if (wantarray) {
          return map{$_->{"value"} } @{$self->{"values"}};
      }
      else {
          return scalar @{ $self->{"values"} };
      }
  }
  
  ###############################
  package DBI::SQL::Nano::Table_;
  ###############################
  sub new ($$) {
      my($proto, $attr) = @_;
      my($self) = { %$attr };
      bless($self, (ref($proto) || $proto));
      $self;
  }
  
  1;
  __END__
  
  =pod
  
  =head1 NAME
  
  DBI::SQL::Nano - a very tiny SQL engine
  
  =head1 SYNOPSIS
  
   BEGIN { $ENV{DBI_SQL_NANO}=1 } # forces use of Nano rather than SQL::Statement
   use DBI::SQL::Nano;
   use Data::Dumper;
   my $stmt = DBI::SQL::Nano::Statement->new(
       "SELECT bar,baz FROM foo WHERE qux = 1"
   ) or die "Couldn't parse";
   print Dumper $stmt;
  
  =head1 DESCRIPTION
  
  DBI::SQL::Nano is meant as a *very* minimal SQL engine for use in situations where SQL::Statement is not available.  In most situations you are better off installing SQL::Statement although DBI::SQL::Nano may be faster for some very simple tasks.
  
  DBI::SQL::Nano, like SQL::Statement is primarily intended to provide a SQL engine for use with some pure perl DBDs including DBD::DBM, DBD::CSV, DBD::AnyData, and DBD::Excel.  It isn't of much use in and of itself.  You can dump out the structure of a parsed SQL statement, but that's about it.
  
  =head1 USAGE
  
  =head2 Setting the DBI_SQL_NANO flag
  
  By default, when a DBD uses DBI::SQL::Nano, the module will look to see if SQL::Statement is installed.  If it is, SQL::Statement objects are used.  If SQL::Statement is not available, DBI::SQL::Nano objects are used.
  
  In some cases, you may wish to use DBI::SQL::Nano objects even if SQL::Statement is available.  To force usage of DBI::SQL::Nano objects regardless of the availability of SQL::Statement, set the environment variable DBI_SQL_NANO to 1.
  
  You can set the environment variable in your shell prior to running your script (with SET or EXPORT or whatever), or else you can set it in your script by putting this at the top of the script:
  
   BEGIN { $ENV{DBI_SQL_NANO} = 1 }
  
  =head2 Supported SQL syntax
  
   Here's a pseudo-BNF.  Square brackets [] indicate optional items;
   Angle brackets <> indicate items defined elsewhere in the BNF.
  
    statement ::=
        DROP TABLE [IF EXISTS] <table_name>
      | CREATE TABLE <table_name> <col_def_list>
      | INSERT INTO <table_name> [<insert_col_list>] VALUES <val_list>
      | DELETE FROM <table_name> [<where_clause>]
      | UPDATE <table_name> SET <set_clause> <where_clause>
      | SELECT <select_col_list> FROM <table_name> [<where_clause>]
                                                   [<order_clause>]
  
    the optional IF EXISTS clause ::=
      * similar to MySQL - prevents errors when trying to drop
        a table that doesn't exist
  
    identifiers ::=
      * table and column names should be valid SQL identifiers
      * especially avoid using spaces and commas in identifiers
      * note: there is no error checking for invalid names, some
        will be accepted, others will cause parse failures
  
    table_name ::=
      * only one table (no multiple table operations)
      * see identifier for valid table names
  
    col_def_list ::=
      * a parens delimited, comma-separated list of column names
      * see identifier for valid column names
      * column types and column constraints may be included but are ignored
        e.g. these are all the same:
          (id,phrase)
          (id INT, phrase VARCHAR(40))
          (id INT PRIMARY KEY, phrase VARCHAR(40) NOT NULL)
      * you are *strongly* advised to put in column types even though
        they are ignored ... it increases portability
  
    insert_col_list ::=
      * a parens delimited, comma-separated list of column names
      * as in standard SQL, this is optional
  
    select_col_list ::=
      * a comma-separated list of column names
      * or an asterisk denoting all columns
  
    val_list ::=
      * a parens delimited, comma-separated list of values which can be:
         * placeholders (an unquoted question mark)
         * numbers (unquoted numbers)
         * column names (unquoted strings)
         * nulls (unquoted word NULL)
         * strings (delimited with single quote marks);
         * note: leading and trailing percent mark (%) and underscore (_)
           can be used as wildcards in quoted strings for use with
           the LIKE and CLIKE operators
         * note: escaped single quote marks within strings are not
           supported, neither are embedded commas, use placeholders instead
  
    set_clause ::=
      * a comma-separated list of column = value pairs
      * see val_list for acceptable value formats
  
    where_clause ::=
      * a single "column/value <op> column/value" predicate, optionally
        preceded by "NOT"
      * note: multiple predicates combined with ORs or ANDs are not supported
      * see val_list for acceptable value formats
      * op may be one of:
           < > >= <= = <> LIKE CLIKE IS
      * CLIKE is a case insensitive LIKE
  
    order_clause ::= column_name [ASC|DESC]
      * a single column optional ORDER BY clause is supported
      * as in standard SQL, if neither ASC (ascending) nor
        DESC (descending) is specified, ASC becomes the default
  
  =head1 ACKNOWLEDGEMENTS
  
  Tim Bunce provided the original idea for this module, helped me out of the tangled trap of namespace, and provided help and advice all along the way.  Although I wrote it from the ground up, it is based on Jochen Weidmann's orignal design of SQL::Statement, so much of the credit for the API goes to him.
  
  =head1 AUTHOR AND COPYRIGHT
  
  This module is written and maintained by
  
  Jeff Zucker < jzucker AT cpan.org >
  
  Copyright (C) 2004 by Jeff Zucker, all rights reserved.
  
  You may freely distribute and/or modify this module under the terms of either the GNU General Public License (GPL) or the Artistic License, as specified in
  the Perl README file.
  
  =cut
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_DBI_SQL_NANO

$fatpacked{"darwin-thread-multi-2level/DBI/Util/CacheMemory.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_UTIL_CACHEMEMORY';
  package DBI::Util::CacheMemory;
  
  #   $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z timbo $
  #
  #   Copyright (c) 2007, Tim Bunce, Ireland
  #
  #   You may distribute under the terms of either the GNU General Public
  #   License or the Artistic License, as specified in the Perl README file.
  
  use strict;
  use warnings;
  
  =head1 NAME
  
  DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory
  
  =head1 DESCRIPTION
  
  Like Cache::Memory (part of the Cache distribution) but doesn't support any fancy features.
  
  This module aims to be a very fast compatible strict sub-set for simple cases,
  such as basic client-side caching for DBD::Gofer.
  
  Like Cache::Memory, and other caches in the Cache and Cache::Cache
  distributions, the data will remain in the cache until cleared, it expires,
  or the process dies. The cache object simply going out of scope will I<not>
  destroy the data.
  
  =head1 METHODS WITH CHANGES
  
  =head2 new
  
  All options except C<namespace> are ignored.
  
  =head2 set
  
  Doesn't support expiry.
  
  =head2 purge
  
  Same as clear() - deletes everything in the namespace.
  
  =head1 METHODS WITHOUT CHANGES
  
  =over
  
  =item clear
  
  =item count
  
  =item exists
  
  =item remove
  
  =back
  
  =head1 UNSUPPORTED METHODS
  
  If it's not listed above, it's not supported.
  
  =cut
  
  our $VERSION = sprintf("0.%06d", q$Revision: 10314 $ =~ /(\d+)/o);
  
  my %cache;
  
  sub new {
      my ($class, %options ) = @_;
      my $namespace = $options{namespace} ||= 'Default';
      #$options{_cache} = \%cache; # can be handy for debugging/dumping
      my $self =  bless \%options => $class;
      $cache{ $namespace } ||= {}; # init - ensure it exists
      return $self;
  }
  
  sub set {
      my ($self, $key, $value) = @_;
      $cache{ $self->{namespace} }->{$key} = $value;
  }
  
  sub get {
      my ($self, $key) = @_;
      return $cache{ $self->{namespace} }->{$key};
  }
  
  sub exists {
      my ($self, $key) = @_;
      return exists $cache{ $self->{namespace} }->{$key};
  }
  
  sub remove {
      my ($self, $key) = @_;
      return delete $cache{ $self->{namespace} }->{$key};
  }
  
  sub purge {
      return shift->clear;
  }
  
  sub clear {
      $cache{ shift->{namespace} } = {};
  }
  
  sub count {
      return scalar keys %{ $cache{ shift->{namespace} } };
  }
  
  sub size {
      my $c = $cache{ shift->{namespace} };
      my $size = 0;
      while ( my ($k,$v) = each %$c ) {
          $size += length($k) + length($v);
      }
      return $size;
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_UTIL_CACHEMEMORY

$fatpacked{"darwin-thread-multi-2level/DBI/Util/_accessor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_UTIL__ACCESSOR';
  package DBI::Util::_accessor;
  use strict;
  use Carp;
  our $VERSION = sprintf("0.%06d", q$Revision: 9478 $ =~ /(\d+)/);
  
  # inspired by Class::Accessor::Fast
  
  sub new {
      my($proto, $fields) = @_;
      my($class) = ref $proto || $proto;
      $fields ||= {};
  
      my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields;
      carp "$class doesn't have accessors for fields: @dubious" if @dubious;
  
      # make a (shallow) copy of $fields.
      bless {%$fields}, $class;
  }
  
  sub mk_accessors {
      my($self, @fields) = @_;
      $self->mk_accessors_using('make_accessor', @fields);
  }
  
  sub mk_accessors_using {
      my($self, $maker, @fields) = @_;
      my $class = ref $self || $self;
  
      # So we don't have to do lots of lookups inside the loop.
      $maker = $self->can($maker) unless ref $maker;
  
      no strict 'refs';
      foreach my $field (@fields) {
          my $accessor = $self->$maker($field);
          *{$class."\:\:$field"} = $accessor
              unless defined &{$class."\:\:$field"};
      }
      #my $hash_ref = \%{$class."\:\:_accessors_hash};
      #$hash_ref->{$_}++ for @fields;
      # XXX also copy down _accessors_hash of base class(es)
      # so one in this class is complete
      return;
  }
  
  sub make_accessor {
      my($class, $field) = @_;
      return sub {
          my $self = shift;
          return $self->{$field} unless @_;
          croak "Too many arguments to $field" if @_ > 1;
          return $self->{$field} = shift;
      };
  }
  
  sub make_accessor_autoviv_hashref {
      my($class, $field) = @_;
      return sub {
          my $self = shift;
          return $self->{$field} ||= {} unless @_;
          croak "Too many arguments to $field" if @_ > 1;
          return $self->{$field} = shift;
      };
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_UTIL__ACCESSOR

$fatpacked{"darwin-thread-multi-2level/DBI/W32ODBC.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DBI_W32ODBC';
  package
    DBI;	# hide this non-DBI package from simple indexers
  
  # $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z timbo $
  #
  # Copyright (c) 1997,1999 Tim Bunce
  # With many thanks to Patrick Hollins for polishing.
  #
  # You may distribute under the terms of either the GNU General Public
  # License or the Artistic License, as specified in the Perl README file.
  
  =head1 NAME
  
  DBI::W32ODBC - An experimental DBI emulation layer for Win32::ODBC
  
  =head1 SYNOPSIS
  
    use DBI::W32ODBC;
  
    # apart from the line above everything is just the same as with
    # the real DBI when using a basic driver with few features.
  
  =head1 DESCRIPTION
  
  This is an experimental pure perl DBI emulation layer for Win32::ODBC
  
  If you can improve this code I'd be interested in hearing about it. If
  you are having trouble using it please respect the fact that it's very
  experimental. Ideally fix it yourself and send me the details.
  
  =head2 Some Things Not Yet Implemented
  
  	Most attributes including PrintError & RaiseError.
  	type_info and table_info
  
  Volunteers welcome!
  
  =cut
  
  ${'DBI::VERSION'}	# hide version from PAUSE indexer
     = "0.01";
  
  my $Revision = sprintf("12.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
  
  
  sub DBI::W32ODBC::import { }	# must trick here since we're called DBI/W32ODBC.pm
  
  
  use Carp;
  
  use Win32::ODBC;
  
  @ISA = qw(Win32::ODBC);
  
  use strict;
  
  $DBI::dbi_debug = $ENV{PERL_DBI_DEBUG} || 0;
  carp "Loaded (W32ODBC) DBI.pm ${'DBI::VERSION'} (debug $DBI::dbi_debug)"
  	if $DBI::dbi_debug;
  
  
  
  sub connect {
      my ($class, $dbname, $dbuser, $dbpasswd, $module, $attr) = @_;
      $dbname .= ";UID=$dbuser"   if $dbuser;
      $dbname .= ";PWD=$dbpasswd" if $dbpasswd;
      my $h = new Win32::ODBC $dbname;
      warn "Error connecting to $dbname: ".Win32::ODBC::Error()."\n" unless $h;
      bless $h, $class if $h;	# rebless into our class
      $h;
  }
  
  
  sub quote {
      my ($h, $string) = @_;
      return "NULL" if !defined $string;
      $string =~ s/'/''/g;	# standard
      # This hack seems to be required for Access but probably breaks for
  	# other databases when using \r and \n. It would be better if we could
  	# use ODBC options to detect that we're actually using Access.
      $string =~ s/\r/' & chr\$(13) & '/g;
      $string =~ s/\n/' & chr\$(10) & '/g;
      "'$string'";
  }
  
  sub do {
      my($h, $statement, $attribs, @params) = @_;
      Carp::carp "\$h->do() attribs unused" if $attribs;
      my $new_h = $h->prepare($statement) or return undef;    ##
      pop @{ $h->{'___sths'} };                               ## certian death assured
      $new_h->execute(@params) or return undef;               ##
      my $rows = $new_h->rows;                                ##
      $new_h->finish;                                         ## bang bang
      ($rows == 0) ? "0E0" : $rows;
  }
  
  # ---
  
  sub prepare {
      my ($h, $sql) = @_;
  	## opens a new connection with every prepare to allow
  	## multiple, concurrent queries
  	my $new_h = new Win32::ODBC $h->{DSN};	##
  	return undef if not $new_h;             ## bail if no connection
  	bless $new_h;					        ## shouldn't be sub-classed...
      $new_h->{'__prepare'} = $sql;			##
  	$new_h->{NAME} = [];				    ##
  	$new_h->{NUM_OF_FIELDS} = -1;			##
  	push @{ $h->{'___sths'} } ,$new_h;		## save sth in parent for mass destruction
      return $new_h;					        ##
  }
  
  sub execute {
      my ($h) = @_;
      my $rc = $h->Sql($h->{'__prepare'});
      return undef if $rc;
      my @fields = $h->FieldNames;
      $h->{NAME} = \@fields;
      $h->{NUM_OF_FIELDS} = scalar @fields;
      $h;	# return dbh as pseudo sth
  }
  
  
  sub fetchrow_hashref {					## provide DBI compatibility
  	my $h = shift;
  	my $NAME = shift || "NAME";
  	my $row = $h->fetchrow_arrayref or return undef;
  	my %hash;
  	@hash{ @{ $h->{$NAME} } } = @$row;
  	return \%hash;
  }
  
  sub fetchrow {
      my $h = shift;
      return unless $h->FetchRow();
      my $fields_r = $h->{NAME};
      return $h->Data(@$fields_r);
  }
  sub fetch {
      my @row = shift->fetchrow;
      return undef unless @row;
      return \@row;
  }
  *fetchrow_arrayref = \&fetch;			## provide DBI compatibility
  *fetchrow_array    = \&fetchrow;		## provide DBI compatibility
  
  sub rows {
      shift->RowCount;
  }
  
  sub finish {
      shift->Close;						## uncommented this line
  }
  
  # ---
  
  sub commit {
  	shift->Transact(ODBC::SQL_COMMIT);
  }
  sub rollback {
  	shift->Transact(ODBC::SQL_ROLLBACK);
  }
  
  sub disconnect {
  	my ($h) = shift; 					## this will kill all the statement handles
  	foreach (@{$h->{'___sths'}}) {		## created for a specific connection
  		$_->Close if $_->{DSN};			##
  	}							        ##
      $h->Close;  						##
  }
  
  sub err {
      (shift->Error)[0];
  }
  sub errstr {
      scalar( shift->Error );
  }
  
  # ---
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_DBI_W32ODBC

$fatpacked{"darwin-thread-multi-2level/Devel/GlobalDestruction.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_DEVEL_GLOBALDESTRUCTION';
  #!/usr/bin/perl
  
  package Devel::GlobalDestruction;
  
  use strict;
  use warnings;
  
  use vars qw($VERSION @ISA);
  
  BEGIN {
  	$VERSION = '0.02';
  
  	local $@;
  
  	eval {
  		require XSLoader;
  		__PACKAGE__->XSLoader::load($VERSION);
  		1;
  	} or do {
  		require DynaLoader;
  		push @ISA, 'DynaLoader';
  		__PACKAGE__->bootstrap($VERSION);
  	};
  }
  
  use Sub::Exporter -setup => {
  	exports => [ qw(in_global_destruction) ],
  	groups  => { default => [ -all ] },
  };
  
  __PACKAGE__
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Devel::GlobalDestruction - Expose PL_dirty, the flag which marks global
  destruction.
  
  =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> so the exports may be renamed, aliased, etc.
  
  =over 4
  
  =item in_global_destruction
  
  Returns the current value of C<PL_dirty>.
  
  =back
  
  =head1 VERSION CONTROL
  
  This module is maintained using Darcs. You can get the latest version from
  L<http://nothingmuch.woobling.org/code>, and use C<darcs send> to commit
  changes.
  
  =head1 AUTHOR
  
  Yuval Kogman E<lt>nothingmuch@woobling.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
  
  
DARWIN-THREAD-MULTI-2LEVEL_DEVEL_GLOBALDESTRUCTION

$fatpacked{"darwin-thread-multi-2level/JSON/XS.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_JSON_XS';
  =head1 NAME
  
  JSON::XS - JSON serialising/deserialising, done correctly and fast
  
  =encoding utf-8
  
  JSON::XS - 正しくて高速な JSON シリアライザ/デシリアライザ
             (http://fleur.hio.jp/perldoc/mix/lib/JSON/XS.html)
  
  =head1 SYNOPSIS
  
   use 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 = JSON::XS->new->ascii->pretty->allow_nonref;
   $pretty_printed_unencoded = $coder->encode ($perl_scalar);
   $perl_scalar = $coder->decode ($unicode_json_text);
  
   # Note that JSON version 2.0 and above will automatically use JSON::XS
   # if available, at virtually no speed overhead either, so you should
   # be able to just:
   
   use JSON;
  
   # and do the same things, except that you have a pure-perl fallback now.
  
  =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.
  
  Beginning with version 2.0 of the JSON module, when both JSON and
  JSON::XS are installed, then JSON will fall back on JSON::XS (this can be
  overridden) with no overhead due to emulation (by inheriting constructor
  and methods). If JSON::XS is not available, it will fall back to the
  compatible JSON::PP module as backend, so using JSON instead of JSON::XS
  gives you a portable JSON API that can be fast when you need and doesn't
  require a C compiler when that is a problem.
  
  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 MAPPING, below, on how JSON::XS maps perl values to JSON values and
  vice versa.
  
  =head2 FEATURES
  
  =over 4
  
  =item * correct Unicode handling
  
  This module knows how to handle Unicode, 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
  
  =cut
  
  package JSON::XS;
  
  use common::sense;
  
  our $VERSION = '2.29';
  our @ISA = qw(Exporter);
  
  our @EXPORT = qw(encode_json decode_json to_json from_json);
  
  sub to_json($) {
     require Carp;
     Carp::croak ("JSON::XS::to_json has been renamed to encode_json, either downgrade to pre-2.0 versions of JSON::XS or rename the call");
  }
  
  sub from_json($) {
     require Carp;
     Carp::croak ("JSON::XS::from_json has been renamed to decode_json, either downgrade to pre-2.0 versions of JSON::XS or rename the call");
  }
  
  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 = 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 = JSON::XS->new->utf8->decode ($json_text)
  
  Except being faster.
  
  =item $is_boolean = JSON::XS::is_bool $scalar
  
  Returns true if the passed scalar represents either JSON::XS::true or
  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.
  
  Just ignore that flag unless you debug a Perl bug, a module written in
  XS or want to dive into the internals of perl. Otherwise it will only
  confuse you, as, despite the name, it says nothing about how your string
  is encoded. You can have Unicode strings with that flag set, with that
  flag clear, and you can have binary data with that flag set and that flag
  clear. Other possibilities exist, too.
  
  If you didn't know about that flag, just the better, pretend it doesn't
  exist.
  
  =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.
  
  It's a fact. Learn to live with it.
  
  =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 JSON::XS
  
  Creates a new JSON::XS object that can be used to de/encode JSON
  strings. All boolean flags described below are by default I<disabled>.
  
  The mutators for flags all return the JSON object again and thus calls can
  be chained:
  
     my $json = JSON::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.
  
    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.
  
    JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
    => ["\x{89}\\u0abc"]    # (perl syntax, U+abc escaped, U+89 not)
  
  =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", JSON::XS->new->encode ($object);
  
  Example, decode UTF-32LE-encoded JSON:
  
    use Encode;
    $object = 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 = 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:
  
     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 = 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}:
     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.
  
     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).
  
  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 parenthese
  mismatches. The only thing it guarantees is that it starts decoding as
  soon as a syntactically valid JSON text has been seen. This means you need
  to set resource limits (e.g. C<max_size>) to ensure the parser will stop
  parsing in the presence if syntax errors.
  
  The following methods implement this incremental parser.
  
  =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 = JSON::XS->new->incr_parse ("[5][7][1,2]");
  
  =item $lvalue_string = $json->incr_text
  
  This method returns the currently stored JSON fragment as an lvalue, that
  is, you can manipulate it. This I<only> works when a preceding call to
  C<incr_parse> in I<scalar context> successfully returned an object. Under
  all other circumstances you must not call this function (I mean it.
  although in simple tests it might actually work, it I<will> fail under
  real world conditions). As a special exception, you can also call this
  method before having parsed anything.
  
  This function is useful in two cases: a) finding the trailing text after a
  JSON object or b) parsing multiple JSON objects separated by non-JSON text
  (such as commas).
  
  =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 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 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 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 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 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 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 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, 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, 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. 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 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, JSON::XS::true]      # yields [false,true]
  
  =item JSON::XS::true, 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: 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> 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> or C<ascii> flags enabled
  
  With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
  with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
  characters as specified by the C<utf8> flag.
  
  If C<utf8> is disabled, then the result is also correctly encoded in those
  character sets (as both are proper subsets of Unicode, meaning that a
  Unicode string with all character values < 256 is the same thing as a
  ISO-8859-1 string, and a Unicode string with all character values < 128 is
  the same thing as an ASCII string in Perl).
  
  If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
  regardless of these flags, just some more characters will be escaped using
  C<\uXXXX> then before.
  
  Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
  encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
  encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
  a subset of Unicode), while ASCII is.
  
  Surprisingly, C<decode> will ignore these flags and so treat all input
  values as governed by the C<utf8> flag. If it is disabled, this allows you
  to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
  Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
  
  So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
  they only govern when the JSON output engine escapes a character or not.
  
  The main use for C<latin1> is to relatively efficiently store binary data
  as JSON, at the expense of breaking compatibility with most JSON decoders.
  
  The main use for C<ascii> is to force the output to not contain characters
  with values > 127, which means you can interpret the resulting string
  as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
  8-bit-encoding, and still get the same data structure back. This is useful
  when your channel for JSON transfer is not 8-bit clean or the encoding
  might be mangled in between (e.g. in mail), and works because ASCII is a
  proper subset of most 8-bit and multibyte encodings in use in the world.
  
  =back
  
  
  =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 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 JSON::XS;
  
     print 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 = 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 it's 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 JSON::XS to generate YAML, you should use this
  algorithm (subject to change in future versions):
  
     my $to_yaml = 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 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 incomaptible 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 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.
  
  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 JSON::XS/2 uses the OO interface
  with pretty-printing and hashkey sorting enabled, 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).
  
  
  =head1 BUGS
  
  While the goal of this module is to be correct, that unfortunately does
  not mean it's bug-free, only that I think its design is bug-free. If you
  keep reporting bugs they will be fixed swiftly, though.
  
  Please refrain from using rt.cpan.org or any other bug reporting
  service. I put the contact address into my modules for a reason.
  
  =cut
  
  our $true  = do { bless \(my $dummy = 1), "JSON::XS::Boolean" };
  our $false = do { bless \(my $dummy = 0), "JSON::XS::Boolean" };
  
  sub true()  { $true  }
  sub false() { $false }
  
  sub is_bool($) {
     UNIVERSAL::isa $_[0], "JSON::XS::Boolean"
  #      or UNIVERSAL::isa $_[0], "JSON::Literal"
  }
  
  XSLoader::load "JSON::XS", $VERSION;
  
  package JSON::XS::Boolean;
  
  use overload
     "0+"     => sub { ${$_[0]} },
     "++"     => sub { $_[0] = ${$_[0]} + 1 },
     "--"     => sub { $_[0] = ${$_[0]} - 1 },
     fallback => 1;
  
  1;
  
  =head1 SEE ALSO
  
  The F<json_xs> command line utility for quick experiments.
  
  =head1 AUTHOR
  
   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_JSON_XS

$fatpacked{"darwin-thread-multi-2level/JSON/XS/Boolean.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_JSON_XS_BOOLEAN';
  =head1 NAME
  
  JSON::XS::Boolean - dummy module providing 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<JSON::XS> for more info about this class.
  
  =cut
  
  use JSON::XS ();
  
  1;
  
  =head1 AUTHOR
  
   Marc Lehmann <schmorp@schmorp.de>
   http://home.schmorp.de/
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_JSON_XS_BOOLEAN

$fatpacked{"darwin-thread-multi-2level/List/MoreUtils.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_LIST_MOREUTILS';
  package List::MoreUtils;
  
  use 5.00503;
  use strict;
  use Exporter   ();
  use DynaLoader ();
  
  use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS };
  BEGIN {
      $VERSION   = '0.33';
      # $VERSION   = eval $VERSION;
      @ISA       = qw{ Exporter DynaLoader };
      @EXPORT_OK = qw{
          any all none notall true false
          firstidx first_index lastidx last_index
          insert_after insert_after_string
          apply indexes
          after after_incl before before_incl
          firstval first_value lastval last_value
          each_array each_arrayref
          pairwise natatime
          mesh zip uniq distinct
          minmax part
      };
      %EXPORT_TAGS = (
          all => \@EXPORT_OK,
      );
  
      # Load the XS at compile-time so that redefinition warnings will be
      # thrown correctly if the XS versions of part or indexes loaded
      eval {
          # PERL_DL_NONLAZY must be false, or any errors in loading will just
          # cause the perl code to be tested
          local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
  
          bootstrap List::MoreUtils $VERSION;
          1;
  
      } unless $ENV{LIST_MOREUTILS_PP};
  }
  
  eval <<'END_PERL' unless defined &any;
  
  # Use pure scalar boolean return values for compatibility with XS
  use constant YES => ! 0;
  use constant NO  => ! 1;
  
  sub any (&@) {
      my $f = shift;
      foreach ( @_ ) {
          return YES if $f->();
      }
      return NO;
  }
  
  sub all (&@) {
      my $f = shift;
      foreach ( @_ ) {
          return NO unless $f->();
      }
      return YES;
  }
  
  sub none (&@) {
      my $f = shift;
      foreach ( @_ ) {
          return NO if $f->();
      }
      return YES;
  }
  
  sub notall (&@) {
      my $f = shift;
      foreach ( @_ ) {
          return YES unless $f->();
      }
      return NO;
  }
  
  sub true (&@) {
      my $f     = shift;
      my $count = 0;
      foreach ( @_ ) {
          $count++ if $f->();
      }
      return $count;
  }
  
  sub false (&@) {
      my $f     = shift;
      my $count = 0;
      foreach ( @_ ) {
          $count++ unless $f->();
      }
      return $count;
  }
  
  sub firstidx (&@) {
      my $f = shift;
      foreach my $i ( 0 .. $#_ ) {
          local *_ = \$_[$i];
          return $i if $f->();
      }
      return -1;
  }
  
  sub lastidx (&@) {
      my $f = shift;
      foreach my $i ( reverse 0 .. $#_ ) {
          local *_ = \$_[$i];
          return $i if $f->();
      }
      return -1;
  }
  
  sub insert_after (&$\@) {
      my ($f, $val, $list) = @_;
      my $c = -1;
      local *_;
      foreach my $i ( 0 .. $#$list ) {
          $_ = $list->[$i];
          $c = $i, last if $f->();
      }
      @$list = (
          @{$list}[ 0 .. $c ],
          $val,
          @{$list}[ $c + 1 .. $#$list ],
      ) and return 1 if $c != -1;
      return 0;
  }
  
  sub insert_after_string ($$\@) {
      my ($string, $val, $list) = @_;
      my $c = -1;
      foreach my $i ( 0 .. $#$list ) {
          local $^W = 0;
          $c = $i, last if $string eq $list->[$i];
      }
      @$list = (
          @{$list}[ 0 .. $c ],
          $val,
          @{$list}[ $c + 1 .. $#$list ],
      ) and return 1 if $c != -1;
      return 0;
  }
  
  sub apply (&@) {
      my $action = shift;
      &$action foreach my @values = @_;
      wantarray ? @values : $values[-1];
  }
  
  sub after (&@) {
      my $test = shift;
      my $started;
      my $lag;
      grep $started ||= do {
          my $x = $lag;
          $lag = $test->();
          $x
      }, @_;
  }
  
  sub after_incl (&@) {
      my $test = shift;
      my $started;
      grep $started ||= $test->(), @_;
  }
  
  sub before (&@) {
      my $test = shift;
      my $more = 1;
      grep $more &&= ! $test->(), @_;
  }
  
  sub before_incl (&@) {
      my $test = shift;
      my $more = 1;
      my $lag  = 1;
      grep $more &&= do {
          my $x = $lag;
          $lag = ! $test->();
          $x
      }, @_;
  }
  
  sub indexes (&@) {
      my $test = shift;
      grep {
          local *_ = \$_[$_];
          $test->()
      } 0 .. $#_;
  }
  
  sub lastval (&@) {
      my $test = shift;
      my $ix;
      for ( $ix = $#_; $ix >= 0; $ix-- ) {
          local *_ = \$_[$ix];
          my $testval = $test->();
  
          # Simulate $_ as alias
          $_[$ix] = $_;
          return $_ if $testval;
      }
      return undef;
  }
  
  sub firstval (&@) {
      my $test = shift;
      foreach ( @_ ) {
          return $_ if $test->();
      }
      return undef;
  }
  
  sub pairwise (&\@\@) {
      my $op = shift;
  
      # Symbols for caller's input arrays
      use vars qw{ @A @B };
      local ( *A, *B ) = @_;
  
      # Localise $a, $b
      my ( $caller_a, $caller_b ) = do {
          my $pkg = caller();
          no strict 'refs';
          \*{$pkg.'::a'}, \*{$pkg.'::b'};
      };
  
      # Loop iteration limit
      my $limit = $#A > $#B? $#A : $#B;
  
      # This map expression is also the return value
      local( *$caller_a, *$caller_b );
      map {
          # Assign to $a, $b as refs to caller's array elements
          ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] );
  
          # Perform the transformation
          $op->();
      }  0 .. $limit;
  }
  
  sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
      return each_arrayref(@_);
  }
  
  sub each_arrayref {
      my @list  = @_; # The list of references to the arrays
      my $index = 0;  # Which one the caller will get next
      my $max   = 0;  # Number of elements in longest array
  
      # Get the length of the longest input array
      foreach ( @list ) {
          unless ( ref $_ eq 'ARRAY' ) {
              require Carp;
              Carp::croak("each_arrayref: argument is not an array reference\n");
          }
          $max = @$_ if @$_ > $max;
      }
  
      # Return the iterator as a closure wrt the above variables.
      return sub {
          if ( @_ ) {
              my $method = shift;
              unless ( $method eq 'index' ) {
                  require Carp;
                  Carp::croak("each_array: unknown argument '$method' passed to iterator.");
              }
  
              # Return current (last fetched) index
              return undef if $index == 0  ||  $index > $max;
              return $index - 1;
          }
  
          # No more elements to return
          return if $index >= $max;
          my $i = $index++;
  
          # Return ith elements
          return map $_->[$i], @list; 
      }
  }
  
  sub natatime ($@) {
      my $n    = shift;
      my @list = @_;
      return sub {
          return splice @list, 0, $n;
      }
  }
  
  sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
      my $max = -1;
      $max < $#$_ && ( $max = $#$_ ) foreach @_;
      map {
          my $ix = $_;
          map $_->[$ix], @_;
      } 0 .. $max; 
  }
  
  sub uniq (@) {
      my %seen = ();
      grep { not $seen{$_}++ } @_;
  }
  
  sub minmax (@) {
      return unless @_;
      my $min = my $max = $_[0];
  
      for ( my $i = 1; $i < @_; $i += 2 ) {
          if ( $_[$i-1] <= $_[$i] ) {
              $min = $_[$i-1] if $min > $_[$i-1];
              $max = $_[$i]   if $max < $_[$i];
          } else {
              $min = $_[$i]   if $min > $_[$i];
              $max = $_[$i-1] if $max < $_[$i-1];
          }
      }
  
      if ( @_ & 1 ) {
          my $i = $#_;
          if ($_[$i-1] <= $_[$i]) {
              $min = $_[$i-1] if $min > $_[$i-1];
              $max = $_[$i]   if $max < $_[$i];
          } else {
              $min = $_[$i]   if $min > $_[$i];
              $max = $_[$i-1] if $max < $_[$i-1];
          }
      }
  
      return ($min, $max);
  }
  
  sub part (&@) {
      my ($code, @list) = @_;
      my @parts;
      push @{ $parts[ $code->($_) ] }, $_  foreach @list;
      return @parts;
  }
  
  sub _XScompiled {
      return 0;
  }
  
  END_PERL
  die $@ if $@;
  
  # Function aliases
  *first_index = \&firstidx;
  *last_index  = \&lastidx;
  *first_value = \&firstval;
  *last_value  = \&lastval;
  *zip         = \&mesh;
  *distinct    = \&uniq;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  List::MoreUtils - Provide the stuff missing in List::Util
  
  =head1 SYNOPSIS
  
      use List::MoreUtils qw{
          any all none notall true false
          firstidx first_index lastidx last_index
          insert_after insert_after_string
          apply indexes
          after after_incl before before_incl
          firstval first_value lastval last_value
          each_array each_arrayref
          pairwise natatime
          mesh zip uniq distinct minmax part
      };
  
  =head1 DESCRIPTION
  
  B<List::MoreUtils> provides some trivial but commonly needed functionality on
  lists which is not going to go into L<List::Util>.
  
  All of the below functions are implementable in only a couple of lines of Perl
  code. Using the functions from this module however should give slightly better
  performance as everything is implemented in C. The pure-Perl implementation of
  these functions only serves as a fallback in case the C portions of this module
  couldn't be compiled on this machine.
  
  =over 4
  
  =item any BLOCK LIST
  
  Returns a true value if any item in LIST meets the criterion given through
  BLOCK. Sets C<$_> for each item in LIST in turn:
  
      print "At least one value undefined"
          if any { ! defined($_) } @list;
  
  Returns false otherwise, or if LIST is empty.
  
  =item all BLOCK LIST
  
  Returns a true value if all items in LIST meet the criterion given through
  BLOCK, or if LIST is empty. Sets C<$_> for each item in LIST in turn:
  
      print "All items defined"
          if all { defined($_) } @list;
  
  Returns false otherwise.
  
  =item none BLOCK LIST
  
  Logically the negation of C<any>. Returns a true value if no item in LIST meets
  the criterion given through BLOCK, or if LIST is empty. Sets C<$_> for each item
  in LIST in turn:
  
      print "No value defined"
          if none { defined($_) } @list;
  
  Returns false otherwise.
  
  =item notall BLOCK LIST
  
  Logically the negation of C<all>. Returns a true value if not all items in LIST
  meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in
  turn:
  
      print "Not all values defined"
          if notall { defined($_) } @list;
  
  Returns false otherwise, or if LIST is empty.
  
  =item true BLOCK LIST
  
  Counts the number of elements in LIST for which the criterion in BLOCK is true.
  Sets C<$_> for  each item in LIST in turn:
  
      printf "%i item(s) are defined", true { defined($_) } @list;
  
  =item false BLOCK LIST
  
  Counts the number of elements in LIST for which the criterion in BLOCK is false.
  Sets C<$_> for each item in LIST in turn:
  
      printf "%i item(s) are not defined", false { defined($_) } @list;
  
  =item firstidx BLOCK LIST
  
  =item first_index BLOCK LIST
  
  Returns the index of the first element in LIST for which the criterion in BLOCK
  is true. Sets C<$_> for each item in LIST in turn:
  
      my @list = (1, 4, 3, 2, 4, 6);
      printf "item with index %i in list is 4", firstidx { $_ == 4 } @list;
      __END__
      item with index 1 in list is 4
      
  Returns C<-1> if no such item could be found.
  
  C<first_index> is an alias for C<firstidx>.
  
  =item lastidx BLOCK LIST
  
  =item last_index BLOCK LIST
  
  Returns the index of the last element in LIST for which the criterion in BLOCK
  is true. Sets C<$_> for each item in LIST in turn:
  
      my @list = (1, 4, 3, 2, 4, 6);
      printf "item with index %i in list is 4", lastidx { $_ == 4 } @list;
      __END__
      item with index 4 in list is 4
  
  Returns C<-1> if no such item could be found.
  
  C<last_index> is an alias for C<lastidx>.
  
  =item insert_after BLOCK VALUE LIST
  
  Inserts VALUE after the first item in LIST for which the criterion in BLOCK is
  true. Sets C<$_> for each item in LIST in turn.
  
      my @list = qw/This is a list/;
      insert_after { $_ eq "a" } "longer" => @list;
      print "@list";
      __END__
      This is a longer list
  
  =item insert_after_string STRING VALUE LIST
  
  Inserts VALUE after the first item in LIST which is equal to STRING. 
  
      my @list = qw/This is a list/;
      insert_after_string "a", "longer" => @list;
      print "@list";
      __END__
      This is a longer list
  
  =item apply BLOCK LIST
  
  Applies BLOCK to each item in LIST and returns a list of the values after BLOCK
  has been applied. In scalar context, the last element is returned.  This
  function is similar to C<map> but will not modify the elements of the input
  list:
  
      my @list = (1 .. 4);
      my @mult = apply { $_ *= 2 } @list;
      print "\@list = @list\n";
      print "\@mult = @mult\n";
      __END__
      @list = 1 2 3 4
      @mult = 2 4 6 8
  
  Think of it as syntactic sugar for
  
      for (my @mult = @list) { $_ *= 2 }
  
  =item before BLOCK LIST
  
  Returns a list of values of LIST upto (and not including) the point where BLOCK
  returns a true value. Sets C<$_> for each element in LIST in turn.
  
  =item before_incl BLOCK LIST
  
  Same as C<before> but also includes the element for which BLOCK is true.
  
  =item after BLOCK LIST
  
  Returns a list of the values of LIST after (and not including) the point
  where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn.
  
      @x = after { $_ % 5 == 0 } (1..9);    # returns 6, 7, 8, 9
  
  =item after_incl BLOCK LIST
  
  Same as C<after> but also inclues the element for which BLOCK is true.
  
  =item indexes BLOCK LIST
  
  Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list
  of the indices of those elements for which BLOCK returned a true value. This is
  just like C<grep> only that it returns indices instead of values:
  
      @x = indexes { $_ % 2 == 0 } (1..10);   # returns 1, 3, 5, 7, 9
  
  =item firstval BLOCK LIST
  
  =item first_value BLOCK LIST
  
  Returns the first element in LIST for which BLOCK evaluates to true. Each
  element of LIST is set to C<$_> in turn. Returns C<undef> if no such element
  has been found.
  
  C<first_val> is an alias for C<firstval>.
  
  =item lastval BLOCK LIST
  
  =item last_value BLOCK LIST
  
  Returns the last value in LIST for which BLOCK evaluates to true. Each element
  of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been
  found.
  
  C<last_val> is an alias for C<lastval>.
  
  =item pairwise BLOCK ARRAY1 ARRAY2
  
  Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a
  new list consisting of BLOCK's return values. The two elements are set to C<$a>
  and C<$b>.  Note that those two are aliases to the original value so changing
  them will modify the input arrays.
  
      @a = (1 .. 5);
      @b = (11 .. 15);
      @x = pairwise { $a + $b } @a, @b;	# returns 12, 14, 16, 18, 20
  
      # mesh with pairwise
      @a = qw/a b c/;
      @b = qw/1 2 3/;
      @x = pairwise { ($a, $b) } @a, @b;	# returns a, 1, b, 2, c, 3
  
  =item each_array ARRAY1 ARRAY2 ...
  
  Creates an array iterator to return the elements of the list of arrays ARRAY1,
  ARRAY2 throughout ARRAYn in turn.  That is, the first time it is called, it
  returns the first element of each array.  The next time, it returns the second
  elements.  And so on, until all elements are exhausted.
  
  This is useful for looping over more than one array at once:
  
      my $ea = each_array(@a, @b, @c);
      while ( my ($a, $b, $c) = $ea->() )   { .... }
  
  The iterator returns the empty list when it reached the end of all arrays.
  
  If the iterator is passed an argument of 'C<index>', then it retuns
  the index of the last fetched set of values, as a scalar.
  
  =item each_arrayref LIST
  
  Like each_array, but the arguments are references to arrays, not the
  plain arrays.
  
  =item natatime EXPR, LIST
  
  Creates an array iterator, for looping over an array in chunks of
  C<$n> items at a time.  (n at a time, get it?).  An example is
  probably a better explanation than I could give in words.
  
  Example:
  
      my @x = ('a' .. 'g');
      my $it = natatime 3, @x;
      while (my @vals = $it->())
      {
          print "@vals\n";
      }
  
  This prints
  
      a b c
      d e f
      g
  
  =item mesh ARRAY1 ARRAY2 [ ARRAY3 ... ]
  
  =item zip ARRAY1 ARRAY2 [ ARRAY3 ... ]
  
  Returns a list consisting of the first elements of each array, then
  the second, then the third, etc, until all arrays are exhausted.
  
  Examples:
  
      @x = qw/a b c d/;
      @y = qw/1 2 3 4/;
      @z = mesh @x, @y;	    # returns a, 1, b, 2, c, 3, d, 4
  
      @a = ('x');
      @b = ('1', '2');
      @c = qw/zip zap zot/;
      @d = mesh @a, @b, @c;   # x, 1, zip, undef, 2, zap, undef, undef, zot
  
  C<zip> is an alias for C<mesh>.
  
  =item uniq LIST
  
  =item distinct LIST
  
  Returns a new list by stripping duplicate values in LIST. The order of
  elements in the returned list is the same as in LIST. In scalar context,
  returns the number of unique elements in LIST.
  
      my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4
      my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5
  
  =item minmax LIST
  
  Calculates the minimum and maximum of LIST and returns a two element list with
  the first element being the minimum and the second the maximum. Returns the
  empty list if LIST was empty.
  
  The C<minmax> algorithm differs from a naive iteration over the list where each
  element is compared to two values being the so far calculated min and max value
  in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient
  possible algorithm.
  
  However, the Perl implementation of it has some overhead simply due to the fact
  that there are more lines of Perl code involved. Therefore, LIST needs to be
  fairly big in order for C<minmax> to win over a naive implementation. This
  limitation does not apply to the XS version.
  
  =item part BLOCK LIST
  
  Partitions LIST based on the return value of BLOCK which denotes into which
  partition the current value is put.
  
  Returns a list of the partitions thusly created. Each partition created is a
  reference to an array.
  
      my $i = 0;
      my @part = part { $i++ % 2 } 1 .. 8;   # returns [1, 3, 5, 7], [2, 4, 6, 8]
  
  You can have a sparse list of partitions as well where non-set partitions will
  be undef:
  
      my @part = part { 2 } 1 .. 10;	    # returns undef, undef, [ 1 .. 10 ]
  
  Be careful with negative values, though:
  
      my @part = part { -1 } 1 .. 10;
      __END__
      Modification of non-creatable array value attempted, subscript -1 ...
  
  Negative values are only ok when they refer to a partition previously created:
  
      my @idx  = ( 0, 1, -1 );
      my $i    = 0;
      my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8]
  
  =back
  
  =head1 EXPORTS
  
  Nothing by default. To import all of this module's symbols, do the conventional
  
      use List::MoreUtils ':all';
  
  It may make more sense though to only import the stuff your program actually
  needs:
  
      use List::MoreUtils qw{ any firstidx };
  
  =head1 ENVIRONMENT
  
  When C<LIST_MOREUTILS_PP> is set, the module will always use the pure-Perl
  implementation and not the XS one. This environment variable is really just
  there for the test-suite to force testing the Perl implementation, and possibly
  for reporting of bugs. I don't see any reason to use it in a production
  environment.
  
  =head1 BUGS
  
  There is a problem with a bug in 5.6.x perls. It is a syntax error to write
  things like:
  
      my @x = apply { s/foo/bar/ } qw{ foo bar baz };
  
  It has to be written as either
  
      my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz';
  
  or
  
      my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/;
  
  Perl 5.5.x and Perl 5.8.x don't suffer from this limitation.
  
  If you have a functionality that you could imagine being in this module, please
  drop me a line. This module's policy will be less strict than L<List::Util>'s
  when it comes to additions as it isn't a core module.
  
  When you report bugs, it would be nice if you could additionally give me the
  output of your program with the environment variable C<LIST_MOREUTILS_PP> set
  to a true value. That way I know where to look for the problem (in XS,
  pure-Perl or possibly both).
  
  =head1 SUPPORT
  
  Bugs should always be submitted via the CPAN bug tracker.
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=List-MoreUtils>
  
  =head1 THANKS
  
  Credits go to a number of people: Steve Purkis for giving me namespace advice
  and James Keenan and Terrence Branno for their effort of keeping the CPAN
  tidier by making L<List::Utils> obsolete. 
  
  Brian McCauley suggested the inclusion of apply() and provided the pure-Perl
  implementation for it.
  
  Eric J. Roode asked me to add all functions from his module C<List::MoreUtil>
  into this one. With minor modifications, the pure-Perl implementations of those
  are by him.
  
  The bunch of people who almost immediately pointed out the many problems with
  the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers).
  
  A particularly nasty memory leak was spotted by Thomas A. Lowery.
  
  Lars Thegler made me aware of problems with older Perl versions.
  
  Anno Siegel de-orphaned each_arrayref().
  
  David Filmer made me aware of a problem in each_arrayref that could ultimately
  lead to a segfault.
  
  Ricardo Signes suggested the inclusion of part() and provided the
  Perl-implementation.
  
  Robin Huston kindly fixed a bug in perl's MULTICALL API to make the
  XS-implementation of part() work.
  
  =head1 TODO
  
  A pile of requests from other people is still pending further processing in
  my mailbox. This includes:
  
  =over 4
  
  =item * List::Util export pass-through
  
  Allow B<List::MoreUtils> to pass-through the regular L<List::Util>
  functions to end users only need to C<use> the one module.
  
  =item * uniq_by(&@)
  
  Use code-reference to extract a key based on which the uniqueness is
  determined. Suggested by Aaron Crane.
  
  =item * delete_index
  
  =item * random_item
  
  =item * random_item_delete_index
  
  =item * list_diff_hash
  
  =item * list_diff_inboth
  
  =item * list_diff_infirst
  
  =item * list_diff_insecond
  
  These were all suggested by Dan Muey.
  
  =item * listify
  
  Always return a flat list when either a simple scalar value was passed or an
  array-reference. Suggested by Mark Summersault.
  
  =back
  
  =head1 SEE ALSO
  
  L<List::Util>
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Some parts copyright 2011 Aaron Crane.
  
  Copyright 2004 - 2010 by Tassilo von Parseval
  
  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.4 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_LIST_MOREUTILS

$fatpacked{"darwin-thread-multi-2level/List/Util.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL';
  # List::Util.pm
  #
  # Copyright (c) 1997-2009 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.
  #
  # This module is normally only loaded if the XS module is not available
  
  package List::Util;
  
  use strict;
  use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY);
  require Exporter;
  
  @ISA        = qw(Exporter);
  @EXPORT_OK  = qw(first min max minstr maxstr reduce sum shuffle);
  $VERSION    = "1.23";
  $XS_VERSION = $VERSION;
  $VERSION    = eval $VERSION;
  
  eval {
    # PERL_DL_NONLAZY must be false, or any errors in loading will just
    # cause the perl code to be tested
    local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
    eval {
      require XSLoader;
      XSLoader::load('List::Util', $XS_VERSION);
      1;
    } or do {
      require DynaLoader;
      local @ISA = qw(DynaLoader);
      bootstrap List::Util $XS_VERSION;
    };
  } unless $TESTING_PERL_ONLY;
  
  
  if (!defined &sum) {
    require List::Util::PP;
    List::Util::PP->import;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  List::Util - A selection of general-utility list subroutines
  
  =head1 SYNOPSIS
  
      use List::Util qw(first max maxstr min minstr reduce shuffle sum);
  
  =head1 DESCRIPTION
  
  C<List::Util> contains a selection of subroutines that people have
  expressed would be nice to have in the perl core, but the usage would
  not really be high enough to warrant the use of a keyword, and the size
  so small such that being individual extensions would be wasteful.
  
  By default C<List::Util> does not export any subroutines. The
  subroutines defined are
  
  =over 4
  
  =item first BLOCK LIST
  
  Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
  of LIST in turn. C<first> returns the first element where the result from
  BLOCK is a true value. If BLOCK never returns true or LIST was empty then
  C<undef> is returned.
  
      $foo = first { defined($_) } @list    # first defined value in @list
      $foo = first { $_ > $value } @list    # first value in @list which
                                            # is greater than $value
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
  
  for example wanted() could be defined() which would return the first
  defined value in @list
  
  =item max LIST
  
  Returns the entry in the list with the highest numerical value. If the
  list is empty then C<undef> is returned.
  
      $foo = max 1..10                # 10
      $foo = max 3,9,12               # 12
      $foo = max @bar, @baz           # whatever
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { $a > $b ? $a : $b } 1..10
  
  =item maxstr LIST
  
  Similar to C<max>, but treats all the entries in the list as strings
  and returns the highest string as defined by the C<gt> operator.
  If the list is empty then C<undef> is returned.
  
      $foo = maxstr 'A'..'Z'          # 'Z'
      $foo = maxstr "hello","world"   # "world"
      $foo = maxstr @bar, @baz        # whatever
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
  
  =item min LIST
  
  Similar to C<max> but returns the entry in the list with the lowest
  numerical value. If the list is empty then C<undef> is returned.
  
      $foo = min 1..10                # 1
      $foo = min 3,9,12               # 3
      $foo = min @bar, @baz           # whatever
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { $a < $b ? $a : $b } 1..10
  
  =item minstr LIST
  
  Similar to C<min>, but treats all the entries in the list as strings
  and returns the lowest string as defined by the C<lt> operator.
  If the list is empty then C<undef> is returned.
  
      $foo = minstr 'A'..'Z'          # 'A'
      $foo = minstr "hello","world"   # "hello"
      $foo = minstr @bar, @baz        # whatever
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
  
  =item reduce BLOCK LIST
  
  Reduces LIST by calling BLOCK, in a scalar context, multiple times,
  setting C<$a> and C<$b> each time. The first call will be with C<$a>
  and C<$b> set to the first two elements of the list, subsequent
  calls will be done by setting C<$a> to the result of the previous
  call and C<$b> to the next element in the list.
  
  Returns the result of the last call to BLOCK. If LIST is empty then
  C<undef> is returned. If LIST only contains one element then that
  element is returned and BLOCK is not executed.
  
      $foo = reduce { $a < $b ? $a : $b } 1..10       # min
      $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
      $foo = reduce { $a + $b } 1 .. 10               # sum
      $foo = reduce { $a . $b } @bar                  # concat
  
  If your algorithm requires that C<reduce> produce an identity value, then
  make sure that you always pass that identity value as the first argument to prevent
  C<undef> being returned
  
    $foo = reduce { $a + $b } 0, @values;             # sum with 0 identity value
  
  =item shuffle LIST
  
  Returns the elements of LIST in a random order
  
      @cards = shuffle 0..51      # 0..51 in a random order
  
  =item sum LIST
  
  Returns the sum of all the elements in LIST. If LIST is empty then
  C<undef> is returned.
  
      $foo = sum 1..10                # 55
      $foo = sum 3,9,12               # 24
      $foo = sum @bar, @baz           # whatever
  
  This function could be implemented using C<reduce> like this
  
      $foo = reduce { $a + $b } 1..10
  
  If your algorithm requires that C<sum> produce an identity of 0, then
  make sure that you always pass C<0> as the first argument to prevent
  C<undef> being returned
  
    $foo = sum 0, @values;
  
  =back
  
  =head1 KNOWN BUGS
  
  With perl versions prior to 5.005 there are some cases where reduce
  will return an incorrect result. This will show up as test 7 of
  reduce.t failing.
  
  =head1 SUGGESTED ADDITIONS
  
  The following are additions that have been requested, but I have been reluctant
  to add due to them being very simple to implement in perl
  
    # One argument is true
  
    sub any { $_ && return 1 for @_; 0 }
  
    # All arguments are true
  
    sub all { $_ || return 0 for @_; 1 }
  
    # All arguments are false
  
    sub none { $_ && return 0 for @_; 1 }
  
    # One argument is false
  
    sub notall { $_ || return 1 for @_; 0 }
  
    # How many elements are true
  
    sub true { scalar grep { $_ } @_ }
  
    # How many elements are false
  
    sub false { scalar grep { !$_ } @_ }
  
  =head1 SEE ALSO
  
  L<Scalar::Util>, L<List::MoreUtils>
  
  =head1 COPYRIGHT
  
  Copyright (c) 1997-2007 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.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL

$fatpacked{"darwin-thread-multi-2level/List/Util/PP.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL_PP';
  # List::Util::PP.pm
  #
  # Copyright (c) 1997-2009 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 List::Util::PP;
  
  use strict;
  use warnings;
  use vars qw(@ISA @EXPORT $VERSION $a $b);
  require Exporter;
  
  @ISA     = qw(Exporter);
  @EXPORT  = qw(first min max minstr maxstr reduce sum shuffle);
  $VERSION = "1.23";
  $VERSION = eval $VERSION;
  
  sub reduce (&@) {
    my $code = shift;
    require Scalar::Util;
    my $type = Scalar::Util::reftype($code);
    unless($type and $type eq 'CODE') {
      require Carp;
      Carp::croak("Not a subroutine reference");
    }
    no strict 'refs';
  
    return shift unless @_ > 1;
  
    use vars qw($a $b);
  
    my $caller = caller;
    local(*{$caller."::a"}) = \my $a;
    local(*{$caller."::b"}) = \my $b;
  
    $a = shift;
    foreach (@_) {
      $b = $_;
      $a = &{$code}();
    }
  
    $a;
  }
  
  sub first (&@) {
    my $code = shift;
    require Scalar::Util;
    my $type = Scalar::Util::reftype($code);
    unless($type and $type eq 'CODE') {
      require Carp;
      Carp::croak("Not a subroutine reference");
    }
  
    foreach (@_) {
      return $_ if &{$code}();
    }
  
    undef;
  }
  
  
  sub sum (@) { reduce { $a + $b } @_ }
  
  sub min (@) { reduce { $a < $b ? $a : $b } @_ }
  
  sub max (@) { reduce { $a > $b ? $a : $b } @_ }
  
  sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
  
  sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
  
  sub shuffle (@) {
    my @a=\(@_);
    my $n;
    my $i=@_;
    map {
      $n = rand($i--);
      (${$a[$n]}, $a[$n] = $a[$i])[0];
    } @_;
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL_PP

$fatpacked{"darwin-thread-multi-2level/List/Util/XS.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL_XS';
  package List::Util::XS;
  use strict;
  use vars qw($VERSION);
  use List::Util;
  
  $VERSION = "1.23";           # FIXUP
  $VERSION = eval $VERSION;    # FIXUP
  
  sub _VERSION { # FIXUP
    require Carp;
    Carp::croak("You need to install Scalar-List-Utils with a C compiler to ensure the XS is compiled")
      if defined $_[1];
    $VERSION;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  List::Util::XS - Indicate if List::Util was compiled with a C compiler
  
  =head1 SYNOPSIS
  
      use List::Util::XS 1.20;
  
  =head1 DESCRIPTION
  
  C<List::Util::XS> can be used as a dependency to ensure List::Util was
  installed using a C compiler and that the XS version is installed.
  
  During installation C<$List::Util::XS::VERSION> will be set to
  C<undef> if the XS was not compiled.
  
  =head1 SEE ALSO
  
  L<Scalar::Util>, L<List::Util>, L<List::MoreUtils>
  
  =head1 COPYRIGHT
  
  Copyright (c) 2008 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.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_LIST_UTIL_XS

$fatpacked{"darwin-thread-multi-2level/MIME/Base64.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MIME_BASE64';
  package MIME::Base64;
  
  use strict;
  use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(encode_base64 decode_base64);
  @EXPORT_OK = qw(encoded_base64_length decoded_base64_length);
  
  $VERSION = '3.10';
  
  require XSLoader;
  XSLoader::load('MIME::Base64', $VERSION);
  
  *encode = \&encode_base64;
  *decode = \&decode_base64;
  
  1;
  
  __END__
  
  =head1 NAME
  
  MIME::Base64 - Encoding and decoding of base64 strings
  
  =head1 SYNOPSIS
  
   use MIME::Base64;
  
   $encoded = encode_base64('Aladdin:open sesame');
   $decoded = decode_base64($encoded);
  
  =head1 DESCRIPTION
  
  This module provides functions to encode and decode strings into and from the
  base64 encoding specified in RFC 2045 - I<MIME (Multipurpose Internet
  Mail Extensions)>. The base64 encoding is designed to represent
  arbitrary sequences of octets in a form that need not be humanly
  readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used,
  enabling 6 bits to be represented per printable character.
  
  The following primary functions are provided:
  
  =over 4
  
  =item encode_base64($str)
  
  =item encode_base64($str, $eol);
  
  Encode data by calling the encode_base64() function.  The first
  argument is the string to encode.  The second argument is the
  line-ending sequence to use.  It is optional and defaults to "\n".  The
  returned encoded string is broken into lines of no more than 76
  characters each and it will end with $eol unless it is empty.  Pass an
  empty string as second argument if you do not want the encoded string
  to be broken into lines.
  
  =item decode_base64($str)
  
  Decode a base64 string by calling the decode_base64() function.  This
  function takes a single argument which is the string to decode and
  returns the decoded data.
  
  Any character not part of the 65-character base64 subset is
  silently ignored.  Characters occurring after a '=' padding character
  are never decoded.
  
  If the length of the string to decode, after ignoring
  non-base64 chars, is not a multiple of 4 or if padding occurs too early,
  then a warning is generated if perl is running under C<-w>.
  
  =back
  
  If you prefer not to import these routines into your namespace, you can
  call them as:
  
      use MIME::Base64 ();
      $encoded = MIME::Base64::encode($decoded);
      $decoded = MIME::Base64::decode($encoded);
  
  Additional functions not exported by default:
  
  =over 4
  
  =item encoded_base64_length($str)
  
  =item encoded_base64_length($str, $eol)
  
  Returns the length that the encoded string would have without actually
  encoding it.  This will return the same value as C<< length(encode_base64($str)) >>,
  but should be more efficient.
  
  =item decoded_base64_length($str)
  
  Returns the length that the decoded string would have without actually
  decoding it.  This will return the same value as C<< length(decode_base64($str)) >>,
  but should be more efficient.
  
  =back
  
  =head1 DIAGNOSTICS
  
  The following warnings can be generated if perl is invoked with the
  C<-w> switch:
  
  =over 4
  
  =item Premature end of base64 data
  
  The number of characters to decode is not a multiple of 4.  Legal
  base64 data should be padded with one or two "=" characters to make
  its length a multiple of 4.  The decoded result will be the same
  whether the padding is present or not.
  
  =item Premature padding of base64 data
  
  The '=' padding character occurs as the first or second character
  in a base64 quartet.
  
  =back
  
  The following exception can be raised:
  
  =over 4
  
  =item Wide character in subroutine entry
  
  The string passed to encode_base64() contains characters with code
  above 255.  The base64 encoding is only defined for single-byte
  characters.  Use the Encode module to select the byte encoding you
  want.
  
  =back
  
  =head1 EXAMPLES
  
  If you want to encode a large file, you should encode it in chunks
  that are a multiple of 57 bytes.  This ensures that the base64 lines
  line up and that you do not end up with padding in the middle. 57
  bytes of data fills one complete base64 line (76 == 57*4/3):
  
     use MIME::Base64 qw(encode_base64);
  
     open(FILE, "/var/log/wtmp") or die "$!";
     while (read(FILE, $buf, 60*57)) {
         print encode_base64($buf);
     }
  
  or if you know you have enough memory
  
     use MIME::Base64 qw(encode_base64);
     local($/) = undef;  # slurp
     print encode_base64(<STDIN>);
  
  The same approach as a command line:
  
     perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)' <file
  
  Decoding does not need slurp mode if every line contains a multiple
  of four base64 chars:
  
     perl -MMIME::Base64 -ne 'print decode_base64($_)' <file
  
  Perl v5.8 and better allow extended Unicode characters in strings.
  Such strings cannot be encoded directly, as the base64
  encoding is only defined for single-byte characters.  The solution is
  to use the Encode module to select the byte encoding you want.  For
  example:
  
      use MIME::Base64 qw(encode_base64);
      use Encode qw(encode);
  
      $encoded = encode_base64(encode("UTF-8", "\x{FFFF}\n"));
      print $encoded;
  
  =head1 COPYRIGHT
  
  Copyright 1995-1999, 2001-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  Distantly based on LWP::Base64 written by Martijn Koster
  <m.koster@nexor.co.uk> and Joerg Reichelt <j.reichelt@nexor.co.uk> and
  code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans
  Mulder <hansm@wsinti07.win.tue.nl>
  
  The XS implementation uses code from metamail.  Copyright 1991 Bell
  Communications Research, Inc. (Bellcore)
  
  =head1 SEE ALSO
  
  L<MIME::QuotedPrint>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_MIME_BASE64

$fatpacked{"darwin-thread-multi-2level/MIME/QuotedPrint.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MIME_QUOTEDPRINT';
  package MIME::QuotedPrint;
  
  use strict;
  use vars qw(@ISA @EXPORT $VERSION);
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(encode_qp decode_qp);
  
  $VERSION = "3.10";
  
  use MIME::Base64;  # will load XS version of {en,de}code_qp()
  
  *encode = \&encode_qp;
  *decode = \&decode_qp;
  
  1;
  
  __END__
  
  =head1 NAME
  
  MIME::QuotedPrint - Encoding and decoding of quoted-printable strings
  
  =head1 SYNOPSIS
  
   use MIME::QuotedPrint;
  
   $encoded = encode_qp($decoded);
   $decoded = decode_qp($encoded);
  
  =head1 DESCRIPTION
  
  This module provides functions to encode and decode strings into and from the
  quoted-printable encoding specified in RFC 2045 - I<MIME (Multipurpose
  Internet Mail Extensions)>.  The quoted-printable encoding is intended
  to represent data that largely consists of bytes that correspond to
  printable characters in the ASCII character set.  Each non-printable
  character (as defined by English Americans) is represented by a
  triplet consisting of the character "=" followed by two hexadecimal
  digits.
  
  The following functions are provided:
  
  =over 4
  
  =item encode_qp($str)
  
  =item encode_qp($str, $eol)
  
  =item encode_qp($str, $eol, $binmode)
  
  This function returns an encoded version of the string ($str) given as
  argument.
  
  The second argument ($eol) is the line-ending sequence to use.  It is
  optional and defaults to "\n".  Every occurrence of "\n" is replaced
  with this string, and it is also used for additional "soft line
  breaks" to ensure that no line end up longer than 76 characters.  Pass
  it as "\015\012" to produce data suitable for external consumption.
  The string "\r\n" produces the same result on many platforms, but not
  all.
  
  The third argument ($binmode) will select binary mode if passed as a
  TRUE value.  In binary mode "\n" will be encoded in the same way as
  any other non-printable character.  This ensures that a decoder will
  end up with exactly the same string whatever line ending sequence it
  uses.  In general it is preferable to use the base64 encoding for
  binary data; see L<MIME::Base64>.
  
  An $eol of "" (the empty string) is special.  In this case, no "soft
  line breaks" are introduced and binary mode is effectively enabled so
  that any "\n" in the original data is encoded as well.
  
  =item decode_qp($str);
  
  This function returns the plain text version of the string given
  as argument.  The lines of the result are "\n" terminated, even if
  the $str argument contains "\r\n" terminated lines.
  
  =back
  
  
  If you prefer not to import these routines into your namespace, you can
  call them as:
  
    use MIME::QuotedPrint ();
    $encoded = MIME::QuotedPrint::encode($decoded);
    $decoded = MIME::QuotedPrint::decode($encoded);
  
  Perl v5.8 and better allow extended Unicode characters in strings.
  Such strings cannot be encoded directly, as the quoted-printable
  encoding is only defined for single-byte characters.  The solution is
  to use the Encode module to select the byte encoding you want.  For
  example:
  
      use MIME::QuotedPrint qw(encode_qp);
      use Encode qw(encode);
  
      $encoded = encode_qp(encode("UTF-8", "\x{FFFF}\n"));
      print $encoded;
  
  =head1 COPYRIGHT
  
  Copyright 1995-1997,2002-2004 Gisle Aas.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<MIME::Base64>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_MIME_QUOTEDPRINT

$fatpacked{"darwin-thread-multi-2level/Moose.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE';
  package Moose;
  BEGIN {
    $Moose::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::VERSION = '2.0401';
  }
  use strict;
  use warnings;
  
  use 5.008;
  
  use Scalar::Util 'blessed';
  use Carp         'confess';
  use Class::Load  'is_class_loaded';
  
  
  use Moose::Deprecated;
  use Moose::Exporter;
  
  use Class::MOP;
  
  BEGIN {
      die "Class::MOP version $Moose::VERSION required--this is version $Class::MOP::VERSION"
          if $Moose::VERSION && $Class::MOP::VERSION ne $Moose::VERSION;
  }
  
  use Moose::Meta::Class;
  use Moose::Meta::TypeConstraint;
  use Moose::Meta::TypeCoercion;
  use Moose::Meta::Attribute;
  use Moose::Meta::Instance;
  
  use Moose::Object;
  
  use Moose::Meta::Role;
  use Moose::Meta::Role::Composite;
  use Moose::Meta::Role::Application;
  use Moose::Meta::Role::Application::RoleSummation;
  use Moose::Meta::Role::Application::ToClass;
  use Moose::Meta::Role::Application::ToRole;
  use Moose::Meta::Role::Application::ToInstance;
  
  use Moose::Util::TypeConstraints;
  use Moose::Util ();
  
  use Moose::Meta::Attribute::Native;
  
  sub throw_error {
      # FIXME This
      shift;
      goto \&confess
  }
  
  sub extends {
      my $meta = shift;
  
      Moose->throw_error("Must derive at least one class") unless @_;
  
      # this checks the metaclass to make sure
      # it is correct, sometimes it can get out
      # of sync when the classes are being built
      $meta->superclasses(@_);
  }
  
  sub with {
      Moose::Util::apply_all_roles(shift, @_);
  }
  
  sub has {
      my $meta = shift;
      my $name = shift;
  
      Moose->throw_error('Usage: has \'name\' => ( key => value, ... )')
          if @_ % 2 == 1;
  
      my %options = ( definition_context => Moose::Util::_caller_info(), @_ );
      my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
      $meta->add_attribute( $_, %options ) for @$attrs;
  }
  
  sub before {
      Moose::Util::add_method_modifier(shift, 'before', \@_);
  }
  
  sub after {
      Moose::Util::add_method_modifier(shift, 'after', \@_);
  }
  
  sub around {
      Moose::Util::add_method_modifier(shift, 'around', \@_);
  }
  
  our $SUPER_PACKAGE;
  our $SUPER_BODY;
  our @SUPER_ARGS;
  
  sub super {
      # This check avoids a recursion loop - see
      # t/bugs/super_recursion.t
      return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
      return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
  }
  
  sub override {
      my $meta = shift;
      my ( $name, $method ) = @_;
      $meta->add_override_method_modifier( $name => $method );
  }
  
  sub inner {
      my $pkg = caller();
      our ( %INNER_BODY, %INNER_ARGS );
  
      if ( my $body = $INNER_BODY{$pkg} ) {
          my @args = @{ $INNER_ARGS{$pkg} };
          local $INNER_ARGS{$pkg};
          local $INNER_BODY{$pkg};
          return $body->(@args);
      } else {
          return;
      }
  }
  
  sub augment {
      my $meta = shift;
      my ( $name, $method ) = @_;
      $meta->add_augment_method_modifier( $name => $method );
  }
  
  Moose::Exporter->setup_import_methods(
      with_meta => [
          qw( extends with has before after around override augment )
      ],
      as_is => [
          qw( super inner ),
          \&Carp::confess,
          \&Scalar::Util::blessed,
      ],
  );
  
  sub init_meta {
      shift;
      my %args = @_;
  
      my $class = $args{for_class}
          or Moose->throw_error("Cannot call init_meta without specifying a for_class");
      my $base_class = $args{base_class} || 'Moose::Object';
      my $metaclass  = $args{metaclass}  || 'Moose::Meta::Class';
      my $meta_name  = exists $args{meta_name} ? $args{meta_name} : 'meta';
  
      Moose->throw_error("The Metaclass $metaclass must be loaded. (Perhaps you forgot to 'use $metaclass'?)")
          unless is_class_loaded($metaclass);
  
      Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Class.")
          unless $metaclass->isa('Moose::Meta::Class');
  
      # make a subtype for each Moose class
      class_type($class)
          unless find_type_constraint($class);
  
      my $meta;
  
      if ( $meta = Class::MOP::get_metaclass_by_name($class) ) {
          unless ( $meta->isa("Moose::Meta::Class") ) {
              my $error_message = "$class already has a metaclass, but it does not inherit $metaclass ($meta).";
              if ( $meta->isa('Moose::Meta::Role') ) {
                  Moose->throw_error($error_message . ' You cannot make the same thing a role and a class. Remove either Moose or Moose::Role.');
              } else {
                  Moose->throw_error($error_message);
              }
          }
      } else {
          # no metaclass
  
          # now we check whether our ancestors have metaclass, and if so borrow that
          my ( undef, @isa ) = @{ mro::get_linear_isa($class) };
  
          foreach my $ancestor ( @isa ) {
              my $ancestor_meta = Class::MOP::get_metaclass_by_name($ancestor) || next;
  
              my $ancestor_meta_class = $ancestor_meta->_real_ref_name;
  
              # if we have an ancestor metaclass that inherits $metaclass, we use
              # that. This is like _fix_metaclass_incompatibility, but we can do it now.
  
              # the case of having an ancestry is not very common, but arises in
              # e.g. Reaction
              unless ( $metaclass->isa( $ancestor_meta_class ) ) {
                  if ( $ancestor_meta_class->isa($metaclass) ) {
                      $metaclass = $ancestor_meta_class;
                  }
              }
          }
  
          $meta = $metaclass->initialize($class);
      }
  
      if (defined $meta_name) {
          # also check for inherited non moose 'meta' method?
          my $existing = $meta->get_method($meta_name);
          if ($existing && !$existing->isa('Class::MOP::Method::Meta')) {
              Carp::cluck "Moose is overwriting an existing method named "
                        . "$meta_name in class $class with a method "
                        . "which returns the class's metaclass. If this is "
                        . "actually what you want, you should remove the "
                        . "existing method, otherwise, you should rename or "
                        . "disable this generated method using the "
                        . "'-meta_name' option to 'use Moose'.";
          }
          $meta->_add_meta_method($meta_name);
      }
  
      # make sure they inherit from Moose::Object
      $meta->superclasses($base_class)
        unless $meta->superclasses();
  
      return $meta;
  }
  
  # This may be used in some older MooseX extensions.
  sub _get_caller {
      goto &Moose::Exporter::_get_caller;
  }
  
  ## make 'em all immutable
  
  $_->make_immutable(
      inline_constructor => 1,
      constructor_name   => "_new",
      # these are Class::MOP accessors, so they need inlining
      inline_accessors => 1
      ) for grep { $_->is_mutable }
      map { $_->meta }
      qw(
      Moose::Meta::Attribute
      Moose::Meta::Class
      Moose::Meta::Instance
  
      Moose::Meta::TypeCoercion
      Moose::Meta::TypeCoercion::Union
  
      Moose::Meta::Method
      Moose::Meta::Method::Constructor
      Moose::Meta::Method::Destructor
      Moose::Meta::Method::Overridden
      Moose::Meta::Method::Augmented
  
      Moose::Meta::Role
      Moose::Meta::Role::Attribute
      Moose::Meta::Role::Method
      Moose::Meta::Role::Method::Required
      Moose::Meta::Role::Method::Conflicting
  
      Moose::Meta::Role::Composite
  
      Moose::Meta::Role::Application
      Moose::Meta::Role::Application::RoleSummation
      Moose::Meta::Role::Application::ToClass
      Moose::Meta::Role::Application::ToRole
      Moose::Meta::Role::Application::ToInstance
  );
  
  $_->make_immutable(
      inline_constructor => 0,
      constructor_name   => undef,
      # these are Class::MOP accessors, so they need inlining
      inline_accessors => 1
      ) for grep { $_->is_mutable }
      map { $_->meta }
      qw(
      Moose::Meta::Method::Accessor
      Moose::Meta::Method::Delegation
      Moose::Meta::Mixin::AttributeCore
  );
  
  1;
  
  # ABSTRACT: A postmodern object system for Perl 5
  
  
  
  =pod
  
  =head1 NAME
  
  Moose - A postmodern object system for Perl 5
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Point;
    use Moose; # automatically turns on strict and warnings
  
    has 'x' => (is => 'rw', isa => 'Int');
    has 'y' => (is => 'rw', isa => 'Int');
  
    sub clear {
        my $self = shift;
        $self->x(0);
        $self->y(0);
    }
  
    package Point3D;
    use Moose;
  
    extends 'Point';
  
    has 'z' => (is => 'rw', isa => 'Int');
  
    after 'clear' => sub {
        my $self = shift;
        $self->z(0);
    };
  
  =head1 DESCRIPTION
  
  Moose is an extension of the Perl 5 object system.
  
  The main goal of Moose is to make Perl 5 Object Oriented programming
  easier, more consistent, and less tedious. With Moose you can think
  more about what you want to do and less about the mechanics of OOP.
  
  Additionally, Moose is built on top of L<Class::MOP>, which is a
  metaclass system for Perl 5. This means that Moose not only makes
  building normal Perl 5 objects better, but it provides the power of
  metaclass programming as well.
  
  =head2 New to Moose?
  
  If you're new to Moose, the best place to start is the
  L<Moose::Manual> docs, followed by the L<Moose::Cookbook>. The intro
  will show you what Moose is, and how it makes Perl 5 OO better.
  
  The cookbook recipes on Moose basics will get you up to speed with
  many of Moose's features quickly. Once you have an idea of what Moose
  can do, you can use the API documentation to get more detail on
  features which interest you.
  
  =head2 Moose Extensions
  
  The C<MooseX::> namespace is the official place to find Moose extensions.
  These extensions can be found on the CPAN.  The easiest way to find them
  is to search for them (L<http://search.cpan.org/search?query=MooseX::>),
  or to examine L<Task::Moose> which aims to keep an up-to-date, easily
  installable list of Moose extensions.
  
  =head1 TRANSLATIONS
  
  Much of the Moose documentation has been translated into other languages.
  
  =over 4
  
  =item Japanese
  
  Japanese docs can be found at
  L<http://perldoc.perlassociation.org/pod/Moose-Doc-JA/index.html>. The
  source POD files can be found in GitHub:
  L<http://github.com/jpa/Moose-Doc-JA>
  
  =back
  
  =head1 BUILDING CLASSES WITH MOOSE
  
  Moose makes every attempt to provide as much convenience as possible during
  class construction/definition, but still stay out of your way if you want it
  to. Here are a few items to note when building classes with Moose.
  
  When you C<use Moose>, Moose will set the class's parent class to
  L<Moose::Object>, I<unless> the class using Moose already has a parent
  class. In addition, specifying a parent with C<extends> will change the parent
  class.
  
  Moose will also manage all attributes (including inherited ones) that are
  defined with C<has>. And (assuming you call C<new>, which is inherited from
  L<Moose::Object>) this includes properly initializing all instance slots,
  setting defaults where appropriate, and performing any type constraint checking
  or coercion.
  
  =head1 PROVIDED METHODS
  
  Moose provides a number of methods to all your classes, mostly through the
  inheritance of L<Moose::Object>. There is however, one exception.
  
  =over 4
  
  =item B<meta>
  
  This is a method which provides access to the current class's metaclass.
  
  =back
  
  =head1 EXPORTED FUNCTIONS
  
  Moose will export a number of functions into the class's namespace which
  may then be used to set up the class. These functions all work directly
  on the current class.
  
  =over 4
  
  =item B<extends (@superclasses)>
  
  This function will set the superclass(es) for the current class.
  
  This approach is recommended instead of C<use base>, because C<use base>
  actually C<push>es onto the class's C<@ISA>, whereas C<extends> will
  replace it. This is important to ensure that classes which do not have
  superclasses still properly inherit from L<Moose::Object>.
  
  Each superclass can be followed by a hash reference with options. Currently,
  only L<-version|Class::MOP/Class Loading Options> is recognized:
  
      extends 'My::Parent'      => { -version => 0.01 },
              'My::OtherParent' => { -version => 0.03 };
  
  An exception will be thrown if the version requirements are not
  satisfied.
  
  =item B<with (@roles)>
  
  This will apply a given set of C<@roles> to the local class.
  
  Like with C<extends>, each specified role can be followed by a hash
  reference with a L<-version|Class::MOP/Class Loading Options> option:
  
      with 'My::Role'      => { -version => 0.32 },
           'My::Otherrole' => { -version => 0.23 };
  
  The specified version requirements must be satisfied, otherwise an
  exception will be thrown.
  
  If your role takes options or arguments, they can be passed along in the
  hash reference as well.
  
  =item B<has $name|@$names =E<gt> %options>
  
  This will install an attribute of a given C<$name> into the current class. If
  the first parameter is an array reference, it will create an attribute for
  every C<$name> in the list. The C<%options> will be passed to the constructor
  for L<Moose::Meta::Attribute> (which inherits from L<Class::MOP::Attribute>),
  so the full documentation for the valid options can be found there. These are
  the most commonly used options:
  
  =over 4
  
  =item I<is =E<gt> 'rw'|'ro'>
  
  The I<is> option accepts either I<rw> (for read/write) or I<ro> (for read
  only). These will create either a read/write accessor or a read-only
  accessor respectively, using the same name as the C<$name> of the attribute.
  
  If you need more control over how your accessors are named, you can
  use the L<reader|Class::MOP::Attribute/reader>,
  L<writer|Class::MOP::Attribute/writer> and
  L<accessor|Class::MOP::Attribute/accessor> options inherited from
  L<Class::MOP::Attribute>, however if you use those, you won't need the
  I<is> option.
  
  =item I<isa =E<gt> $type_name>
  
  The I<isa> option uses Moose's type constraint facilities to set up runtime
  type checking for this attribute. Moose will perform the checks during class
  construction, and within any accessors. The C<$type_name> argument must be a
  string. The string may be either a class name or a type defined using
  Moose's type definition features. (Refer to L<Moose::Util::TypeConstraints>
  for information on how to define a new type, and how to retrieve type meta-data).
  
  =item I<coerce =E<gt> (1|0)>
  
  This will attempt to use coercion with the supplied type constraint to change
  the value passed into any accessors or constructors. You B<must> supply a type
  constraint, and that type constraint B<must> define a coercion. See
  L<Moose::Cookbook::Basics::Recipe5> for an example.
  
  =item I<does =E<gt> $role_name>
  
  This will accept the name of a role which the value stored in this attribute
  is expected to have consumed.
  
  =item I<required =E<gt> (1|0)>
  
  This marks the attribute as being required. This means a value must be
  supplied during class construction, I<or> the attribute must be lazy
  and have either a default or a builder. Note that c<required> does not
  say anything about the attribute's value, which can be C<undef>.
  
  =item I<weak_ref =E<gt> (1|0)>
  
  This will tell the class to store the value of this attribute as a weakened
  reference. If an attribute is a weakened reference, it B<cannot> also be
  coerced. Note that when a weak ref expires, the attribute's value becomes
  undefined, and is still considered to be set for purposes of predicate,
  default, etc.
  
  =item I<lazy =E<gt> (1|0)>
  
  This will tell the class to not create this slot until absolutely necessary.
  If an attribute is marked as lazy it B<must> have a default or builder
  supplied.
  
  =item I<trigger =E<gt> $code>
  
  The I<trigger> option is a CODE reference which will be called after
  the value of the attribute is set. The CODE ref is passed the
  instance itself, the updated value, and the original value if the
  attribute was already set.
  
  You B<can> have a trigger on a read-only attribute.
  
  B<NOTE:> Triggers will only fire when you B<assign> to the attribute,
  either in the constructor, or using the writer. Default and built values will
  B<not> cause the trigger to be fired.
  
  =item I<handles =E<gt> ARRAY | HASH | REGEXP | ROLE | ROLETYPE | DUCKTYPE | CODE>
  
  The I<handles> option provides Moose classes with automated delegation features.
  This is a pretty complex and powerful option. It accepts many different option
  formats, each with its own benefits and drawbacks.
  
  B<NOTE:> The class being delegated to does not need to be a Moose based class,
  which is why this feature is especially useful when wrapping non-Moose classes.
  
  All I<handles> option formats share the following traits:
  
  You cannot override a locally defined method with a delegated method; an
  exception will be thrown if you try. That is to say, if you define C<foo> in
  your class, you cannot override it with a delegated C<foo>. This is almost never
  something you would want to do, and if it is, you should do it by hand and not
  use Moose.
  
  You cannot override any of the methods found in Moose::Object, or the C<BUILD>
  and C<DEMOLISH> methods. These will not throw an exception, but will silently
  move on to the next method in the list. My reasoning for this is that you would
  almost never want to do this, since it usually breaks your class. As with
  overriding locally defined methods, if you do want to do this, you should do it
  manually, not with Moose.
  
  You do not I<need> to have a reader (or accessor) for the attribute in order
  to delegate to it. Moose will create a means of accessing the value for you,
  however this will be several times B<less> efficient then if you had given
  the attribute a reader (or accessor) to use.
  
  Below is the documentation for each option format:
  
  =over 4
  
  =item C<ARRAY>
  
  This is the most common usage for I<handles>. You basically pass a list of
  method names to be delegated, and Moose will install a delegation method
  for each one.
  
  =item C<HASH>
  
  This is the second most common usage for I<handles>. Instead of a list of
  method names, you pass a HASH ref where each key is the method name you
  want installed locally, and its value is the name of the original method
  in the class being delegated to.
  
  This can be very useful for recursive classes like trees. Here is a
  quick example (soon to be expanded into a Moose::Cookbook recipe):
  
    package Tree;
    use Moose;
  
    has 'node' => (is => 'rw', isa => 'Any');
  
    has 'children' => (
        is      => 'ro',
        isa     => 'ArrayRef',
        default => sub { [] }
    );
  
    has 'parent' => (
        is          => 'rw',
        isa         => 'Tree',
        weak_ref    => 1,
        handles     => {
            parent_node => 'node',
            siblings    => 'children',
        }
    );
  
  In this example, the Tree package gets C<parent_node> and C<siblings> methods,
  which delegate to the C<node> and C<children> methods (respectively) of the Tree
  instance stored in the C<parent> slot.
  
  You may also use an array reference to curry arguments to the original method.
  
    has 'thing' => (
        ...
        handles => { set_foo => [ set => 'foo' ] },
    );
  
    # $self->set_foo(...) calls $self->thing->set('foo', ...)
  
  The first element of the array reference is the original method name, and the
  rest is a list of curried arguments.
  
  =item C<REGEXP>
  
  The regexp option works very similar to the ARRAY option, except that it builds
  the list of methods for you. It starts by collecting all possible methods of the
  class being delegated to, then filters that list using the regexp supplied here.
  
  B<NOTE:> An I<isa> option is required when using the regexp option format. This
  is so that we can determine (at compile time) the method list from the class.
  Without an I<isa> this is just not possible.
  
  =item C<ROLE> or C<ROLETYPE>
  
  With the role option, you specify the name of a role or a
  L<role type|Moose::Meta::TypeConstraint::Role> whose "interface" then becomes
  the list of methods to handle. The "interface" can be defined as; the methods
  of the role and any required methods of the role. It should be noted that this
  does B<not> include any method modifiers or generated attribute methods (which
  is consistent with role composition).
  
  =item C<DUCKTYPE>
  
  With the duck type option, you pass a duck type object whose "interface" then
  becomes the list of methods to handle. The "interface" can be defined as the
  list of methods passed to C<duck_type> to create a duck type object. For more
  information on C<duck_type> please check
  L<Moose::Util::TypeConstraints>.
  
  =item C<CODE>
  
  This is the option to use when you really want to do something funky. You should
  only use it if you really know what you are doing, as it involves manual
  metaclass twiddling.
  
  This takes a code reference, which should expect two arguments. The first is the
  attribute meta-object this I<handles> is attached to. The second is the
  metaclass of the class being delegated to. It expects you to return a hash (not
  a HASH ref) of the methods you want mapped.
  
  =back
  
  =item I<traits =E<gt> [ @role_names ]>
  
  This tells Moose to take the list of C<@role_names> and apply them to the
  attribute meta-object. Custom attribute metaclass traits are useful for
  extending the capabilities of the I<has> keyword: they are the simplest way to
  extend the MOP, but they are still a fairly advanced topic and too much to
  cover here.
  
  See L<Metaclass and Trait Name Resolution> for details on how a trait name is
  resolved to a role name.
  
  Also see L<Moose::Cookbook::Meta::Recipe3> for a metaclass trait
  example.
  
  =item I<builder> => Str
  
  The value of this key is the name of the method that will be called to
  obtain the value used to initialize the attribute. See the L<builder
  option docs in Class::MOP::Attribute|Class::MOP::Attribute/builder>
  and/or L<Moose::Cookbook::Basics::Recipe8> for more information.
  
  =item I<default> => SCALAR | CODE
  
  The value of this key is the default value which will initialize the attribute.
  
  NOTE: If the value is a simple scalar (string or number), then it can
  be just passed as is.  However, if you wish to initialize it with a
  HASH or ARRAY ref, then you need to wrap that inside a CODE reference.
  See the L<default option docs in
  Class::MOP::Attribute|Class::MOP::Attribute/default> for more
  information.
  
  =item I<clearer> => Str
  
  Creates a method allowing you to clear the value. See the L<clearer option
  docs in Class::MOP::Attribute|Class::MOP::Attribute/clearer> for more
  information.
  
  =item I<predicate> => Str
  
  Creates a method to perform a basic test to see if a value has been set in the
  attribute. See the L<predicate option docs in
  Class::MOP::Attribute|Class::MOP::Attribute/predicate> for more information.
  
  Note that the predicate will return true even for a C<weak_ref> attribute
  whose value has expired.
  
  =item I<documentation> => $string
  
  An arbitrary string that can be retrieved later by calling C<<
  $attr->documentation >>.
  
  =back
  
  =item B<has +$name =E<gt> %options>
  
  This is variation on the normal attribute creator C<has> which allows you to
  clone and extend an attribute from a superclass or from a role. Here is an
  example of the superclass usage:
  
    package Foo;
    use Moose;
  
    has 'message' => (
        is      => 'rw',
        isa     => 'Str',
        default => 'Hello, I am a Foo'
    );
  
    package My::Foo;
    use Moose;
  
    extends 'Foo';
  
    has '+message' => (default => 'Hello I am My::Foo');
  
  What is happening here is that B<My::Foo> is cloning the C<message> attribute
  from its parent class B<Foo>, retaining the C<is =E<gt> 'rw'> and C<isa =E<gt>
  'Str'> characteristics, but changing the value in C<default>.
  
  Here is another example, but within the context of a role:
  
    package Foo::Role;
    use Moose::Role;
  
    has 'message' => (
        is      => 'rw',
        isa     => 'Str',
        default => 'Hello, I am a Foo'
    );
  
    package My::Foo;
    use Moose;
  
    with 'Foo::Role';
  
    has '+message' => (default => 'Hello I am My::Foo');
  
  In this case, we are basically taking the attribute which the role supplied
  and altering it within the bounds of this feature.
  
  Note that you can only extend an attribute from either a superclass or a role,
  you cannot extend an attribute in a role that composes over an attribute from
  another role.
  
  Aside from where the attributes come from (one from superclass, the other
  from a role), this feature works exactly the same. This feature is restricted
  somewhat, so as to try and force at least I<some> sanity into it. Most options work the same, but there are some exceptions:
  
  =over 4
  
  =item I<reader>
  
  =item I<writer>
  
  =item I<accessor>
  
  =item I<clearer>
  
  =item I<predicate>
  
  These options can be added, but cannot override a superclass definition.
  
  =item I<traits>
  
  You are allowed to B<add> additional traits to the C<traits> definition.
  These traits will be composed into the attribute, but preexisting traits
  B<are not> overridden, or removed.
  
  =back
  
  =item B<before $name|@names|\@names|qr/.../ =E<gt> sub { ... }>
  
  =item B<after $name|@names|\@names|qr/.../ =E<gt> sub { ... }>
  
  =item B<around $name|@names|\@names|qr/.../ =E<gt> sub { ... }>
  
  These three items are syntactic sugar for the before, after, and around method
  modifier features that L<Class::MOP> provides. More information on these may be
  found in L<Moose::Manual::MethodModifiers> and the
  L<Class::MOP::Class documentation|Class::MOP::Class/"Method Modifiers">.
  
  =item B<override ($name, &sub)>
  
  An C<override> method is a way of explicitly saying "I am overriding this
  method from my superclass". You can call C<super> within this method, and
  it will work as expected. The same thing I<can> be accomplished with a normal
  method call and the C<SUPER::> pseudo-package; it is really your choice.
  
  =item B<super>
  
  The keyword C<super> is a no-op when called outside of an C<override> method. In
  the context of an C<override> method, it will call the next most appropriate
  superclass method with the same arguments as the original method.
  
  =item B<augment ($name, &sub)>
  
  An C<augment> method, is a way of explicitly saying "I am augmenting this
  method from my superclass". Once again, the details of how C<inner> and
  C<augment> work is best described in the L<Moose::Cookbook::Basics::Recipe6>.
  
  =item B<inner>
  
  The keyword C<inner>, much like C<super>, is a no-op outside of the context of
  an C<augment> method. You can think of C<inner> as being the inverse of
  C<super>; the details of how C<inner> and C<augment> work is best described in
  the L<Moose::Cookbook::Basics::Recipe6>.
  
  =item B<blessed>
  
  This is the C<Scalar::Util::blessed> function. It is highly recommended that
  this is used instead of C<ref> anywhere you need to test for an object's class
  name.
  
  =item B<confess>
  
  This is the C<Carp::confess> function, and exported here for historical
  reasons.
  
  =back
  
  =head1 METACLASS
  
  When you use Moose, you can specify traits which will be applied to your
  metaclass:
  
      use Moose -traits => 'My::Trait';
  
  This is very similar to the attribute traits feature. When you do
  this, your class's C<meta> object will have the specified traits
  applied to it. See L<Metaclass and Trait Name Resolution> for more
  details.
  
  =head2 Metaclass and Trait Name Resolution
  
  By default, when given a trait name, Moose simply tries to load a
  class of the same name. If such a class does not exist, it then looks
  for for a class matching
  B<Moose::Meta::$type::Custom::Trait::$trait_name>. The C<$type>
  variable here will be one of B<Attribute> or B<Class>, depending on
  what the trait is being applied to.
  
  If a class with this long name exists, Moose checks to see if it has
  the method C<register_implementation>. This method is expected to
  return the I<real> class name of the trait. If there is no
  C<register_implementation> method, it will fall back to using
  B<Moose::Meta::$type::Custom::Trait::$trait> as the trait name.
  
  The lookup method for metaclasses is the same, except that it looks
  for a class matching B<Moose::Meta::$type::Custom::$metaclass_name>.
  
  If all this is confusing, take a look at
  L<Moose::Cookbook::Meta::Recipe3>, which demonstrates how to create an
  attribute trait.
  
  =head1 UNIMPORTING FUNCTIONS
  
  =head2 B<unimport>
  
  Moose offers a way to remove the keywords it exports, through the C<unimport>
  method. You simply have to say C<no Moose> at the bottom of your code for this
  to work. Here is an example:
  
      package Person;
      use Moose;
  
      has 'first_name' => (is => 'rw', isa => 'Str');
      has 'last_name'  => (is => 'rw', isa => 'Str');
  
      sub full_name {
          my $self = shift;
          $self->first_name . ' ' . $self->last_name
      }
  
      no Moose; # keywords are removed from the Person package
  
  =head1 EXTENDING AND EMBEDDING MOOSE
  
  To learn more about extending Moose, we recommend checking out the
  "Extending" recipes in the L<Moose::Cookbook>, starting with
  L<Moose::Cookbook::Extending::Recipe1>, which provides an overview of
  all the different ways you might extend Moose. L<Moose::Exporter> and
  L<Moose::Util::MetaRole> are the modules which provide the majority of the
  extension functionality, so reading their documentation should also be helpful.
  
  =head2 The MooseX:: namespace
  
  Generally if you're writing an extension I<for> Moose itself you'll want
  to put your extension in the C<MooseX::> namespace. This namespace is
  specifically for extensions that make Moose better or different in some
  fundamental way. It is traditionally B<not> for a package that just happens
  to use Moose. This namespace follows from the examples of the C<LWPx::>
  and C<DBIx::> namespaces that perform the same function for C<LWP> and C<DBI>
  respectively.
  
  =head1 METACLASS COMPATIBILITY AND MOOSE
  
  Metaclass compatibility is a thorny subject. You should start by
  reading the "About Metaclass compatibility" section in the
  C<Class::MOP> docs.
  
  Moose will attempt to resolve a few cases of metaclass incompatibility
  when you set the superclasses for a class, in addition to the cases that
  C<Class::MOP> handles.
  
  Moose tries to determine if the metaclasses only "differ by roles". This
  means that the parent and child's metaclass share a common ancestor in
  their respective hierarchies, and that the subclasses under the common
  ancestor are only different because of role applications. This case is
  actually fairly common when you mix and match various C<MooseX::*>
  modules, many of which apply roles to the metaclass.
  
  If the parent and child do differ by roles, Moose replaces the
  metaclass in the child with a newly created metaclass. This metaclass
  is a subclass of the parent's metaclass which does all of the roles that
  the child's metaclass did before being replaced. Effectively, this
  means the new metaclass does all of the roles done by both the
  parent's and child's original metaclasses.
  
  Ultimately, this is all transparent to you except in the case of an
  unresolvable conflict.
  
  =head1 CAVEATS
  
  =over 4
  
  =item *
  
  It should be noted that C<super> and C<inner> B<cannot> be used in the same
  method. However, they may be combined within the same class hierarchy; see
  F<t/basics/override_augment_inner_super.t> for an example.
  
  The reason for this is that C<super> is only valid within a method
  with the C<override> modifier, and C<inner> will never be valid within an
  C<override> method. In fact, C<augment> will skip over any C<override> methods
  when searching for its appropriate C<inner>.
  
  This might seem like a restriction, but I am of the opinion that keeping these
  two features separate (yet interoperable) actually makes them easy to use, since
  their behavior is then easier to predict. Time will tell whether I am right or
  not (UPDATE: so far so good).
  
  =back
  
  =head1 GETTING HELP
  
  We offer both a mailing list and a very active IRC channel.
  
  The mailing list is L<moose@perl.org>. You must be subscribed to send
  a message. To subscribe, send an empty message to
  L<moose-subscribe@perl.org>
  
  You can also visit us at C<#moose> on L<irc://irc.perl.org/#moose>
  This channel is quite active, and questions at all levels (on Moose-related
  topics ;) are welcome.
  
  =head1 ACKNOWLEDGEMENTS
  
  =over 4
  
  =item I blame Sam Vilain for introducing me to the insanity that is meta-models.
  
  =item I blame Audrey Tang for then encouraging my meta-model habit in #perl6.
  
  =item Without Yuval "nothingmuch" Kogman this module would not be possible,
  and it certainly wouldn't have this name ;P
  
  =item The basis of the TypeContraints module was Rob Kinyon's idea
  originally, I just ran with it.
  
  =item Thanks to mst & chansen and the whole #moose posse for all the
  early ideas/feature-requests/encouragement/bug-finding.
  
  =item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes.
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<http://www.iinteractive.com/moose>
  
  This is the official web home of Moose. It contains links to our public git
  repository, as well as links to a number of talks and articles on Moose and
  Moose related technologies.
  
  =item the L<Moose manual|Moose::Manual>
  
  This is an introduction to Moose which covers most of the basics.
  
  =item Modern Perl, by chromatic
  
  This is an introduction to modern Perl programming, which includes a section on
  Moose. It is available in print and as a free download from
  L<http://onyxneon.com/books/modern_perl/>.
  
  =item The Moose is flying, a tutorial by Randal Schwartz
  
  Part 1 - L<http://www.stonehenge.com/merlyn/LinuxMag/col94.html>
  
  Part 2 - L<http://www.stonehenge.com/merlyn/LinuxMag/col95.html>
  
  =item Several Moose extension modules in the C<MooseX::> namespace.
  
  See L<http://search.cpan.org/search?query=MooseX::> for extensions.
  
  =back
  
  =head2 Books
  
  =over 4
  
  =item The Art of the MetaObject Protocol
  
  I mention this in the L<Class::MOP> docs too, as this book was critical in
  the development of both modules and is highly recommended.
  
  =back
  
  =head2 Papers
  
  =over 4
  
  =item L<http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf>
  
  This paper (suggested by lbr on #moose) was what lead to the implementation
  of the C<super>/C<override> and C<inner>/C<augment> features. If you really
  want to understand them, I suggest you read this.
  
  =back
  
  =head1 BUGS
  
  All complex software has bugs lurking in it, and this module is no
  exception.
  
  Please report any bugs to C<bug-moose@rt.cpan.org>, or through the web
  interface at L<http://rt.cpan.org>.
  
  You can also discuss feature requests or possible bugs on the Moose mailing
  list (moose@perl.org) or on IRC at L<irc://irc.perl.org/#moose>.
  
  =head1 FEATURE REQUESTS
  
  We are very strict about what features we add to the Moose core, especially
  the user-visible features. Instead we have made sure that the underlying
  meta-system of Moose is as extensible as possible so that you can add your
  own features easily.
  
  That said, occasionally there is a feature needed in the meta-system
  to support your planned extension, in which case you should either
  email the mailing list (moose@perl.org) or join us on IRC at
  L<irc://irc.perl.org/#moose> to discuss. The
  L<Moose::Manual::Contributing> has more detail about how and when you
  can contribute.
  
  =head1 CABAL
  
  There are only a few people with the rights to release a new version
  of Moose. The Moose Cabal are the people to go to with questions regarding
  the wider purview of Moose. They help maintain not just the code
  but the community as well.
  
  Stevan (stevan) Little E<lt>stevan@iinteractive.comE<gt>
  
  Jesse (doy) Luehrs E<lt>doy at tozt dot netE<gt>
  
  Yuval (nothingmuch) Kogman
  
  Shawn (sartak) Moore E<lt>sartak@bestpractical.comE<gt>
  
  Hans Dieter (confound) Pearcey E<lt>hdp@pobox.comE<gt>
  
  Chris (perigrin) Prather
  
  Florian Ragwitz E<lt>rafl@debian.orgE<gt>
  
  Dave (autarch) Rolsky E<lt>autarch@urth.orgE<gt>
  
  =head1 CONTRIBUTORS
  
  Moose is a community project, and as such, involves the work of many, many
  members of the community beyond just the members in the cabal. In particular:
  
  Dave (autarch) Rolsky wrote most of the documentation in L<Moose::Manual>.
  
  John (jgoulah) Goulah wrote L<Moose::Cookbook::Snack::Keywords>.
  
  Jess (castaway) Robinson wrote L<Moose::Cookbook::Snack::Types>.
  
  Aran (bluefeet) Clary Deltac wrote L<Moose::Cookbook::Basics::Recipe9>.
  
  Anders (Debolaz) Nor Berle contributed L<Test::Moose> and L<Moose::Util>.
  
  Also, the code in L<Moose::Meta::Attribute::Native> is based on code from the
  L<MooseX::AttributeHelpers> distribution, which had contributions from:
  
  Chris (perigrin) Prather
  
  Cory (gphat) Watson
  
  Evan Carroll
  
  Florian (rafl) Ragwitz
  
  Jason May
  
  Jay Hannah
  
  Jesse (doy) Luehrs
  
  Paul (frodwith) Driver
  
  Robert (rlb3) Boone
  
  Robert Buels
  
  Robert (phaylon) Sedlacek
  
  Shawn (Sartak) Moore
  
  Stevan Little
  
  Tom (dec) Lanyon
  
  Yuval Kogman
  
  Finally, these people also contributed various tests, bug fixes,
  documentation, and features to the Moose codebase:
  
  Aankhen
  
  Adam (Alias) Kennedy
  
  Christian (chansen) Hansen
  
  Cory (gphat) Watson
  
  Dylan Hardison (doc fixes)
  
  Eric (ewilhelm) Wilhelm
  
  Evan Carroll
  
  Guillermo (groditi) Roditi
  
  Jason May
  
  Jay Hannah
  
  Jonathan (jrockway) Rockway
  
  Matt (mst) Trout
  
  Nathan (kolibrie) Gray
  
  Paul (frodwith) Driver
  
  Piotr (dexter) Roszatycki
  
  Robert Buels
  
  Robert (phaylon) Sedlacek
  
  Robert (rlb3) Boone
  
  Sam (mugwump) Vilain
  
  Scott (konobi) McWhirter
  
  Shlomi (rindolf) Fish
  
  Tom (dec) Lanyon
  
  Wallace (wreis) Reis
  
  ... and many other #moose folks
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE

$fatpacked{"darwin-thread-multi-2level/Moose/Conflicts.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_CONFLICTS';
  package # hide from PAUSE
      Moose::Conflicts;
  
  use strict;
  use warnings;
  
  use Dist::CheckConflicts
      -dist      => 'Moose',
      -conflicts => {
          'Catalyst' => '5.80028',
          'Devel::REPL' => '1.003008',
          'Fey' => '0.36',
          'Fey::ORM' => '0.42',
          'File::ChangeNotify' => '0.15',
          'KiokuDB' => '0.51',
          'Markdent' => '0.16',
          'MooseX::Aliases' => '0.08',
          'MooseX::AlwaysCoerce' => '0.13',
          'MooseX::Attribute::Deflator' => '2.1.7',
          'MooseX::Attribute::Dependent' => '1.1.0',
          'MooseX::Attribute::Prototype' => '0.10',
          'MooseX::AttributeHelpers' => '0.22',
          'MooseX::AttributeIndexes' => '1.0.0',
          'MooseX::AttributeInflate' => '0.02',
          'MooseX::CascadeClearing' => '0.03',
          'MooseX::ClassAttribute' => '0.25',
          'MooseX::Constructor::AllErrors' => '0.012',
          'MooseX::FollowPBP' => '0.02',
          'MooseX::HasDefaults' => '0.02',
          'MooseX::InstanceTracking' => '0.04',
          'MooseX::LazyRequire' => '0.06',
          'MooseX::Meta::Attribute::Index' => '0.04',
          'MooseX::Meta::Attribute::Lvalue' => '0.05',
          'MooseX::MethodAttributes' => '0.22',
          'MooseX::NonMoose' => '0.17',
          'MooseX::POE' => '0.211',
          'MooseX::Params::Validate' => '0.05',
          'MooseX::PrivateSetters' => '0.03',
          'MooseX::Role::Cmd' => '0.06',
          'MooseX::Role::Parameterized' => '0.23',
          'MooseX::Role::WithOverloading' => '0.07',
          'MooseX::SemiAffordanceAccessor' => '0.05',
          'MooseX::SetOnce' => '0.100473',
          'MooseX::Singleton' => '0.25',
          'MooseX::SlurpyConstructor' => '1.1',
          'MooseX::StrictConstructor' => '0.12',
          'MooseX::Types' => '0.19',
          'MooseX::Types::Parameterizable' => '0.05',
          'MooseX::Types::Signal' => '1.101930',
          'MooseX::UndefTolerant' => '0.11',
          'PRANG' => '0.14',
          'Pod::Elemental' => '0.093280',
          'Reaction' => '0.002003',
          'Test::Able' => '0.10',
          'namespace::autoclean' => '0.08',
      },
      -also => [ qw(
          Class::Load
          Class::Load::XS
          Data::OptList
          Devel::GlobalDestruction
          Dist::CheckConflicts
          Eval::Closure
          List::MoreUtils
          MRO::Compat
          Package::DeprecationManager
          Package::Stash
          Package::Stash::XS
          Params::Util
          Scalar::Util
          Sub::Exporter
          Sub::Name
          Task::Weaken
          Try::Tiny
      ) ],
  
  ;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_CONFLICTS

$fatpacked{"darwin-thread-multi-2level/Moose/Deprecated.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_DEPRECATED';
  package Moose::Deprecated;
  BEGIN {
    $Moose::Deprecated::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Deprecated::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Package::DeprecationManager 0.07 -deprecations => {
      'optimized type constraint sub ref' => '2.0000',
      'default is for Native Trait'       => '1.14',
      'default default for Native Trait'  => '1.14',
      'coerce without coercion'           => '1.08',
      },
      -ignore => [qr/^(?:Class::MOP|Moose)(?:::)?/],
      ;
  
  1;
  
  # ABSTRACT: Manages deprecation warnings for Moose
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Deprecated - Manages deprecation warnings for Moose
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
      use Moose::Deprecated -api_version => $version;
  
  =head1 FUNCTIONS
  
  This module manages deprecation warnings for features that have been
  deprecated in Moose.
  
  If you specify C<< -api_version => $version >>, you can use deprecated features
  without warnings. Note that this special treatment is limited to the package
  that loads C<Moose::Deprecated>.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_DEPRECATED

$fatpacked{"darwin-thread-multi-2level/Moose/Error/Confess.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_CONFESS';
  package Moose::Error::Confess;
  BEGIN {
    $Moose::Error::Confess::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Error::Confess::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base qw(Moose::Error::Default);
  
  sub new {
      my ( $self, @args ) = @_;
      $self->create_error_confess(@args);
  }
  
  sub _inline_new {
      my ( $self, %args ) = @_;
  
      my $depth = ($args{depth} || 0) - 1;
      return 'Moose::Error::Util::create_error_confess('
        . 'message => ' . $args{message} . ', '
        . 'depth   => ' . $depth         . ', '
    . ')';
  }
  
  1;
  
  # ABSTRACT: Prefer C<confess>
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Error::Confess - Prefer C<confess>
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
      # Metaclass definition must come before Moose is used.
      use metaclass (
          metaclass => 'Moose::Meta::Class',
          error_class => 'Moose::Error::Confess',
      );
      use Moose;
      # ...
  
  =head1 DESCRIPTION
  
  This error class uses L<Carp/confess> to raise errors generated in your
  metaclass.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_CONFESS

$fatpacked{"darwin-thread-multi-2level/Moose/Error/Croak.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_CROAK';
  package Moose::Error::Croak;
  BEGIN {
    $Moose::Error::Croak::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Error::Croak::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base qw(Moose::Error::Default);
  
  sub new {
      my ( $self, @args ) = @_;
      $self->create_error_croak(@args);
  }
  
  sub _inline_new {
      my ( $self, %args ) = @_;
  
      my $depth = ($args{depth} || 0) - 1;
      return 'Moose::Error::Util::create_error_croak('
        . 'message => ' . $args{message} . ', '
        . 'depth   => ' . $depth         . ', '
    . ')';
  }
  
  1;
  
  # ABSTRACT: Prefer C<croak>
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Error::Croak - Prefer C<croak>
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
      # Metaclass definition must come before Moose is used.
      use metaclass (
          metaclass => 'Moose::Meta::Class',
          error_class => 'Moose::Error::Croak',
      );
      use Moose;
      # ...
  
  =head1 DESCRIPTION
  
  This error class uses L<Carp/croak> to raise errors generated in your
  metaclass.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
  Overrides L<Moose::Error::Default/new> to prefer C<croak>.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_CROAK

$fatpacked{"darwin-thread-multi-2level/Moose/Error/Default.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_DEFAULT';
  package Moose::Error::Default;
  BEGIN {
    $Moose::Error::Default::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Error::Default::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp::Heavy;
  use Class::MOP::MiniTrait;
  
  use Moose::Error::Util;
  
  use base 'Class::MOP::Object';
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  sub new {
      my ( $self, @args ) = @_;
      # can't use Moose::Error::Util::create_error here because that would break
      # inheritance. we don't care about that for the inlined version, because
      # the inlined versions are explicitly not inherited.
      if (defined $ENV{MOOSE_ERROR_STYLE} && $ENV{MOOSE_ERROR_STYLE} eq 'croak') {
          $self->create_error_croak( @args );
      }
      else {
          $self->create_error_confess( @args );
      }
  }
  
  sub _inline_new {
      my ( $self, %args ) = @_;
  
      my $depth = ($args{depth} || 0) - 1;
      return 'Moose::Error::Util::create_error('
        . 'message => ' . $args{message} . ', '
        . 'depth   => ' . $depth         . ', '
    . ')';
  }
  
  sub create_error_croak {
      my ( $self, @args ) = @_;
      return Moose::Error::Util::create_error_croak(@args);
  }
  
  sub create_error_confess {
      my ( $self, @args ) = @_;
      return Moose::Error::Util::create_error_confess(@args);
  }
  
  1;
  
  # ABSTRACT: L<Carp> based error generation for Moose.
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Error::Default - L<Carp> based error generation for Moose.
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements L<Carp> based error generation.
  
  The default behavior is like L<Moose::Error::Confess>. To override this to
  default to L<Moose::Error::Croak>'s behaviour on a system wide basis, set the
  MOOSE_ERROR_STYLE environment variable to C<croak>. The use of this
  environment variable is considered experimental, and may change in a future
  release.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Error::Default->new(@args) >>
  
  Create a new error. Delegates to C<create_error_confess> or
  C<create_error_croak>.
  
  =item B<< $error->create_error_confess(@args) >>
  
  =item B<< $error->create_error_croak(@args) >>
  
  Creates a new errors string of the specified style.
  
  =back
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_DEFAULT

$fatpacked{"darwin-thread-multi-2level/Moose/Error/Util.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_UTIL';
  package # pretend this doesn't exist, because it shouldn't
      Moose::Error::Util;
  
  use strict;
  use warnings;
  
  # this intentionally exists to have a place to put this logic that doesn't
  # involve loading Class::MOP, so... don't do that
  
  use Carp::Heavy;
  
  sub _create_error_carpmess {
      my %args = @_;
  
      my $carp_level = 3 + ( $args{depth} || 0 );
      local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
  
      my @args = exists $args{message} ? $args{message} : ();
  
      if ( $args{longmess} || $Carp::Verbose ) {
          local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $carp_level;
          return Carp::longmess(@args);
      } else {
          return Carp::ret_summary($carp_level, @args);
      }
  }
  
  sub create_error_croak {
      _create_error_carpmess(@_);
  }
  
  sub create_error_confess {
      _create_error_carpmess(@_, longmess => 1);
  }
  
  sub create_error {
      if (defined $ENV{MOOSE_ERROR_STYLE} && $ENV{MOOSE_ERROR_STYLE} eq 'croak') {
          create_error_croak(@_);
      }
      else {
          create_error_confess(@_);
      }
  }
  
  1;
  
  __END__
  
  =pod
  
  =for pod_coverage_needs_some_pod
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ERROR_UTIL

$fatpacked{"darwin-thread-multi-2level/Moose/Exporter.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_EXPORTER';
  package Moose::Exporter;
  BEGIN {
    $Moose::Exporter::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Exporter::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw(is_class_loaded);
  use Class::MOP;
  use List::MoreUtils qw( first_index uniq );
  use Moose::Util::MetaRole;
  use Scalar::Util qw(reftype);
  use Sub::Exporter 0.980;
  use Sub::Name qw(subname);
  
  my %EXPORT_SPEC;
  
  sub setup_import_methods {
      my ( $class, %args ) = @_;
  
      $args{exporting_package} ||= caller();
  
      $class->build_import_methods(
          %args,
          install => [qw(import unimport init_meta)]
      );
  }
  
  sub build_import_methods {
      my ( $class, %args ) = @_;
  
      my $exporting_package = $args{exporting_package} ||= caller();
  
      my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) };
  
      $EXPORT_SPEC{$exporting_package} = \%args;
  
      my @exports_from = $class->_follow_also($exporting_package);
  
      my $export_recorder = {};
      my $is_reexport     = {};
  
      my $exports = $class->_make_sub_exporter_params(
          [ @exports_from, $exporting_package ],
          $export_recorder,
          $is_reexport,
          $meta_lookup,
      );
  
      my $exporter = $class->_make_exporter(
          $exports,
          $is_reexport,
          $meta_lookup,
      );
  
      my %methods;
      $methods{import} = $class->_make_import_sub(
          $exporting_package,
          $exporter,
          \@exports_from,
          $is_reexport,
          $meta_lookup,
      );
  
      $methods{unimport} = $class->_make_unimport_sub(
          $exporting_package,
          $exports,
          $export_recorder,
          $is_reexport,
          $meta_lookup,
      );
  
      $methods{init_meta} = $class->_make_init_meta(
          $exporting_package,
          \%args,
          $meta_lookup,
      );
  
      my $package = Class::MOP::Package->initialize($exporting_package);
      for my $to_install ( @{ $args{install} || [] } ) {
          my $symbol = '&' . $to_install;
          next
              unless $methods{$to_install}
                  && !$package->has_package_symbol($symbol);
          $package->add_package_symbol( $symbol, $methods{$to_install} );
      }
  
      return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
  }
  
  sub _make_exporter {
      my ($class, $exports, $is_reexport, $meta_lookup) = @_;
  
      return Sub::Exporter::build_exporter(
          {
              exports   => $exports,
              groups    => { default => [':all'] },
              installer => sub {
                  my ($arg, $to_export) = @_;
                  my $meta = $meta_lookup->($arg->{into});
  
                  goto &Sub::Exporter::default_installer unless $meta;
  
                  # don't overwrite existing symbols with our magically flagged
                  # version of it if we would install the same sub that's already
                  # in the importer
  
                  my @filtered_to_export;
                  my %installed;
                  for (my $i = 0; $i < @{ $to_export }; $i += 2) {
                      my ($as, $cv) = @{ $to_export }[$i, $i + 1];
  
                      next if !ref($as)
                           && $meta->has_package_symbol('&' . $as)
                           && $meta->get_package_symbol('&' . $as) == $cv;
  
                      push @filtered_to_export, $as, $cv;
                      $installed{$as} = 1 unless ref $as;
                  }
  
                  Sub::Exporter::default_installer($arg, \@filtered_to_export);
  
                  for my $name ( keys %{$is_reexport} ) {
                      no strict 'refs';
                      no warnings 'once';
                      next unless exists $installed{$name};
                      _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } );
                  }
              },
          }
      );
  }
  
  {
      my $seen = {};
  
      sub _follow_also {
          my $class             = shift;
          my $exporting_package = shift;
  
          local %$seen = ( $exporting_package => 1 );
  
          return reverse uniq( _follow_also_real($exporting_package) );
      }
  
      sub _follow_also_real {
          my $exporting_package = shift;
  
          if ( !exists $EXPORT_SPEC{$exporting_package} ) {
              my $loaded = is_class_loaded($exporting_package);
  
              die "Package in also ($exporting_package) does not seem to "
                  . "use Moose::Exporter"
                  . ( $loaded ? "" : " (is it loaded?)" );
          }
  
          my $also = $EXPORT_SPEC{$exporting_package}{also};
  
          return unless defined $also;
  
          my @also = ref $also ? @{$also} : $also;
  
          for my $package (@also) {
              die
                  "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package"
                  if $seen->{$package};
  
              $seen->{$package} = 1;
          }
  
          return @also, map { _follow_also_real($_) } @also;
      }
  }
  
  sub _parse_trait_aliases {
      my $class   = shift;
      my ($package, $aliases) = @_;
  
      my @ret;
      for my $alias (@$aliases) {
          my $name;
          if (ref($alias)) {
              reftype($alias) eq 'ARRAY'
                  or Moose->throw_error(reftype($alias) . " references are not "
                                      . "valid arguments to the 'trait_aliases' "
                                      . "option");
  
              ($alias, $name) = @$alias;
          }
          else {
              ($name = $alias) =~ s/.*:://;
          }
          push @ret, subname "${package}::${name}" => sub () { $alias };
      }
  
      return @ret;
  }
  
  sub _make_sub_exporter_params {
      my $class           = shift;
      my $packages        = shift;
      my $export_recorder = shift;
      my $is_reexport     = shift;
      my $meta_lookup     = shift;
  
      my %exports;
  
      for my $package ( @{$packages} ) {
          my $args = $EXPORT_SPEC{$package}
              or die "The $package package does not use Moose::Exporter\n";
  
          for my $name ( @{ $args->{with_meta} } ) {
              my $sub = $class->_sub_from_package( $package, $name )
                  or next;
  
              my $fq_name = $package . '::' . $name;
  
              $exports{$name} = $class->_make_wrapped_sub_with_meta(
                  $fq_name,
                  $sub,
                  $export_recorder,
                  $meta_lookup,
              );
          }
  
          for my $name ( @{ $args->{with_caller} } ) {
              my $sub = $class->_sub_from_package( $package, $name )
                  or next;
  
              my $fq_name = $package . '::' . $name;
  
              $exports{$name} = $class->_make_wrapped_sub(
                  $fq_name,
                  $sub,
                  $export_recorder,
              );
          }
  
          my @extra_exports = $class->_parse_trait_aliases(
              $package, $args->{trait_aliases},
          );
          for my $name ( @{ $args->{as_is} }, @extra_exports ) {
              my ( $sub, $coderef_name );
  
              if ( ref $name ) {
                  $sub = $name;
  
                  my $coderef_pkg;
                  ( $coderef_pkg, $coderef_name )
                      = Class::MOP::get_code_info($name);
  
                  if ( $coderef_pkg ne $package ) {
                      $is_reexport->{$coderef_name} = 1;
                  }
              }
              else {
                  $sub = $class->_sub_from_package( $package, $name )
                      or next;
  
                  $coderef_name = $name;
              }
  
              $export_recorder->{$sub} = 1;
  
              $exports{$coderef_name} = sub {$sub};
          }
      }
  
      return \%exports;
  }
  
  sub _sub_from_package {
      my $sclass  = shift;
      my $package = shift;
      my $name    = shift;
  
      my $sub = do {
          no strict 'refs';
          \&{ $package . '::' . $name };
      };
  
      return $sub if defined &$sub;
  
      Carp::cluck "Trying to export undefined sub ${package}::${name}";
  
      return;
  }
  
  our $CALLER;
  
  sub _make_wrapped_sub {
      my $self            = shift;
      my $fq_name         = shift;
      my $sub             = shift;
      my $export_recorder = shift;
  
      # We need to set the package at import time, so that when
      # package Foo imports has(), we capture "Foo" as the
      # package. This lets other packages call Foo::has() and get
      # the right package. This is done for backwards compatibility
      # with existing production code, not because this is a good
      # idea ;)
      return sub {
          my $caller = $CALLER;
  
          my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller );
  
          my $sub = subname( $fq_name => $wrapper );
  
          $export_recorder->{$sub} = 1;
  
          return $sub;
      };
  }
  
  sub _make_wrapped_sub_with_meta {
      my $self            = shift;
      my $fq_name         = shift;
      my $sub             = shift;
      my $export_recorder = shift;
      my $meta_lookup     = shift;
  
      return sub {
          my $caller = $CALLER;
  
          my $wrapper = $self->_late_curry_wrapper(
              $sub, $fq_name,
              $meta_lookup => $caller
          );
  
          my $sub = subname( $fq_name => $wrapper );
  
          $export_recorder->{$sub} = 1;
  
          return $sub;
      };
  }
  
  sub _curry_wrapper {
      my $class   = shift;
      my $sub     = shift;
      my $fq_name = shift;
      my @extra   = @_;
  
      my $wrapper = sub { $sub->( @extra, @_ ) };
      if ( my $proto = prototype $sub ) {
  
          # XXX - Perl's prototype sucks. Use & to make set_prototype
          # ignore the fact that we're passing "private variables"
          &Scalar::Util::set_prototype( $wrapper, $proto );
      }
      return $wrapper;
  }
  
  sub _late_curry_wrapper {
      my $class   = shift;
      my $sub     = shift;
      my $fq_name = shift;
      my $extra   = shift;
      my @ex_args = @_;
  
      my $wrapper = sub {
  
          # resolve curried arguments at runtime via this closure
          my @curry = ( $extra->(@ex_args) );
          return $sub->( @curry, @_ );
      };
  
      if ( my $proto = prototype $sub ) {
  
          # XXX - Perl's prototype sucks. Use & to make set_prototype
          # ignore the fact that we're passing "private variables"
          &Scalar::Util::set_prototype( $wrapper, $proto );
      }
      return $wrapper;
  }
  
  sub _make_import_sub {
      shift;
      my $exporting_package = shift;
      my $exporter          = shift;
      my $exports_from      = shift;
      my $is_reexport       = shift;
      my $meta_lookup       = shift;
  
      return sub {
  
          # I think we could use Sub::Exporter's collector feature
          # to do this, but that would be rather gross, since that
          # feature isn't really designed to return a value to the
          # caller of the exporter sub.
          #
          # Also, this makes sure we preserve backwards compat for
          # _get_caller, so it always sees the arguments in the
          # expected order.
          my $traits;
          ( $traits, @_ ) = _strip_traits(@_);
  
          my $metaclass;
          ( $metaclass, @_ ) = _strip_metaclass(@_);
          $metaclass
              = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass )
              if defined $metaclass && length $metaclass;
  
          my $meta_name;
          ( $meta_name, @_ ) = _strip_meta_name(@_);
  
          # Normally we could look at $_[0], but in some weird cases
          # (involving goto &Moose::import), $_[0] ends as something
          # else (like Squirrel).
          my $class = $exporting_package;
  
          $CALLER = _get_caller(@_);
  
          # this works because both pragmas set $^H (see perldoc
          # perlvar) which affects the current compilation -
          # i.e. the file who use'd us - which is why we don't need
          # to do anything special to make it affect that file
          # rather than this one (which is already compiled)
  
          strict->import;
          warnings->import;
  
          my $did_init_meta;
          for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
  
              # init_meta can apply a role, which when loaded uses
              # Moose::Exporter, which in turn sets $CALLER, so we need
              # to protect against that.
              local $CALLER = $CALLER;
              $c->init_meta(
                  for_class => $CALLER,
                  metaclass => $metaclass,
                  meta_name => $meta_name,
              );
              $did_init_meta = 1;
          }
  
          if ( $did_init_meta && @{$traits} ) {
  
              # The traits will use Moose::Role, which in turn uses
              # Moose::Exporter, which in turn sets $CALLER, so we need
              # to protect against that.
              local $CALLER = $CALLER;
              _apply_meta_traits( $CALLER, $traits, $meta_lookup );
          }
          elsif ( @{$traits} ) {
              require Moose;
              Moose->throw_error(
                  "Cannot provide traits when $class does not have an init_meta() method"
              );
          }
  
          my ( undef, @args ) = @_;
          my $extra = shift @args if ref $args[0] eq 'HASH';
  
          $extra ||= {};
          if ( !$extra->{into} ) {
              $extra->{into_level} ||= 0;
              $extra->{into_level}++;
          }
  
          $class->$exporter( $extra, @args );
      };
  }
  
  sub _strip_traits {
      my $idx = first_index { ( $_ || '' ) eq '-traits' } @_;
  
      return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
  
      my $traits = $_[ $idx + 1 ];
  
      splice @_, $idx, 2;
  
      $traits = [$traits] unless ref $traits;
  
      return ( $traits, @_ );
  }
  
  sub _strip_metaclass {
      my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_;
  
      return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
  
      my $metaclass = $_[ $idx + 1 ];
  
      splice @_, $idx, 2;
  
      return ( $metaclass, @_ );
  }
  
  sub _strip_meta_name {
      my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_;
  
      return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
  
      my $meta_name = $_[ $idx + 1 ];
  
      splice @_, $idx, 2;
  
      return ( $meta_name, @_ );
  }
  
  sub _apply_meta_traits {
      my ( $class, $traits, $meta_lookup ) = @_;
  
      return unless @{$traits};
  
      my $meta = $meta_lookup->($class);
  
      my $type = ( split /::/, ref $meta )[-1]
          or Moose->throw_error(
          'Cannot determine metaclass type for trait application . Meta isa '
              . ref $meta );
  
      my @resolved_traits = map {
          ref $_
              ? $_
              : Moose::Util::resolve_metatrait_alias( $type => $_ )
      } @$traits;
  
      return unless @resolved_traits;
  
      my %args = ( for => $class );
  
      if ( $meta->isa('Moose::Meta::Role') ) {
          $args{role_metaroles} = { role => \@resolved_traits };
      }
      else {
          $args{class_metaroles} = { class => \@resolved_traits };
      }
  
      Moose::Util::MetaRole::apply_metaroles(%args);
  }
  
  sub _get_caller {
  
      # 1 extra level because it's called by import so there's a layer
      # of indirection
      my $offset = 1;
  
      return
            ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
          : ( ref $_[1] && defined $_[1]->{into_level} )
          ? caller( $offset + $_[1]->{into_level} )
          : caller($offset);
  }
  
  sub _make_unimport_sub {
      shift;
      my $exporting_package = shift;
      my $exports           = shift;
      my $export_recorder   = shift;
      my $is_reexport       = shift;
      my $meta_lookup       = shift;
  
      return sub {
          my $caller = scalar caller();
          Moose::Exporter->_remove_keywords(
              $caller,
              [ keys %{$exports} ],
              $export_recorder,
              $is_reexport,
          );
      };
  }
  
  sub _remove_keywords {
      shift;
      my $package          = shift;
      my $keywords         = shift;
      my $recorded_exports = shift;
      my $is_reexport      = shift;
  
      no strict 'refs';
  
      foreach my $name ( @{$keywords} ) {
          if ( defined &{ $package . '::' . $name } ) {
              my $sub = \&{ $package . '::' . $name };
  
              # make sure it is from us
              next unless $recorded_exports->{$sub};
  
              if ( $is_reexport->{$name} ) {
                  no strict 'refs';
                  next
                      unless _export_is_flagged(
                              \*{ join q{::} => $package, $name } );
              }
  
              # and if it is from us, then undef the slot
              delete ${ $package . '::' }{$name};
          }
      }
  }
  
  sub _make_init_meta {
      shift;
      my $class          = shift;
      my $args           = shift;
      my $meta_lookup    = shift;
  
      my %old_style_roles;
      for my $role (
          map {"${_}_roles"}
          qw(
          metaclass
          attribute_metaclass
          method_metaclass
          wrapped_method_metaclass
          instance_metaclass
          constructor_class
          destructor_class
          error_class
          )
          ) {
          $old_style_roles{$role} = $args->{$role}
              if exists $args->{$role};
      }
  
      my %base_class_roles;
      %base_class_roles = ( roles => $args->{base_class_roles} )
          if exists $args->{base_class_roles};
  
      my %new_style_roles = map { $_ => $args->{$_} }
          grep { exists $args->{$_} } qw( class_metaroles role_metaroles );
  
      return unless %new_style_roles || %old_style_roles || %base_class_roles;
  
      return sub {
          shift;
          my %options = @_;
  
          return unless $meta_lookup->( $options{for_class} );
  
          if ( %new_style_roles || %old_style_roles ) {
              Moose::Util::MetaRole::apply_metaroles(
                  for => $options{for_class},
                  %new_style_roles,
                  %old_style_roles,
              );
          }
  
          Moose::Util::MetaRole::apply_base_class_roles(
              for_class => $options{for_class},
              %base_class_roles,
              )
              if $meta_lookup->( $options{for_class} )
                  ->isa('Moose::Meta::Class');
  
          return $meta_lookup->( $options{for_class} );
      };
  }
  
  sub import {
      strict->import;
      warnings->import;
  }
  
  1;
  
  # ABSTRACT: make an import() and unimport() just like Moose.pm
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Exporter - make an import() and unimport() just like Moose.pm
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyApp::Moose;
  
    use Moose ();
    use Moose::Exporter;
  
    Moose::Exporter->setup_import_methods(
        with_meta => [ 'has_rw', 'sugar2' ],
        as_is     => [ 'sugar3', \&Some::Random::thing ],
        also      => 'Moose',
    );
  
    sub has_rw {
        my ( $meta, $name, %options ) = @_;
        $meta->add_attribute(
            $name,
            is => 'rw',
            %options,
        );
    }
  
    # then later ...
    package MyApp::User;
  
    use MyApp::Moose;
  
    has 'name';
    has_rw 'size';
    thing;
  
    no MyApp::Moose;
  
  =head1 DESCRIPTION
  
  This module encapsulates the exporting of sugar functions in a
  C<Moose.pm>-like manner. It does this by building custom C<import>,
  C<unimport>, and C<init_meta> methods for your module, based on a spec you
  provide.
  
  It also lets you "stack" Moose-alike modules so you can export Moose's sugar
  as well as your own, along with sugar from any random C<MooseX> module, as
  long as they all use C<Moose::Exporter>. This feature exists to let you bundle
  a set of MooseX modules into a policy module that developers can use directly
  instead of using Moose itself.
  
  To simplify writing exporter modules, C<Moose::Exporter> also imports
  C<strict> and C<warnings> into your exporter module, as well as into
  modules that use it.
  
  =head1 METHODS
  
  This module provides two public methods:
  
  =over 4
  
  =item B<< Moose::Exporter->setup_import_methods(...) >>
  
  When you call this method, C<Moose::Exporter> builds custom C<import>,
  C<unimport>, and C<init_meta> methods for your module. The C<import> method
  will export the functions you specify, and can also re-export functions
  exported by some other module (like C<Moose.pm>).
  
  The C<unimport> method cleans the caller's namespace of all the exported
  functions. This includes any functions you re-export from other
  packages. However, if the consumer of your package also imports those
  functions from the original package, they will I<not> be cleaned.
  
  If you pass any parameters for L<Moose::Util::MetaRole>, this method will
  generate an C<init_meta> for you as well (see below for details). This
  C<init_meta> will call C<Moose::Util::MetaRole::apply_metaroles> and
  C<Moose::Util::MetaRole::apply_base_class_roles> as needed.
  
  Note that if any of these methods already exist, they will not be
  overridden, you will have to use C<build_import_methods> to get the
  coderef that would be installed.
  
  This method accepts the following parameters:
  
  =over 8
  
  =item * with_meta => [ ... ]
  
  This list of function I<names only> will be wrapped and then exported. The
  wrapper will pass the metaclass object for the caller as its first argument.
  
  Many sugar functions will need to use this metaclass object to do something to
  the calling package.
  
  =item * as_is => [ ... ]
  
  This list of function names or sub references will be exported as-is. You can
  identify a subroutine by reference, which is handy to re-export some other
  module's functions directly by reference (C<\&Some::Package::function>).
  
  If you do export some other package's function, this function will never be
  removed by the C<unimport> method. The reason for this is we cannot know if
  the caller I<also> explicitly imported the sub themselves, and therefore wants
  to keep it.
  
  =item * trait_aliases => [ ... ]
  
  This is a list of package names which should have shortened aliases exported,
  similar to the functionality of L<aliased>. Each element in the list can be
  either a package name, in which case the export will be named as the last
  namespace component of the package, or an arrayref, whose first element is the
  package to alias to, and second element is the alias to export.
  
  =item * also => $name or \@names
  
  This is a list of modules which contain functions that the caller
  wants to export. These modules must also use C<Moose::Exporter>. The
  most common use case will be to export the functions from C<Moose.pm>.
  Functions specified by C<with_meta> or C<as_is> take precedence over
  functions exported by modules specified by C<also>, so that a module
  can selectively override functions exported by another module.
  
  C<Moose::Exporter> also makes sure all these functions get removed
  when C<unimport> is called.
  
  =item * meta_lookup => sub { ... }
  
  This is a function which will be called to provide the metaclass
  to be operated upon by the exporter. This is an advanced feature
  intended for use by package generator modules in the vein of
  L<MooseX::Role::Parameterized> in order to simplify reusing sugar
  from other modules that use C<Moose::Exporter>. This function is
  used, for example, to select the metaclass to bind to functions
  that are exported using the C<with_meta> option.
  
  This function will receive one parameter: the class name into which
  the sugar is being exported. The default implementation is:
  
      sub { Class::MOP::class_of(shift) }
  
  Accordingly, this function is expected to return a metaclass.
  
  =back
  
  You can also provide parameters for C<Moose::Util::MetaRole::apply_metaroles>
  and C<Moose::Util::MetaRole::base_class_roles>. Specifically, valid parameters
  are "class_metaroles", "role_metaroles", and "base_class_roles".
  
  =item B<< Moose::Exporter->build_import_methods(...) >>
  
  Returns two or three code refs, one for C<import>, one for
  C<unimport>, and optionally one for C<init_meta>, if the appropriate
  options are passed in.
  
  Accepts the additional C<install> option, which accepts an arrayref of method
  names to install into your exporting package. The valid options are C<import>,
  C<unimport>, and C<init_meta>. Calling C<setup_import_methods> is equivalent
  to calling C<build_import_methods> with C<< install => [qw(import unimport
  init_meta)] >> except that it doesn't also return the methods.
  
  The C<import> method is built using L<Sub::Exporter>. This means that it can
  take a hashref of the form C<< { into => $package } >> to specify the package
  it operates on.
  
  Used by C<setup_import_methods>.
  
  =back
  
  =head1 IMPORTING AND init_meta
  
  If you want to set an alternative base object class or metaclass class, see
  above for details on how this module can call L<Moose::Util::MetaRole> for
  you.
  
  If you want to do something that is not supported by this module, simply
  define an C<init_meta> method in your class. The C<import> method that
  C<Moose::Exporter> generates for you will call this method (if it exists). It
  will always pass the caller to this method via the C<for_class> parameter.
  
  Most of the time, your C<init_meta> method will probably just call C<<
  Moose->init_meta >> to do the real work:
  
    sub init_meta {
        shift; # our class name
        return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
    }
  
  Keep in mind that C<build_import_methods> will return an C<init_meta>
  method for you, which you can also call from within your custom
  C<init_meta>:
  
    my ( $import, $unimport, $init_meta )
        = Moose::Exporter->build_import_methods(...);
  
    sub import {
        my $class = shift;
  
        ...
  
        # You can either pass an explicit package to import into ...
        $class->$import( { into => scalar(caller) }, ... );
  
        ...;
    }
  
    # ... or you can use 'goto' to provide the correct caller info to the
    # generated method
    sub unimport { goto &$unimport }
  
    sub init_meta {
        my $class = shift;
  
        ...
  
        $class->$init_meta(...);
  
        ...
    }
  
  =head1 METACLASS TRAITS
  
  The C<import> method generated by C<Moose::Exporter> will allow the
  user of your module to specify metaclass traits in a C<-traits>
  parameter passed as part of the import:
  
    use Moose -traits => 'My::Meta::Trait';
  
    use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
  
  These traits will be applied to the caller's metaclass
  instance. Providing traits for an exporting class that does not create
  a metaclass for the caller is an error.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_EXPORTER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE';
  
  package Moose::Meta::Attribute;
  BEGIN {
    $Moose::Meta::Attribute::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use B ();
  use Class::Load qw(is_class_loaded load_class);
  use Scalar::Util 'blessed', 'weaken';
  use List::MoreUtils 'any';
  use Try::Tiny;
  use overload     ();
  
  use Moose::Deprecated;
  use Moose::Meta::Method::Accessor;
  use Moose::Meta::Method::Delegation;
  use Moose::Util ();
  use Moose::Util::TypeConstraints ();
  use Class::MOP::MiniTrait;
  
  use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  __PACKAGE__->meta->add_attribute('traits' => (
      reader    => 'applied_traits',
      predicate => 'has_applied_traits',
      Class::MOP::_definition_context(),
  ));
  
  # we need to have a ->does method in here to
  # more easily support traits, and the introspection
  # of those traits. We extend the does check to look
  # for metatrait aliases.
  sub does {
      my ($self, $role_name) = @_;
      my $name = try {
          Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
      };
      return 0 if !defined($name); # failed to load class
      return $self->Moose::Object::does($name);
  }
  
  sub _error_thrower {
      my $self = shift;
      require Moose::Meta::Class;
      ( ref $self && $self->associated_class ) || "Moose::Meta::Class";
  }
  
  sub throw_error {
      my $self = shift;
      my $inv = $self->_error_thrower;
      unshift @_, "message" if @_ % 2 == 1;
      unshift @_, attr => $self if ref $self;
      unshift @_, $inv;
      my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1
      goto $handler;
  }
  
  sub _inline_throw_error {
      my ( $self, $msg, $args ) = @_;
  
      my $inv = $self->_error_thrower;
      # XXX ugh
      $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
  
      # XXX ugh ugh UGH
      my $class = $self->associated_class;
      if ($class) {
          my $class_name = B::perlstring($class->name);
          my $attr_name = B::perlstring($self->name);
          $args = 'attr => Class::MOP::class_of(' . $class_name . ')'
                . '->find_attribute_by_name(' . $attr_name . '), '
                . (defined $args ? $args : '');
      }
  
      return $inv->_inline_throw_error($msg, $args)
  }
  
  sub new {
      my ($class, $name, %options) = @_;
      $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
  
      delete $options{__hack_no_process_options};
  
      my %attrs =
          ( map { $_ => 1 }
            grep { defined }
            map { $_->init_arg() }
            $class->meta()->get_all_attributes()
          );
  
      my @bad = sort grep { ! $attrs{$_} }  keys %options;
  
      if (@bad)
      {
          Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
      }
  
      return $class->SUPER::new($name, %options);
  }
  
  sub interpolate_class_and_new {
      my ($class, $name, %args) = @_;
  
      my ( $new_class, @traits ) = $class->interpolate_class(\%args);
  
      $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
  }
  
  sub interpolate_class {
      my ($class, $options) = @_;
  
      $class = ref($class) || $class;
  
      if ( my $metaclass_name = delete $options->{metaclass} ) {
          my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
  
          if ( $class ne $new_class ) {
              if ( $new_class->can("interpolate_class") ) {
                  return $new_class->interpolate_class($options);
              } else {
                  $class = $new_class;
              }
          }
      }
  
      my @traits;
  
      if (my $traits = $options->{traits}) {
          my $i = 0;
          my $has_foreign_options = 0;
  
          while ($i < @$traits) {
              my $trait = $traits->[$i++];
              next if ref($trait); # options to a trait we discarded
  
              $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
                    || $trait;
  
              next if $class->does($trait);
  
              push @traits, $trait;
  
              # are there options?
              if ($traits->[$i] && ref($traits->[$i])) {
                  $has_foreign_options = 1
                      if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] };
  
                  push @traits, $traits->[$i++];
              }
          }
  
          if (@traits) {
              my %options = (
                  superclasses => [ $class ],
                  roles        => [ @traits ],
              );
  
              if ($has_foreign_options) {
                  $options{weaken} = 0;
              }
              else {
                  $options{cache} = 1;
              }
  
              my $anon_class = Moose::Meta::Class->create_anon_class(%options);
              $class = $anon_class->name;
          }
      }
  
      return ( wantarray ? ( $class, @traits ) : $class );
  }
  
  # ...
  
  # method-generating options shouldn't be overridden
  sub illegal_options_for_inheritance {
      qw(reader writer accessor clearer predicate)
  }
  
  # NOTE/TODO
  # This method *must* be able to handle
  # Class::MOP::Attribute instances as
  # well. Yes, I know that is wrong, but
  # apparently we didn't realize it was
  # doing that and now we have some code
  # which is dependent on it. The real
  # solution of course is to push this
  # feature back up into Class::MOP::Attribute
  # but I not right now, I am too lazy.
  # However if you are reading this and
  # looking for something to do,.. please
  # be my guest.
  # - stevan
  sub clone_and_inherit_options {
      my ($self, %options) = @_;
  
      # NOTE:
      # we may want to extends a Class::MOP::Attribute
      # in which case we need to be able to use the
      # core set of legal options that have always
      # been here. But we allows Moose::Meta::Attribute
      # instances to changes them.
      # - SL
      my @illegal_options = $self->can('illegal_options_for_inheritance')
          ? $self->illegal_options_for_inheritance
          : ();
  
      my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
      (scalar @found_illegal_options == 0)
          || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
  
      if ($options{isa}) {
          my $type_constraint;
          if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
              $type_constraint = $options{isa};
          }
          else {
              $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}, { package_defined_in => $options{definition_context}->{package} });
              (defined $type_constraint)
                  || $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
          }
  
          $options{type_constraint} = $type_constraint;
      }
  
      if ($options{does}) {
          my $type_constraint;
          if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
              $type_constraint = $options{does};
          }
          else {
              $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}, { package_defined_in => $options{definition_context}->{package} });
              (defined $type_constraint)
                  || $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
          }
  
          $options{type_constraint} = $type_constraint;
      }
  
      # NOTE:
      # this doesn't apply to Class::MOP::Attributes,
      # so we can ignore it for them.
      # - SL
      if ($self->can('interpolate_class')) {
          ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
  
          my %seen;
          my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
          $options{traits} = \@all_traits if @all_traits;
      }
  
      # This method can be called on a CMOP::Attribute object, so we need to
      # make sure we can call this method.
      $self->_process_lazy_build_option( $self->name, \%options )
          if $self->can('_process_lazy_build_option');
  
      $self->clone(%options);
  }
  
  sub clone {
      my ( $self, %params ) = @_;
  
      my $class = delete $params{metaclass} || ref $self;
  
      my ( @init, @non_init );
  
      foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
          push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
      }
  
      my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
  
      my $name = delete $new_params{name};
  
      my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
  
      foreach my $attr ( @non_init ) {
          $attr->set_value($clone, $attr->get_value($self));
      }
  
      return $clone;
  }
  
  sub _process_options {
      my ( $class, $name, $options ) = @_;
  
      $class->_process_is_option( $name, $options );
      $class->_process_isa_option( $name, $options );
      $class->_process_does_option( $name, $options );
      $class->_process_coerce_option( $name, $options );
      $class->_process_trigger_option( $name, $options );
      $class->_process_auto_deref_option( $name, $options );
      $class->_process_lazy_build_option( $name, $options );
      $class->_process_lazy_option( $name, $options );
      $class->_process_required_option( $name, $options );
  }
  
  sub _process_is_option {
      my ( $class, $name, $options ) = @_;
  
      return unless $options->{is};
  
      ### -------------------------
      ## is => ro, writer => _foo    # turns into (reader => foo, writer => _foo) as before
      ## is => rw, writer => _foo    # turns into (reader => foo, writer => _foo)
      ## is => rw, accessor => _foo  # turns into (accessor => _foo)
      ## is => ro, accessor => _foo  # error, accesor is rw
      ### -------------------------
  
      if ( $options->{is} eq 'ro' ) {
          $class->throw_error(
              "Cannot define an accessor name on a read-only attribute, accessors are read/write",
              data => $options )
              if exists $options->{accessor};
          $options->{reader} ||= $name;
      }
      elsif ( $options->{is} eq 'rw' ) {
          if ( $options->{writer} ) {
              $options->{reader} ||= $name;
          }
          else {
              $options->{accessor} ||= $name;
          }
      }
      elsif ( $options->{is} eq 'bare' ) {
          return;
          # do nothing, but don't complain (later) about missing methods
      }
      else {
          $class->throw_error( "I do not understand this option (is => "
                  . $options->{is}
                  . ") on attribute ($name)", data => $options->{is} );
      }
  }
  
  sub _process_isa_option {
      my ( $class, $name, $options ) = @_;
  
      return unless exists $options->{isa};
  
      if ( exists $options->{does} ) {
          if ( try { $options->{isa}->can('does') } ) {
              ( $options->{isa}->does( $options->{does} ) )
                  || $class->throw_error(
                  "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)",
                  data => $options );
          }
          else {
              $class->throw_error(
                  "Cannot have an isa option which cannot ->does() on attribute ($name)",
                  data => $options );
          }
      }
  
      # allow for anon-subtypes here ...
      if ( blessed( $options->{isa} )
          && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) {
          $options->{type_constraint} = $options->{isa};
      }
      else {
          $options->{type_constraint}
              = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
              $options->{isa},
              { package_defined_in => $options->{definition_context}->{package} }
          );
      }
  }
  
  sub _process_does_option {
      my ( $class, $name, $options ) = @_;
  
      return unless exists $options->{does} && ! exists $options->{isa};
  
      # allow for anon-subtypes here ...
      if ( blessed( $options->{does} )
          && $options->{does}->isa('Moose::Meta::TypeConstraint') ) {
          $options->{type_constraint} = $options->{does};
      }
      else {
          $options->{type_constraint}
              = Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
              $options->{does},
              { package_defined_in => $options->{definition_context}->{package} }
          );
      }
  }
  
  sub _process_coerce_option {
      my ( $class, $name, $options ) = @_;
  
      return unless $options->{coerce};
  
      ( exists $options->{type_constraint} )
          || $class->throw_error(
          "You cannot have coercion without specifying a type constraint on attribute ($name)",
          data => $options );
  
      $class->throw_error(
          "You cannot have a weak reference to a coerced value on attribute ($name)",
          data => $options )
          if $options->{weak_ref};
  
      unless ( $options->{type_constraint}->has_coercion ) {
          my $type = $options->{type_constraint}->name;
  
          Moose::Deprecated::deprecated(
              feature => 'coerce without coercion',
              message =>
                  "You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
          );
      }
  }
  
  sub _process_trigger_option {
      my ( $class, $name, $options ) = @_;
  
      return unless exists $options->{trigger};
  
      ( 'CODE' eq ref $options->{trigger} )
          || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
  }
  
  sub _process_auto_deref_option {
      my ( $class, $name, $options ) = @_;
  
      return unless $options->{auto_deref};
  
      ( exists $options->{type_constraint} )
          || $class->throw_error(
          "You cannot auto-dereference without specifying a type constraint on attribute ($name)",
          data => $options );
  
      ( $options->{type_constraint}->is_a_type_of('ArrayRef')
        || $options->{type_constraint}->is_a_type_of('HashRef') )
          || $class->throw_error(
          "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
          data => $options );
  }
  
  sub _process_lazy_build_option {
      my ( $class, $name, $options ) = @_;
  
      return unless $options->{lazy_build};
  
      $class->throw_error(
          "You can not use lazy_build and default for the same attribute ($name)",
          data => $options )
          if exists $options->{default};
  
      $options->{lazy} = 1;
      $options->{builder} ||= "_build_${name}";
  
      if ( $name =~ /^_/ ) {
          $options->{clearer}   ||= "_clear${name}";
          $options->{predicate} ||= "_has${name}";
      }
      else {
          $options->{clearer}   ||= "clear_${name}";
          $options->{predicate} ||= "has_${name}";
      }
  }
  
  sub _process_lazy_option {
      my ( $class, $name, $options ) = @_;
  
      return unless $options->{lazy};
  
      ( exists $options->{default} || defined $options->{builder} )
          || $class->throw_error(
          "You cannot have a lazy attribute ($name) without specifying a default value for it",
          data => $options );
  }
  
  sub _process_required_option {
      my ( $class, $name, $options ) = @_;
  
      if (
          $options->{required}
          && !(
              ( !exists $options->{init_arg} || defined $options->{init_arg} )
              || exists $options->{default}
              || defined $options->{builder}
          )
          ) {
          $class->throw_error(
              "You cannot have a required attribute ($name) without a default, builder, or an init_arg",
              data => $options );
      }
  }
  
  sub initialize_instance_slot {
      my ($self, $meta_instance, $instance, $params) = @_;
      my $init_arg = $self->init_arg();
      # try to fetch the init arg from the %params ...
  
      my $val;
      my $value_is_set;
      if ( defined($init_arg) and exists $params->{$init_arg}) {
          $val = $params->{$init_arg};
          $value_is_set = 1;
      }
      else {
          # skip it if it's lazy
          return if $self->is_lazy;
          # and die if it's required and doesn't have a default value
          $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
              if $self->is_required && !$self->has_default && !$self->has_builder;
  
          # if nothing was in the %params, we can use the
          # attribute's default value (if it has one)
          if ($self->has_default) {
              $val = $self->default($instance);
              $value_is_set = 1;
          }
          elsif ($self->has_builder) {
              $val = $self->_call_builder($instance);
              $value_is_set = 1;
          }
      }
  
      return unless $value_is_set;
  
      $val = $self->_coerce_and_verify( $val, $instance );
  
      $self->set_initial_value($instance, $val);
  
      if ( ref $val && $self->is_weak_ref ) {
          $self->_weaken_value($instance);
      }
  }
  
  sub _call_builder {
      my ( $self, $instance ) = @_;
  
      my $builder = $self->builder();
  
      return $instance->$builder()
          if $instance->can( $self->builder );
  
      $self->throw_error(  blessed($instance)
              . " does not support builder method '"
              . $self->builder
              . "' for attribute '"
              . $self->name
              . "'",
              object => $instance,
       );
  }
  
  ## Slot management
  
  sub _make_initializer_writer_callback {
      my $self = shift;
      my ($meta_instance, $instance, $slot_name) = @_;
      my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
      return sub {
          $old_callback->($self->_coerce_and_verify($_[0], $instance));
      };
  }
  
  sub set_value {
      my ($self, $instance, @args) = @_;
      my $value = $args[0];
  
      my $attr_name = quotemeta($self->name);
  
      if ($self->is_required and not @args) {
          $self->throw_error("Attribute ($attr_name) is required", object => $instance);
      }
  
      $value = $self->_coerce_and_verify( $value, $instance );
  
      my @old;
      if ( $self->has_trigger && $self->has_value($instance) ) {
          @old = $self->get_value($instance, 'for trigger');
      }
  
      $self->SUPER::set_value($instance, $value);
  
      if ( ref $value && $self->is_weak_ref ) {
          $self->_weaken_value($instance);
      }
  
      if ($self->has_trigger) {
          $self->trigger->($instance, $value, @old);
      }
  }
  
  sub _inline_set_value {
      my $self = shift;
      my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
  
      my $old     = '@old';
      my $copy    = '$val';
      $tc       ||= '$type_constraint';
      $coercion ||= '$type_coercion';
      $message  ||= '$type_message';
  
      my @code;
      if ($self->_writer_value_needs_copy) {
          push @code, $self->_inline_copy_value($value, $copy);
          $value = $copy;
      }
  
      # constructors already handle required checks
      push @code, $self->_inline_check_required
          unless $for_constructor;
  
      push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
  
      # constructors do triggers all at once at the end
      push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
          unless $for_constructor;
  
      push @code, (
          $self->SUPER::_inline_set_value($instance, $value),
          $self->_inline_weaken_value($instance, $value),
      );
  
      # constructors do triggers all at once at the end
      push @code, $self->_inline_trigger($instance, $value, $old)
          unless $for_constructor;
  
      return @code;
  }
  
  sub _writer_value_needs_copy {
      my $self = shift;
      return $self->should_coerce;
  }
  
  sub _inline_copy_value {
      my $self = shift;
      my ($value, $copy) = @_;
  
      return 'my ' . $copy . ' = ' . $value . ';'
  }
  
  sub _inline_check_required {
      my $self = shift;
  
      return unless $self->is_required;
  
      my $attr_name = quotemeta($self->name);
  
      return (
          'if (@_ < 2) {',
              $self->_inline_throw_error(
                  '"Attribute (' . $attr_name . ') is required, so cannot '
                . 'be set to undef"' # defined $_[1] is not good enough
              ) . ';',
          '}',
      );
  }
  
  sub _inline_tc_code {
      my $self = shift;
      my ($value, $tc, $coercion, $message, $is_lazy) = @_;
      return (
          $self->_inline_check_coercion(
              $value, $tc, $coercion, $is_lazy,
          ),
          $self->_inline_check_constraint(
              $value, $tc, $message, $is_lazy,
          ),
      );
  }
  
  sub _inline_check_coercion {
      my $self = shift;
      my ($value, $tc, $coercion) = @_;
  
      return unless $self->should_coerce && $self->type_constraint->has_coercion;
  
      if ( $self->type_constraint->can_be_inlined ) {
          return (
              'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
                  $value . ' = ' . $coercion . '->(' . $value . ');',
              '}',
          );
      }
      else {
          return (
              'if (!' . $tc . '->(' . $value . ')) {',
                  $value . ' = ' . $coercion . '->(' . $value . ');',
              '}',
          );
      }
  }
  
  sub _inline_check_constraint {
      my $self = shift;
      my ($value, $tc, $message) = @_;
  
      return unless $self->has_type_constraint;
  
      my $attr_name = quotemeta($self->name);
  
      if ( $self->type_constraint->can_be_inlined ) {
          return (
              'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
                  $self->_inline_throw_error(
                      '"Attribute (' . $attr_name . ') does not pass the type '
                    . 'constraint because: " . '
                    . 'do { local $_ = ' . $value . '; '
                        . $message . '->(' . $value . ')'
                    . '}',
                      'data => ' . $value
                  ) . ';',
              '}',
          );
      }
      else {
          return (
              'if (!' . $tc . '->(' . $value . ')) {',
                  $self->_inline_throw_error(
                      '"Attribute (' . $attr_name . ') does not pass the type '
                    . 'constraint because: " . '
                    . 'do { local $_ = ' . $value . '; '
                        . $message . '->(' . $value . ')'
                    . '}',
                      'data => ' . $value
                  ) . ';',
              '}',
          );
      }
  }
  
  sub _inline_get_old_value_for_trigger {
      my $self = shift;
      my ($instance, $old) = @_;
  
      return unless $self->has_trigger;
  
      return (
          'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
              '? ' . $self->_inline_instance_get($instance),
              ': ();',
      );
  }
  
  sub _inline_weaken_value {
      my $self = shift;
      my ($instance, $value) = @_;
  
      return unless $self->is_weak_ref;
  
      my $mi = $self->associated_class->get_meta_instance;
      return (
          $mi->inline_weaken_slot_value($instance, $self->name),
              'if ref ' . $value . ';',
      );
  }
  
  sub _inline_trigger {
      my $self = shift;
      my ($instance, $value, $old) = @_;
  
      return unless $self->has_trigger;
  
      return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
  }
  
  sub _eval_environment {
      my $self = shift;
  
      my $env = { };
  
      $env->{'$trigger'} = \($self->trigger)
          if $self->has_trigger;
      $env->{'$attr_default'} = \($self->default)
          if $self->has_default;
  
      if ($self->has_type_constraint) {
          my $tc_obj = $self->type_constraint;
  
          $env->{'$type_constraint'} = \(
              $tc_obj->_compiled_type_constraint
          ) unless $tc_obj->can_be_inlined;
          # these two could probably get inlined versions too
          $env->{'$type_coercion'} = \(
              $tc_obj->coercion->_compiled_type_coercion
          ) if $tc_obj->has_coercion;
          $env->{'$type_message'} = \(
              $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
          );
  
          $env = { %$env, %{ $tc_obj->inline_environment } };
      }
  
      # XXX ugh, fix these
      $env->{'$attr'} = \$self
          if $self->has_initializer && $self->is_lazy;
      # pretty sure this is only going to be closed over if you use a custom
      # error class at this point, but we should still get rid of this
      # at some point
      $env->{'$meta'} = \($self->associated_class);
  
      return $env;
  }
  
  sub _weaken_value {
      my ( $self, $instance ) = @_;
  
      my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
          ->get_meta_instance;
  
      $meta_instance->weaken_slot_value( $instance, $self->name );
  }
  
  sub get_value {
      my ($self, $instance, $for_trigger) = @_;
  
      if ($self->is_lazy) {
          unless ($self->has_value($instance)) {
              my $value;
              if ($self->has_default) {
                  $value = $self->default($instance);
              } elsif ( $self->has_builder ) {
                  $value = $self->_call_builder($instance);
              }
  
              $value = $self->_coerce_and_verify( $value, $instance );
  
              $self->set_initial_value($instance, $value);
  
              if ( ref $value && $self->is_weak_ref ) {
                  $self->_weaken_value($instance);
              }
          }
      }
  
      if ( $self->should_auto_deref && ! $for_trigger ) {
  
          my $type_constraint = $self->type_constraint;
  
          if ($type_constraint->is_a_type_of('ArrayRef')) {
              my $rv = $self->SUPER::get_value($instance);
              return unless defined $rv;
              return wantarray ? @{ $rv } : $rv;
          }
          elsif ($type_constraint->is_a_type_of('HashRef')) {
              my $rv = $self->SUPER::get_value($instance);
              return unless defined $rv;
              return wantarray ? %{ $rv } : $rv;
          }
          else {
              $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
          }
  
      }
      else {
  
          return $self->SUPER::get_value($instance);
      }
  }
  
  sub _inline_get_value {
      my $self = shift;
      my ($instance, $tc, $coercion, $message) = @_;
  
      my $slot_access = $self->_inline_instance_get($instance);
      $tc           ||= '$type_constraint';
      $coercion     ||= '$type_coercion';
      $message      ||= '$type_message';
  
      return (
          $self->_inline_check_lazy($instance, $tc, $coercion, $message),
          $self->_inline_return_auto_deref($slot_access),
      );
  }
  
  sub _inline_check_lazy {
      my $self = shift;
      my ($instance, $tc, $coercion, $message) = @_;
  
      return unless $self->is_lazy;
  
      my $slot_exists = $self->_inline_instance_has($instance);
  
      return (
          'if (!' . $slot_exists . ') {',
              $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
          '}',
      );
  }
  
  sub _inline_init_from_default {
      my $self = shift;
      my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
  
      if (!($self->has_default || $self->has_builder)) {
          $self->throw_error(
              'You cannot have a lazy attribute '
            . '(' . $self->name . ') '
            . 'without specifying a default value for it',
              attr => $self,
          );
      }
  
      return (
          $self->_inline_generate_default($instance, $default),
          # intentionally not using _inline_tc_code, since that can be overridden
          # to do things like possibly only do member tc checks, which isn't
          # appropriate for checking the result of a default
          $self->has_type_constraint
              ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
                 $self->_inline_check_constraint($default, $tc, $message, $for_lazy))
              : (),
          $self->_inline_init_slot($instance, $default),
          $self->_inline_weaken_value($instance, $default),
      );
  }
  
  sub _inline_generate_default {
      my $self = shift;
      my ($instance, $default) = @_;
  
      if ($self->has_default) {
          my $source = 'my ' . $default . ' = $attr_default';
          $source .= '->(' . $instance . ')'
              if $self->is_default_a_coderef;
          return $source . ';';
      }
      elsif ($self->has_builder) {
          my $builder = B::perlstring($self->builder);
          my $builder_str = quotemeta($self->builder);
          my $attr_name_str = quotemeta($self->name);
          return (
              'my ' . $default . ';',
              'if (my $builder = ' . $instance . '->can(' . $builder . ')) {',
                  $default . ' = ' . $instance . '->$builder;',
              '}',
              'else {',
                  'my $class = ref(' . $instance . ') || ' . $instance . ';',
                  $self->_inline_throw_error(
                      '"$class does not support builder method '
                    . '\'' . $builder_str . '\' for attribute '
                    . '\'' . $attr_name_str . '\'"'
                  ) . ';',
              '}',
          );
      }
      else {
          $self->throw_error(
              "Can't generate a default for " . $self->name
            . " since no default or builder was specified"
          );
      }
  }
  
  sub _inline_init_slot {
      my $self = shift;
      my ($inv, $value) = @_;
  
      if ($self->has_initializer) {
          return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
      }
      else {
          return $self->_inline_instance_set($inv, $value) . ';';
      }
  }
  
  sub _inline_return_auto_deref {
      my $self = shift;
  
      return 'return ' . $self->_auto_deref(@_) . ';';
  }
  
  sub _auto_deref {
      my $self = shift;
      my ($ref_value) = @_;
  
      return $ref_value unless $self->should_auto_deref;
  
      my $type_constraint = $self->type_constraint;
  
      my $sigil;
      if ($type_constraint->is_a_type_of('ArrayRef')) {
          $sigil = '@';
      }
      elsif ($type_constraint->is_a_type_of('HashRef')) {
          $sigil = '%';
      }
      else {
          $self->throw_error(
              'Can not auto de-reference the type constraint \''
            . $type_constraint->name
            . '\'',
              type_constraint => $type_constraint,
          );
      }
  
      return 'wantarray '
               . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
               . ': (' . $ref_value . ')';
  }
  
  ## installing accessors
  
  sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
  
  sub install_accessors {
      my $self = shift;
      $self->SUPER::install_accessors(@_);
      $self->install_delegation if $self->has_handles;
      return;
  }
  
  sub _check_associated_methods {
      my $self = shift;
      unless (
          @{ $self->associated_methods }
          || ($self->_is_metadata || '') eq 'bare'
      ) {
          Carp::cluck(
              'Attribute (' . $self->name . ') of class '
              . $self->associated_class->name
              . ' has no associated methods'
              . ' (did you mean to provide an "is" argument?)'
              . "\n"
          )
      }
  }
  
  sub _process_accessors {
      my $self = shift;
      my ($type, $accessor, $generate_as_inline_methods) = @_;
  
      $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
      my $method = $self->associated_class->get_method($accessor);
  
      if (   $method
          && $method->isa('Class::MOP::Method::Accessor')
          && $method->associated_attribute->name ne $self->name ) {
  
          my $other_attr_name = $method->associated_attribute->name;
          my $name            = $self->name;
  
          Carp::cluck(
              "You are overwriting an accessor ($accessor) for the $other_attr_name attribute"
                  . " with a new accessor method for the $name attribute" );
      }
  
      if (
             $method
          && !$method->is_stub
          && !$method->isa('Class::MOP::Method::Accessor')
          && (  !$self->definition_context
              || $method->package_name eq $self->definition_context->{package} )
          ) {
  
          Carp::cluck(
              "You are overwriting a locally defined method ($accessor) with "
                  . "an accessor" );
      }
  
      if (  !$self->associated_class->has_method($accessor)
          && $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
  
          Carp::cluck(
              "You are overwriting a locally defined function ($accessor) with "
                  . "an accessor" );
      }
  
      $self->SUPER::_process_accessors(@_);
  }
  
  sub remove_accessors {
      my $self = shift;
      $self->SUPER::remove_accessors(@_);
      $self->remove_delegation if $self->has_handles;
      return;
  }
  
  sub install_delegation {
      my $self = shift;
  
      # NOTE:
      # Here we canonicalize the 'handles' option
      # this will sort out any details and always
      # return an hash of methods which we want
      # to delagate to, see that method for details
      my %handles = $self->_canonicalize_handles;
  
  
      # install the delegation ...
      my $associated_class = $self->associated_class;
      foreach my $handle (sort keys %handles) {
          my $method_to_call = $handles{$handle};
          my $class_name = $associated_class->name;
          my $name = "${class_name}::${handle}";
  
          if ( my $method = $associated_class->get_method($handle) ) {
              $self->throw_error(
                  "You cannot overwrite a locally defined method ($handle) with a delegation",
                  method_name => $handle
              ) unless $method->is_stub;
          }
  
          # NOTE:
          # handles is not allowed to delegate
          # any of these methods, as they will
          # override the ones in your class, which
          # is almost certainly not what you want.
  
          # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
          #cluck("Not delegating method '$handle' because it is a core method") and
          next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
  
          my $method = $self->_make_delegation_method($handle, $method_to_call);
  
          $self->associated_class->add_method($method->name, $method);
          $self->associate_method($method);
      }
  }
  
  sub remove_delegation {
      my $self = shift;
      my %handles = $self->_canonicalize_handles;
      my $associated_class = $self->associated_class;
      foreach my $handle (keys %handles) {
          next unless any { $handle eq $_ }
                      map { $_->name }
                      @{ $self->associated_methods };
          $self->associated_class->remove_method($handle);
      }
  }
  
  # private methods to help delegation ...
  
  sub _canonicalize_handles {
      my $self    = shift;
      my $handles = $self->handles;
      if (my $handle_type = ref($handles)) {
          if ($handle_type eq 'HASH') {
              return %{$handles};
          }
          elsif ($handle_type eq 'ARRAY') {
              return map { $_ => $_ } @{$handles};
          }
          elsif ($handle_type eq 'Regexp') {
              ($self->has_type_constraint)
                  || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
              return map  { ($_ => $_) }
                     grep { /$handles/ } $self->_get_delegate_method_list;
          }
          elsif ($handle_type eq 'CODE') {
              return $handles->($self, $self->_find_delegate_metaclass);
          }
          elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
              return map { $_ => $_ } @{ $handles->methods };
          }
          elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
              $handles = $handles->role;
          }
          else {
              $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
          }
      }
  
      load_class($handles);
      my $role_meta = Class::MOP::class_of($handles);
  
      (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
          || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
  
      return map { $_ => $_ }
          map { $_->name }
          grep { !$_->isa('Class::MOP::Method::Meta') } (
          $role_meta->_get_local_methods,
          $role_meta->get_required_method_list,
          );
  }
  
  sub _get_delegate_method_list {
      my $self = shift;
      my $meta = $self->_find_delegate_metaclass;
      if ($meta->isa('Class::MOP::Class')) {
          return map  { $_->name }  # NOTE: !never! delegate &meta
                 grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
                      $meta->get_all_methods;
      }
      elsif ($meta->isa('Moose::Meta::Role')) {
          return $meta->get_method_list;
      }
      else {
          $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
      }
  }
  
  sub _find_delegate_metaclass {
      my $self = shift;
      if (my $class = $self->_isa_metadata) {
          unless ( is_class_loaded($class) ) {
              $self->throw_error(
                  sprintf(
                      'The %s attribute is trying to delegate to a class which has not been loaded - %s',
                      $self->name, $class
                  )
              );
          }
          # we might be dealing with a non-Moose class,
          # and need to make our own metaclass. if there's
          # already a metaclass, it will be returned
          return Class::MOP::Class->initialize($class);
      }
      elsif (my $role = $self->_does_metadata) {
          unless ( is_class_loaded($class) ) {
              $self->throw_error(
                  sprintf(
                      'The %s attribute is trying to delegate to a role which has not been loaded - %s',
                      $self->name, $role
                  )
              );
          }
  
          return Class::MOP::class_of($role);
      }
      else {
          $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
      }
  }
  
  sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
  
  sub _make_delegation_method {
      my ( $self, $handle_name, $method_to_call ) = @_;
  
      my @curried_arguments;
  
      ($method_to_call, @curried_arguments) = @$method_to_call
          if 'ARRAY' eq ref($method_to_call);
  
      return $self->delegation_metaclass->new(
          name               => $handle_name,
          package_name       => $self->associated_class->name,
          attribute          => $self,
          delegate_to_method => $method_to_call,
          curried_arguments  => \@curried_arguments,
      );
  }
  
  sub _coerce_and_verify {
      my $self     = shift;
      my $val      = shift;
      my $instance = shift;
  
      return $val unless $self->has_type_constraint;
  
      $val = $self->type_constraint->coerce($val)
          if $self->should_coerce && $self->type_constraint->has_coercion;
  
      $self->verify_against_type_constraint($val, instance => $instance);
  
      return $val;
  }
  
  sub verify_against_type_constraint {
      my $self = shift;
      my $val  = shift;
  
      return 1 if !$self->has_type_constraint;
  
      my $type_constraint = $self->type_constraint;
  
      $type_constraint->check($val)
          || $self->throw_error("Attribute ("
                   . $self->name
                   . ") does not pass the type constraint because: "
                   . $type_constraint->get_message($val), data => $val, @_);
  }
  
  package Moose::Meta::Attribute::Custom::Moose;
  BEGIN {
    $Moose::Meta::Attribute::Custom::Moose::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Custom::Moose::VERSION = '2.0401';
  }
  sub register_implementation { 'Moose::Meta::Attribute' }
  
  1;
  
  # ABSTRACT: The Moose attribute metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute - The Moose attribute metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Attribute> that provides
  additional Moose-specific functionality.
  
  To really understand this class, you will need to start with the
  L<Class::MOP::Attribute> documentation. This class can be understood
  as a set of additional features on top of the basic feature provided
  by that parent class.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
  
  =head1 METHODS
  
  Many of the documented below override methods in
  L<Class::MOP::Attribute> and add Moose specific features.
  
  =head2 Creation
  
  =over 4
  
  =item B<< Moose::Meta::Attribute->new(%options) >>
  
  This method overrides the L<Class::MOP::Attribute> constructor.
  
  Many of the options below are described in more detail in the
  L<Moose::Manual::Attributes> document.
  
  It adds the following options to the constructor:
  
  =over 8
  
  =item * is => 'ro', 'rw', 'bare'
  
  This provides a shorthand for specifying the C<reader>, C<writer>, or
  C<accessor> names. If the attribute is read-only ('ro') then it will
  have a C<reader> method with the same attribute as the name.
  
  If it is read-write ('rw') then it will have an C<accessor> method
  with the same name. If you provide an explicit C<writer> for a
  read-write attribute, then you will have a C<reader> with the same
  name as the attribute, and a C<writer> with the name you provided.
  
  Use 'bare' when you are deliberately not installing any methods
  (accessor, reader, etc.) associated with this attribute; otherwise,
  Moose will issue a deprecation warning when this attribute is added to a
  metaclass.
  
  =item * isa => $type
  
  This option accepts a type. The type can be a string, which should be
  a type name. If the type name is unknown, it is assumed to be a class
  name.
  
  This option can also accept a L<Moose::Meta::TypeConstraint> object.
  
  If you I<also> provide a C<does> option, then your C<isa> option must
  be a class name, and that class must do the role specified with
  C<does>.
  
  =item * does => $role
  
  This is short-hand for saying that the attribute's type must be an
  object which does the named role.
  
  =item * coerce => $bool
  
  This option is only valid for objects with a type constraint
  (C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
  this attribute is set.
  
  You can make both this and the C<weak_ref> option true.
  
  =item * trigger => $sub
  
  This option accepts a subroutine reference, which will be called after
  the attribute is set.
  
  =item * required => $bool
  
  An attribute which is required must be provided to the constructor. An
  attribute which is required can also have a C<default> or C<builder>,
  which will satisfy its required-ness.
  
  A required attribute must have a C<default>, C<builder> or a
  non-C<undef> C<init_arg>
  
  =item * lazy => $bool
  
  A lazy attribute must have a C<default> or C<builder>. When an
  attribute is lazy, the default value will not be calculated until the
  attribute is read.
  
  =item * weak_ref => $bool
  
  If this is true, the attribute's value will be stored as a weak
  reference.
  
  =item * auto_deref => $bool
  
  If this is true, then the reader will dereference the value when it is
  called. The attribute must have a type constraint which defines the
  attribute as an array or hash reference.
  
  =item * lazy_build => $bool
  
  Setting this to true makes the attribute lazy and provides a number of
  default methods.
  
    has 'size' => (
        is         => 'ro',
        lazy_build => 1,
    );
  
  is equivalent to this:
  
    has 'size' => (
        is        => 'ro',
        lazy      => 1,
        builder   => '_build_size',
        clearer   => 'clear_size',
        predicate => 'has_size',
    );
  
  If your attribute name starts with an underscore (C<_>), then the clearer
  and predicate will as well:
  
    has '_size' => (
        is         => 'ro',
        lazy_build => 1,
    );
  
  becomes:
  
    has '_size' => (
        is        => 'ro',
        lazy      => 1,
        builder   => '_build__size',
        clearer   => '_clear_size',
        predicate => '_has_size',
    );
  
  Note the doubled underscore in the builder name. Internally, Moose
  simply prepends the attribute name with "_build_" to come up with the
  builder name.
  
  =item * documentation
  
  An arbitrary string that can be retrieved later by calling C<<
  $attr->documentation >>.
  
  =back
  
  =item B<< $attr->clone(%options) >>
  
  This creates a new attribute based on attribute being cloned. You must
  supply a C<name> option to provide a new name for the attribute.
  
  The C<%options> can only specify options handled by
  L<Class::MOP::Attribute>.
  
  =back
  
  =head2 Value management
  
  =over 4
  
  =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
  
  This method is used internally to initialize the attribute's slot in
  the object C<$instance>.
  
  This overrides the L<Class::MOP::Attribute> method to handle lazy
  attributes, weak references, and type constraints.
  
  =item B<get_value>
  
  =item B<set_value>
  
    eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
    if($@) {
      print "Oops: $@\n";
    }
  
  I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
  
  Before setting the value, a check is made on the type constraint of
  the attribute, if it has one, to see if the value passes it. If the
  value fails to pass, the set operation dies with a L</throw_error>.
  
  Any coercion to convert values is done before checking the type constraint.
  
  To check a value against a type constraint before setting it, fetch the
  attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
  fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
  and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
  for an example.
  
  =back
  
  =head2 Attribute Accessor generation
  
  =over 4
  
  =item B<< $attr->install_accessors >>
  
  This method overrides the parent to also install delegation methods.
  
  If, after installing all methods, the attribute object has no associated
  methods, it throws an error unless C<< is => 'bare' >> was passed to the
  attribute constructor.  (Trying to add an attribute that has no associated
  methods is almost always an error.)
  
  =item B<< $attr->remove_accessors >>
  
  This method overrides the parent to also remove delegation methods.
  
  =item B<< $attr->inline_set($instance_var, $value_var) >>
  
  This method return a code snippet suitable for inlining the relevant
  operation. It expect strings containing variable names to be used in the
  inlining, like C<'$self'> or C<'$_[1]'>.
  
  =item B<< $attr->install_delegation >>
  
  This method adds its delegation methods to the attribute's associated
  class, if it has any to add.
  
  =item B<< $attr->remove_delegation >>
  
  This method remove its delegation methods from the attribute's
  associated class.
  
  =item B<< $attr->accessor_metaclass >>
  
  Returns the accessor metaclass name, which defaults to
  L<Moose::Meta::Method::Accessor>.
  
  =item B<< $attr->delegation_metaclass >>
  
  Returns the delegation metaclass name, which defaults to
  L<Moose::Meta::Method::Delegation>.
  
  =back
  
  =head2 Additional Moose features
  
  These methods are not found in the superclass. They support features
  provided by Moose.
  
  =over 4
  
  =item B<< $attr->does($role) >>
  
  This indicates whether the I<attribute itself> does the given
  role. The role can be given as a full class name, or as a resolvable
  trait name.
  
  Note that this checks the attribute itself, not its type constraint,
  so it is checking the attribute's metaclass and any traits applied to
  the attribute.
  
  =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
  
  This is an alternate constructor that handles the C<metaclass> and
  C<traits> options.
  
  Effectively, this method is a factory that finds or creates the
  appropriate class for the given C<metaclass> and/or C<traits>.
  
  Once it has the appropriate class, it will call C<< $class->new($name,
  %options) >> on that class.
  
  =item B<< $attr->clone_and_inherit_options(%options) >>
  
  This method supports the C<has '+foo'> feature. It does various bits
  of processing on the supplied C<%options> before ultimately calling
  the C<clone> method.
  
  One of its main tasks is to make sure that the C<%options> provided
  does not include the options returned by the
  C<illegal_options_for_inheritance> method.
  
  =item B<< $attr->illegal_options_for_inheritance >>
  
  This returns a blacklist of options that can not be overridden in a
  subclass's attribute definition.
  
  This exists to allow a custom metaclass to change or add to the list
  of options which can not be changed.
  
  =item B<< $attr->type_constraint >>
  
  Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
  if it has one.
  
  =item B<< $attr->has_type_constraint >>
  
  Returns true if this attribute has a type constraint.
  
  =item B<< $attr->verify_against_type_constraint($value) >>
  
  Given a value, this method returns true if the value is valid for the
  attribute's type constraint. If the value is not valid, it throws an
  error.
  
  =item B<< $attr->handles >>
  
  This returns the value of the C<handles> option passed to the
  constructor.
  
  =item B<< $attr->has_handles >>
  
  Returns true if this attribute performs delegation.
  
  =item B<< $attr->is_weak_ref >>
  
  Returns true if this attribute stores its value as a weak reference.
  
  =item B<< $attr->is_required >>
  
  Returns true if this attribute is required to have a value.
  
  =item B<< $attr->is_lazy >>
  
  Returns true if this attribute is lazy.
  
  =item B<< $attr->is_lazy_build >>
  
  Returns true if the C<lazy_build> option was true when passed to the
  constructor.
  
  =item B<< $attr->should_coerce >>
  
  Returns true if the C<coerce> option passed to the constructor was
  true.
  
  =item B<< $attr->should_auto_deref >>
  
  Returns true if the C<auto_deref> option passed to the constructor was
  true.
  
  =item B<< $attr->trigger >>
  
  This is the subroutine reference that was in the C<trigger> option
  passed to the constructor, if any.
  
  =item B<< $attr->has_trigger >>
  
  Returns true if this attribute has a trigger set.
  
  =item B<< $attr->documentation >>
  
  Returns the value that was in the C<documentation> option passed to
  the constructor, if any.
  
  =item B<< $attr->has_documentation >>
  
  Returns true if this attribute has any documentation.
  
  =item B<< $attr->applied_traits >>
  
  This returns an array reference of all the traits which were applied
  to this attribute. If none were applied, this returns C<undef>.
  
  =item B<< $attr->has_applied_traits >>
  
  Returns true if this attribute has any traits applied.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE';
  package Moose::Meta::Attribute::Native;
  BEGIN {
    $Moose::Meta::Attribute::Native::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::VERSION = '2.0401';
  }
  
  use Class::Load qw(load_class);
  
  my @trait_names = qw(Bool Counter Number String Array Hash Code);
  
  for my $trait_name (@trait_names) {
      my $trait_class = "Moose::Meta::Attribute::Native::Trait::$trait_name";
      my $meta = Class::MOP::Class->initialize(
          "Moose::Meta::Attribute::Custom::Trait::$trait_name"
      );
      if ($meta->find_method_by_name('register_implementation')) {
          my $class = $meta->name->register_implementation;
          Moose->throw_error(
              "An implementation for $trait_name already exists " .
              "(found '$class' when trying to register '$trait_class')"
          );
      }
      $meta->add_method(register_implementation => sub {
          # resolve_metatrait_alias will load classes anyway, but throws away
          # their error message; we WANT to die if there's a problem
          load_class($trait_class);
          return $trait_class;
      });
  }
  
  1;
  
  # ABSTRACT: Delegate to native Perl types
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native - Delegate to native Perl types
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyClass;
    use Moose;
  
    has 'mapping' => (
        traits  => ['Hash'],
        is      => 'rw',
        isa     => 'HashRef[Str]',
        default => sub { {} },
        handles => {
            exists_in_mapping => 'exists',
            ids_in_mapping    => 'keys',
            get_mapping       => 'get',
            set_mapping       => 'set',
            set_quantity      => [ set => 'quantity' ],
        },
    );
  
    my $obj = MyClass->new;
    $obj->set_quantity(10);      # quantity => 10
    $obj->set_mapping('foo', 4); # foo => 4
    $obj->set_mapping('bar', 5); # bar => 5
    $obj->set_mapping('baz', 6); # baz => 6
  
    # prints 5
    print $obj->get_mapping('bar') if $obj->exists_in_mapping('bar');
  
    # prints 'quantity, foo, bar, baz'
    print join ', ', $obj->ids_in_mapping;
  
  =head1 DESCRIPTION
  
  Native delegations allow you to delegate to native Perl data
  structures as if they were objects. For example, in the L</SYNOPSIS> you can
  see a hash reference being treated as if it has methods named C<exists()>,
  C<keys()>, C<get()>, and C<set()>.
  
  The delegation methods (mostly) map to Perl builtins and operators. The return
  values of these delegations should be the same as the corresponding Perl
  operation. Any deviations will be explicitly documented.
  
  =head1 API
  
  Native delegations are enabled by passing certain options to C<has> when
  creating an attribute.
  
  =head2 traits
  
  To enable this feature, pass the appropriate name in the C<traits> array
  reference for the attribute. For example, to enable this feature for hash
  reference, we include C<'Hash'> in the list of traits.
  
  =head2 isa
  
  You will need to make sure that the attribute has an appropriate type. For
  example, to use this with a Hash you must specify that your attribute is some
  sort of C<HashRef>.
  
  =head2 handles
  
  This is just like any other delegation, but only a hash reference is allowed
  when defining native delegations. The keys are the methods to be created in
  the class which contains the attribute. The values are the methods provided by
  the associated trait. Currying works the same way as it does with any other
  delegation.
  
  See the docs for each native trait for details on what methods are available.
  
  =head2 is
  
  Some traits provide a default C<is> for historical reasons. This behavior is
  deprecated, and you are strongly encouraged to provide a value. If you don't
  plan to read and write the attribute value directly, not passing the C<is>
  option will prevent standard accessor generation.
  
  =head2 default or builder
  
  Some traits provide a default C<default> for historical reasons. This behavior
  is deprecated, and you are strongly encouraged to provide a default value or
  make the attribute required.
  
  =head1 TRAITS FOR NATIVE DELEGATIONS
  
  =over
  
  =item L<Array|Moose::Meta::Attribute::Native::Trait::Array>
  
      has 'queue' => (
          traits  => ['Array'],
          is      => 'ro',
          isa     => 'ArrayRef[Str]',
          default => sub { [] },
          handles => {
              add_item  => 'push',
              next_item => 'shift',
              # ...
          }
      );
  
  =item L<Bool|Moose::Meta::Attribute::Native::Trait::Bool>
  
      has 'is_lit' => (
          traits  => ['Bool'],
          is      => 'ro',
          isa     => 'Bool',
          default => 0,
          handles => {
              illuminate  => 'set',
              darken      => 'unset',
              flip_switch => 'toggle',
              is_dark     => 'not',
              # ...
          }
      );
  
  =item L<Code|Moose::Meta::Attribute::Native::Trait::Code>
  
      has 'callback' => (
          traits  => ['Code'],
          is      => 'ro',
          isa     => 'CodeRef',
          default => sub {
              sub {'called'}
          },
          handles => {
              call => 'execute',
              # ...
          }
      );
  
  =item L<Counter|Moose::Meta::Attribute::Native::Trait::Counter>
  
      has 'counter' => (
          traits  => ['Counter'],
          is      => 'ro',
          isa     => 'Num',
          default => 0,
          handles => {
              inc_counter   => 'inc',
              dec_counter   => 'dec',
              reset_counter => 'reset',
              # ...
          }
      );
  
  =item L<Hash|Moose::Meta::Attribute::Native::Trait::Hash>
  
      has 'options' => (
          traits  => ['Hash'],
          is      => 'ro',
          isa     => 'HashRef[Str]',
          default => sub { {} },
          handles => {
              set_option => 'set',
              get_option => 'get',
              has_option => 'exists',
              # ...
          }
      );
  
  =item L<Number|Moose::Meta::Attribute::Native::Trait::Number>
  
      has 'integer' => (
          traits  => ['Number'],
          is      => 'ro',
          isa     => 'Int',
          default => 5,
          handles => {
              set => 'set',
              add => 'add',
              sub => 'sub',
              mul => 'mul',
              div => 'div',
              mod => 'mod',
              abs => 'abs',
              # ...
          }
      );
  
  =item L<String|Moose::Meta::Attribute::Native::Trait::String>
  
      has 'text' => (
          traits  => ['String'],
          is      => 'ro',
          isa     => 'Str',
          default => q{},
          handles => {
              add_text     => 'append',
              replace_text => 'replace',
              # ...
          }
      );
  
  =back
  
  =head1 COMPATIBILITY WITH MooseX::AttributeHelpers
  
  This feature used to be a separated CPAN distribution called
  L<MooseX::AttributeHelpers>.
  
  When the feature was incorporated into the Moose core, some of the API details
  were changed. The underlying capabilities are the same, but some details of
  the API were changed.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT';
  
  package Moose::Meta::Attribute::Native::Trait;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::VERSION = '2.0401';
  }
  use Moose::Role;
  
  use Class::Load qw(load_class);
  use List::MoreUtils qw( any uniq );
  use Moose::Util::TypeConstraints;
  use Moose::Deprecated;
  
  requires '_helper_type';
  
  has _used_default_is => (
      is      => 'rw',
      isa     => 'Bool',
      default => 0,
  );
  
  before '_process_options' => sub {
      my ( $self, $name, $options ) = @_;
  
      $self->_check_helper_type( $options, $name );
  
      if ( !( any { exists $options->{$_} } qw( is reader writer accessor ) )
          && $self->can('_default_is') ) {
  
          $options->{is} = $self->_default_is;
  
          $options->{_used_default_is} = 1;
      }
  
      if (
          !(
              $options->{required}
              || any { exists $options->{$_} } qw( default builder lazy_build )
          )
          && $self->can('_default_default')
          ) {
  
          $options->{default} = $self->_default_default;
  
          Moose::Deprecated::deprecated(
              feature => 'default default for Native Trait',
              message =>
                  'Allowing a native trait to automatically supply a default is deprecated.'
                  . ' You can avoid this warning by supplying a default, builder, or making the attribute required'
          );
      }
  };
  
  after 'install_accessors' => sub {
      my $self = shift;
  
      return unless $self->_used_default_is;
  
      my @methods
          = $self->_default_is eq 'rw'
          ? qw( reader writer accessor )
          : 'reader';
  
      my $name = $self->name;
      my $class = $self->associated_class->name;
  
      for my $meth ( uniq grep {defined} map { $self->$_ } @methods ) {
  
          my $message
              = "The $meth method in the $class class was automatically created"
              . " by the native delegation trait for the $name attribute."
              . q{ This "default is" feature is deprecated.}
              . q{ Explicitly set "is" or define accessor names to avoid this};
  
          $self->associated_class->add_before_method_modifier(
              $meth => sub {
                  Moose::Deprecated::deprecated(
                      feature => 'default is for Native Trait',
                      message =>$message,
                  );
              }
          );
      }
      };
  
  sub _check_helper_type {
      my ( $self, $options, $name ) = @_;
  
      my $type = $self->_helper_type;
  
      $options->{isa} = $type
          unless exists $options->{isa};
  
      my $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint(
          $options->{isa} );
  
      ( $isa->is_a_type_of($type) )
          || confess
          "The type constraint for $name must be a subtype of $type but it's a $isa";
  }
  
  before 'install_accessors' => sub { (shift)->_check_handles_values };
  
  sub _check_handles_values {
      my $self = shift;
  
      my %handles = $self->_canonicalize_handles;
  
      for my $original_method ( values %handles ) {
          my $name = $original_method->[0];
  
          my $accessor_class = $self->_native_accessor_class_for($name);
  
          ( $accessor_class && $accessor_class->can('new') )
              || confess
              "$name is an unsupported method type - $accessor_class";
      }
  }
  
  around '_canonicalize_handles' => sub {
      shift;
      my $self    = shift;
      my $handles = $self->handles;
  
      return unless $handles;
  
      unless ( 'HASH' eq ref $handles ) {
          $self->throw_error(
              "The 'handles' option must be a HASH reference, not $handles");
      }
  
      return
          map { $_ => $self->_canonicalize_handles_value( $handles->{$_} ) }
          keys %$handles;
  };
  
  sub _canonicalize_handles_value {
      my $self  = shift;
      my $value = shift;
  
      if ( ref $value && 'ARRAY' ne ref $value ) {
          $self->throw_error(
              "All values passed to handles must be strings or ARRAY references, not $value"
          );
      }
  
      return ref $value ? $value : [$value];
  }
  
  around '_make_delegation_method' => sub {
      my $next = shift;
      my ( $self, $handle_name, $method_to_call ) = @_;
  
      my ( $name, @curried_args ) = @$method_to_call;
  
      my $accessor_class = $self->_native_accessor_class_for($name);
  
      die "Cannot find an accessor class for $name"
          unless $accessor_class && $accessor_class->can('new');
  
      return $accessor_class->new(
          name               => $handle_name,
          package_name       => $self->associated_class->name,
          delegate_to_method => $name,
          attribute          => $self,
          is_inline          => 1,
          curried_arguments  => \@curried_args,
          root_types         => [ $self->_root_types ],
      );
  };
  
  sub _root_types {
      return $_[0]->_helper_type;
  }
  
  sub _native_accessor_class_for {
      my ( $self, $suffix ) = @_;
  
      my $role
          = 'Moose::Meta::Method::Accessor::Native::'
          . $self->_native_type . '::'
          . $suffix;
  
      load_class($role);
      return Moose::Meta::Class->create_anon_class(
          superclasses =>
              [ $self->accessor_metaclass, $self->delegation_metaclass ],
          roles => [$role],
          cache => 1,
      )->name;
  }
  
  sub _build_native_type {
      my $self = shift;
  
      for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) {
          return $1 if $role_name =~ /::Native::Trait::(\w+)$/;
      }
  
      die "Cannot calculate native type for " . ref $self;
  }
  
  has '_native_type' => (
      is      => 'ro',
      isa     => 'Str',
      lazy    => 1,
      builder => '_build_native_type',
  );
  
  no Moose::Role;
  no Moose::Util::TypeConstraints;
  
  1;
  
  # ABSTRACT: Shared role for native delegation traits
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 SEE ALSO
  
  Documentation for Moose native traits can be found in
  L<Moose::Meta::Attribute::Native>.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Array.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_ARRAY';
  
  package Moose::Meta::Attribute::Native::Trait::Array;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Array::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Array::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _helper_type { 'ArrayRef' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for ArrayRef attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Array - Helper trait for ArrayRef attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
      package Stuff;
      use Moose;
  
      has 'options' => (
          traits  => ['Array'],
          is      => 'ro',
          isa     => 'ArrayRef[Str]',
          default => sub { [] },
          handles => {
              all_options    => 'elements',
              add_option     => 'push',
              map_options    => 'map',
              filter_options => 'grep',
              find_option    => 'first',
              get_option     => 'get',
              join_options   => 'join',
              count_options  => 'count',
              has_options    => 'count',
              has_no_options => 'is_empty',
              sorted_options => 'sort',
          },
      );
  
      no Moose;
      1;
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for array references.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<ArrayRef>.
  
  =head1 PROVIDED METHODS
  
  =over 4
  
  =item * B<count>
  
  Returns the number of elements in the array.
  
    $stuff = Stuff->new;
    $stuff->options( [ "foo", "bar", "baz", "boo" ] );
  
    print $stuff->count_options; # prints 4
  
  This method does not accept any arguments.
  
  =item * B<is_empty>
  
  Returns a boolean value that is true when the array has no elements.
  
    $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n";
  
  This method does not accept any arguments.
  
  =item * B<elements>
  
  Returns all of the elements of the array as an array (not an array reference).
  
    my @option = $stuff->all_options;
    print "@options\n";    # prints "foo bar baz boo"
  
  This method does not accept any arguments.
  
  =item * B<get($index)>
  
  Returns an element of the array by its index. You can also use negative index
  numbers, just as with Perl's core array handling.
  
    my $option = $stuff->get_option(1);
    print "$option\n";    # prints "bar"
  
  If the specified element does not exist, this will return C<undef>.
  
  This method accepts just one argument.
  
  =item * B<pop>
  
  Just like Perl's builtin C<pop>.
  
  This method does not accept any arguments.
  
  =item * B<push($value1, $value2, value3 ...)>
  
  Just like Perl's builtin C<push>. Returns the number of elements in the new
  array.
  
  This method accepts any number of arguments.
  
  =item * B<shift>
  
  Just like Perl's builtin C<shift>.
  
  This method does not accept any arguments.
  
  =item * B<unshift($value1, $value2, value3 ...)>
  
  Just like Perl's builtin C<unshift>. Returns the number of elements in the new
  array.
  
  This method accepts any number of arguments.
  
  =item * B<splice($offset, $length, @values)>
  
  Just like Perl's builtin C<splice>. In scalar context, this returns the last
  element removed, or C<undef> if no elements were removed. In list context,
  this returns all the elements removed from the array.
  
  This method requires at least one argument.
  
  =item * B<first( sub { ... } )>
  
  This method returns the first matching item in the array, just like
  L<List::Util>'s C<first> function. The matching is done with a subroutine
  reference you pass to this method. The subroutine will be called against each
  element in the array until one matches or all elements have been checked.
  
    my $found = $stuff->find_option( sub {/^b/} );
    print "$found\n";    # prints "bar"
  
  This method requires a single argument.
  
  =item * B<first_index( sub { ... } )>
  
  This method returns the index of the first matching item in the array, just
  like L<List::MoreUtils>'s C<first_index> function. The matching is done with a
  subroutine reference you pass to this method. The subroutine will be called
  against each element in the array until one matches or all elements have been
  checked.
  
  This method requires a single argument.
  
  =item * B<grep( sub { ... } )>
  
  This method returns every element matching a given criteria, just like Perl's
  core C<grep> function. This method requires a subroutine which implements the
  matching logic.
  
    my @found = $stuff->filter_options( sub {/^b/} );
    print "@found\n";    # prints "bar baz boo"
  
  This method requires a single argument.
  
  =item * B<map( sub { ... } )>
  
  This method transforms every element in the array and returns a new array,
  just like Perl's core C<map> function. This method requires a subroutine which
  implements the transformation.
  
    my @mod_options = $stuff->map_options( sub { $_ . "-tag" } );
    print "@mod_options\n";    # prints "foo-tag bar-tag baz-tag boo-tag"
  
  This method requires a single argument.
  
  =item * B<reduce( sub { ... } )>
  
  This method turns an array into a single value, by passing a function the
  value so far and the next value in the array, just like L<List::Util>'s
  C<reduce> function. The reducing is done with a subroutine reference you pass
  to this method.
  
    my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } );
    print "$found\n";    # prints "foobarbazboo"
  
  This method requires a single argument.
  
  =item * B<sort>
  
  =item * B<sort( sub { ... } )>
  
  Returns the elements of the array in sorted order.
  
  You can provide an optional subroutine reference to sort with (as you can with
  Perl's core C<sort> function). However, instead of using C<$a> and C<$b> in
  this subroutine, you will need to use C<$_[0]> and C<$_[1]>.
  
    # ascending ASCIIbetical
    my @sorted = $stuff->sort_options();
  
    # Descending alphabetical order
    my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } );
    print "@sorted_options\n";    # prints "foo boo baz bar"
  
  This method accepts a single argument.
  
  =item * B<sort_in_place>
  
  =item * B<sort_in_place( sub { ... } )>
  
  Sorts the array I<in place>, modifying the value of the attribute.
  
  You can provide an optional subroutine reference to sort with (as you can with
  Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you
  will need to use C<$_[0]> and C<$_[1]> instead.
  
  This method does not define a return value.
  
  This method accepts a single argument.
  
  =item * B<shuffle>
  
  Returns the elements of the array in random order, like C<shuffle> from
  L<List::Util>.
  
  This method does not accept any arguments.
  
  =item * B<uniq>
  
  Returns the array with all duplicate elements removed, like C<uniq> from
  L<List::MoreUtils>.
  
  This method does not accept any arguments.
  
  =item * B<join($str)>
  
  Joins every element of the array using the separator given as argument, just
  like Perl's core C<join> function.
  
    my $joined = $stuff->join_options(':');
    print "$joined\n";    # prints "foo:bar:baz:boo"
  
  This method requires a single argument.
  
  =item * B<set($index, $value)>
  
  Given an index and a value, sets the specified array element's value.
  
  This method returns the value at C<$index> after the set.
  
  This method requires two arguments.
  
  =item * B<delete($index)>
  
  Removes the element at the given index from the array.
  
  This method returns the deleted value. Note that if no value exists, it will
  return C<undef>.
  
  This method requires one argument.
  
  =item * B<insert($index, $value)>
  
  Inserts a new element into the array at the given index.
  
  This method returns the new value at C<$index>.
  
  This method requires two arguments.
  
  =item * B<clear>
  
  Empties the entire array, like C<@array = ()>.
  
  This method does not define a return value.
  
  This method does not accept any arguments.
  
  =item * B<accessor($index)>
  
  =item * B<accessor($index, $value)>
  
  This method provides a get/set accessor for the array, based on array indexes.
  If passed one argument, it returns the value at the specified index.  If
  passed two arguments, it sets the value of the specified index.
  
  When called as a setter, this method returns the new value at C<$index>.
  
  This method accepts one or two arguments.
  
  =item * B<natatime($n)>
  
  =item * B<natatime($n, $code)>
  
  This method returns an iterator which, on each call, returns C<$n> more items
  from the array, in order, like C<natatime> from L<List::MoreUtils>. A coderef
  can optionally be provided; it will be called on each group of C<$n> elements
  in the array.
  
  This method accepts one or two arguments.
  
  =item * B<shallow_clone>
  
  This method returns a shallow clone of the array reference.  The return value
  is a reference to a new array with the same elements.  It is I<shallow>
  because any elements that were references in the original will be the I<same>
  references in the clone.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_ARRAY

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Bool.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_BOOL';
  package Moose::Meta::Attribute::Native::Trait::Bool;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Bool::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Bool::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _default_is  { 'rw' }
  sub _helper_type { 'Bool' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for Bool attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Bool - Helper trait for Bool attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Room;
    use Moose;
  
    has 'is_lit' => (
        traits  => ['Bool'],
        is      => 'rw',
        isa     => 'Bool',
        default => 0,
        handles => {
            illuminate  => 'set',
            darken      => 'unset',
            flip_switch => 'toggle',
            is_dark     => 'not',
        },
    );
  
    my $room = Room->new();
    $room->illuminate;        # same as $room->is_lit(1);
    $room->darken;            # same as $room->is_lit(0);
    $room->flip_switch;       # same as $room->is_lit(not $room->is_lit);
    return $room->is_dark;    # same as !$room->is_lit
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for boolean values. A boolean is
  a scalar which can be C<1>, C<0>, C<"">, or C<undef>.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<Bool>.
  
  =head1 PROVIDED METHODS
  
  None of these methods accept arguments.
  
  =over 4
  
  =item * B<set>
  
  Sets the value to C<1> and returns C<1>.
  
  =item * B<unset>
  
  Set the value to C<0> and returns C<0>.
  
  =item * B<toggle>
  
  Toggles the value. If it's true, set to false, and vice versa.
  
  Returns the new value.
  
  =item * B<not>
  
  Equivalent of 'not C<$value>'.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_BOOL

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Code.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_CODE';
  package Moose::Meta::Attribute::Native::Trait::Code;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Code::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Code::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _helper_type { 'CodeRef' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for CodeRef attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Code - Helper trait for CodeRef attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Foo;
    use Moose;
  
    has 'callback' => (
        traits  => ['Code'],
        is      => 'ro',
        isa     => 'CodeRef',
        default => sub {
            sub { print "called" }
        },
        handles => {
            call => 'execute',
        },
    );
  
    my $foo = Foo->new;
    $foo->call;    # prints "called"
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for code references.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<CodeRef>.
  
  =head1 PROVIDED METHODS
  
  =over 4
  
  =item * B<execute(@args)>
  
  Calls the coderef with the given args.
  
  =item * B<execute_method(@args)>
  
  Calls the coderef with the the instance as invocant and given args.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_CODE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Counter.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_COUNTER';
  
  package Moose::Meta::Attribute::Native::Trait::Counter;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Counter::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Counter::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait' =>
      { -excludes => ['_root_types'] };
  
  sub _default_default { 0 }
  sub _default_is { 'ro' }
  sub _helper_type { 'Num' }
  sub _root_types { 'Num', 'Int' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for Int attributes which represent counters
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Counter - Helper trait for Int attributes which represent counters
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyHomePage;
    use Moose;
  
    has 'counter' => (
        traits  => ['Counter'],
        is      => 'ro',
        isa     => 'Num',
        default => 0,
        handles => {
            inc_counter   => 'inc',
            dec_counter   => 'dec',
            reset_counter => 'reset',
        },
    );
  
    my $page = MyHomePage->new();
    $page->inc_counter;    # same as $page->counter( $page->counter + 1 );
    $page->dec_counter;    # same as $page->counter( $page->counter - 1 );
  
    my $count_by_twos = 2;
    $page->inc_counter($count_by_twos);
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for counters. A counter can be
  any sort of number (integer or not). The delegation methods allow you to
  increment, decrement, or reset the value.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<Num>.
  
  =head1 PROVIDED METHODS
  
  =over 4
  
  =item * B<set($value)>
  
  Sets the counter to the specified value and returns the new value.
  
  This method requires a single argument.
  
  =item * B<inc>
  
  =item * B<inc($arg)>
  
  Increases the attribute value by the amount of the argument, or by 1 if no
  argument is given. This method returns the new value.
  
  This method accepts a single argument.
  
  =item * B<dec>
  
  =item * B<dec($arg)>
  
  Decreases the attribute value by the amount of the argument, or by 1 if no
  argument is given. This method returns the new value.
  
  This method accepts a single argument.
  
  =item * B<reset>
  
  Resets the value stored in this slot to its default value, and returns the new
  value.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_COUNTER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Hash.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_HASH';
  
  package Moose::Meta::Attribute::Native::Trait::Hash;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Hash::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Hash::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _helper_type { 'HashRef' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for HashRef attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Hash - Helper trait for HashRef attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Stuff;
    use Moose;
  
    has 'options' => (
        traits    => ['Hash'],
        is        => 'ro',
        isa       => 'HashRef[Str]',
        default   => sub { {} },
        handles   => {
            set_option     => 'set',
            get_option     => 'get',
            has_no_options => 'is_empty',
            num_options    => 'count',
            delete_option  => 'delete',
            option_pairs   => 'kv',
        },
    );
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for hash references.
  
  =head1 PROVIDED METHODS
  
  =over 4
  
  =item B<get($key, $key2, $key3...)>
  
  Returns values from the hash.
  
  In list context it returns a list of values in the hash for the given keys. In
  scalar context it returns the value for the last key specified.
  
  This method requires at least one argument.
  
  =item B<set($key =E<gt> $value, $key2 =E<gt> $value2...)>
  
  Sets the elements in the hash to the given values. It returns the new values
  set for each key, in the same order as the keys passed to the method.
  
  This method requires at least two arguments, and expects an even number of
  arguments.
  
  =item B<delete($key, $key2, $key3...)>
  
  Removes the elements with the given keys.
  
  In list context it returns a list of values in the hash for the deleted
  keys. In scalar context it returns the value for the last key specified.
  
  =item B<keys>
  
  Returns the list of keys in the hash.
  
  This method does not accept any arguments.
  
  =item B<exists($key)>
  
  Returns true if the given key is present in the hash.
  
  This method requires a single argument.
  
  =item B<defined($key)>
  
  Returns true if the value of a given key is defined.
  
  This method requires a single argument.
  
  =item B<values>
  
  Returns the list of values in the hash.
  
  This method does not accept any arguments.
  
  =item B<kv>
  
  Returns the key/value pairs in the hash as an array of array references.
  
    for my $pair ( $object->options->kv ) {
        print "$pair->[0] = $pair->[1]\n";
    }
  
  This method does not accept any arguments.
  
  =item B<elements>
  
  Returns the key/value pairs in the hash as a flattened list..
  
  This method does not accept any arguments.
  
  =item B<clear>
  
  Resets the hash to an empty value, like C<%hash = ()>.
  
  This method does not accept any arguments.
  
  =item B<count>
  
  Returns the number of elements in the hash. Also useful for not empty:
  C<< has_options => 'count' >>.
  
  This method does not accept any arguments.
  
  =item B<is_empty>
  
  If the hash is populated, returns false. Otherwise, returns true.
  
  This method does not accept any arguments.
  
  =item B<accessor($key)>
  
  =item B<accessor($key, $value)>
  
  If passed one argument, returns the value of the specified key. If passed two
  arguments, sets the value of the specified key.
  
  When called as a setter, this method returns the value that was set.
  
  =item B<shallow_clone>
  
  This method returns a shallow clone of the hash reference.  The return value
  is a reference to a new hash with the same keys and values.  It is I<shallow>
  because any values that were references in the original will be the I<same>
  references in the clone.
  
  =back
  
  Note that C<each> is deliberately omitted, due to its stateful interaction
  with the hash iterator. C<keys> or C<kv> are much safer.
  
  =head1 METHODS
  
  =over 4
  
  =item B<meta>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_HASH

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/Number.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_NUMBER';
  package Moose::Meta::Attribute::Native::Trait::Number;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::Number::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::Number::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _helper_type { 'Num' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for Num attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::Number - Helper trait for Num attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Real;
    use Moose;
  
    has 'integer' => (
        traits  => ['Number'],
        is      => 'ro',
        isa     => 'Num',
        default => 5,
        handles => {
            set => 'set',
            add => 'add',
            sub => 'sub',
            mul => 'mul',
            div => 'div',
            mod => 'mod',
            abs => 'abs',
        },
    );
  
    my $real = Real->new();
    $real->add(5);    # same as $real->integer($real->integer + 5);
    $real->sub(2);    # same as $real->integer($real->integer - 2);
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for numbers. All of the
  operations correspond to arithmetic operations like addition or
  multiplication.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<Num>.
  
  =head1 PROVIDED METHODS
  
  All of these methods modify the attribute's value in place. All methods return
  the new value.
  
  =over 4
  
  =item * B<add($value)>
  
  Adds the current value of the attribute to C<$value>.
  
  =item * B<sub($value)>
  
  Subtracts C<$value> from the current value of the attribute.
  
  =item * B<mul($value)>
  
  Multiplies the current value of the attribute by C<$value>.
  
  =item * B<div($value)>
  
  Divides the current value of the attribute by C<$value>.
  
  =item * B<mod($value)>
  
  Returns the current value of the attribute modulo C<$value>.
  
  =item * B<abs>
  
  Sets the current value of the attribute to its absolute value.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_NUMBER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Attribute/Native/Trait/String.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_STRING';
  package Moose::Meta::Attribute::Native::Trait::String;
  BEGIN {
    $Moose::Meta::Attribute::Native::Trait::String::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Attribute::Native::Trait::String::VERSION = '2.0401';
  }
  use Moose::Role;
  
  with 'Moose::Meta::Attribute::Native::Trait';
  
  sub _default_default { q{} }
  sub _default_is { 'rw' }
  sub _helper_type { 'Str' }
  
  no Moose::Role;
  
  1;
  
  # ABSTRACT: Helper trait for Str attributes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Attribute::Native::Trait::String - Helper trait for Str attributes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyHomePage;
    use Moose;
  
    has 'text' => (
        traits  => ['String'],
        is      => 'rw',
        isa     => 'Str',
        default => q{},
        handles => {
            add_text     => 'append',
            replace_text => 'replace',
        },
    );
  
    my $page = MyHomePage->new();
    $page->add_text("foo");    # same as $page->text($page->text . "foo");
  
  =head1 DESCRIPTION
  
  This trait provides native delegation methods for strings.
  
  =head1 DEFAULT TYPE
  
  If you don't provide an C<isa> value for your attribute, it will default to
  C<Str>.
  
  =head1 PROVIDED METHODS
  
  =over 4
  
  =item * B<inc>
  
  Increments the value stored in this slot using the magical string autoincrement
  operator. Note that Perl doesn't provide analogous behavior in C<-->, so
  C<dec> is not available. This method returns the new value.
  
  This method does not accept any arguments.
  
  =item * B<append($string)>
  
  Appends to the string, like C<.=>, and returns the new value.
  
  This method requires a single argument.
  
  =item * B<prepend($string)>
  
  Prepends to the string and returns the new value.
  
  This method requires a single argument.
  
  =item * B<replace($pattern, $replacement)>
  
  Performs a regexp substitution (L<perlop/s>). There is no way to provide the
  C<g> flag, but code references will be accepted for the replacement, causing
  the regex to be modified with a single C<e>. C</smxi> can be applied using the
  C<qr> operator. This method returns the new value.
  
  This method requires two arguments.
  
  =item * B<match($pattern)>
  
  Runs the regex against the string and returns the matching value(s).
  
  This method requires a single argument.
  
  =item * B<chop>
  
  Just like L<perlfunc/chop>. This method returns the chopped character.
  
  This method does not accept any arguments.
  
  =item * B<chomp>
  
  Just like L<perlfunc/chomp>. This method returns the number of characters
  removed.
  
  This method does not accept any arguments.
  
  =item * B<clear>
  
  Sets the string to the empty string (not the value passed to C<default>).
  
  This method does not have a defined return value.
  
  This method does not accept any arguments.
  
  =item * B<length>
  
  Just like L<perlfunc/length>, returns the length of the string.
  
  =item * B<substr>
  
  This acts just like L<perlfunc/substr>. When called as a writer, it returns
  the substring that was replaced, just like the Perl builtin.
  
  This method requires at least one argument, and accepts no more than three.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ATTRIBUTE_NATIVE_TRAIT_STRING

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Class.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_CLASS';
  
  package Moose::Meta::Class;
  BEGIN {
    $Moose::Meta::Class::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Class::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw(load_class);
  use Class::MOP;
  use Carp qw( confess );
  use Data::OptList;
  use List::Util qw( first );
  use List::MoreUtils qw( any all uniq first_index );
  use Scalar::Util 'blessed';
  
  use Moose::Meta::Method::Overridden;
  use Moose::Meta::Method::Augmented;
  use Moose::Error::Default;
  use Moose::Meta::Class::Immutable::Trait;
  use Moose::Meta::Method::Constructor;
  use Moose::Meta::Method::Destructor;
  use Moose::Meta::Method::Meta;
  use Moose::Util;
  use Class::MOP::MiniTrait;
  
  use base 'Class::MOP::Class';
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  __PACKAGE__->meta->add_attribute('roles' => (
      reader  => 'roles',
      default => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('role_applications' => (
      reader  => '_get_role_applications',
      default => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute(
      Class::MOP::Attribute->new('immutable_trait' => (
          accessor => "immutable_trait",
          default  => 'Moose::Meta::Class::Immutable::Trait',
          Class::MOP::_definition_context(),
      ))
  );
  
  __PACKAGE__->meta->add_attribute('constructor_class' => (
      accessor => 'constructor_class',
      default  => 'Moose::Meta::Method::Constructor',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('destructor_class' => (
      accessor => 'destructor_class',
      default  => 'Moose::Meta::Method::Destructor',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('error_class' => (
      accessor => 'error_class',
      default  => 'Moose::Error::Default',
      Class::MOP::_definition_context(),
  ));
  
  sub initialize {
      my $class = shift;
      my @args = @_;
      unshift @args, 'package' if @args % 2;
      my %opts = @args;
      my $package = delete $opts{package};
      return Class::MOP::get_metaclass_by_name($package)
          || $class->SUPER::initialize($package,
                  'attribute_metaclass' => 'Moose::Meta::Attribute',
                  'method_metaclass'    => 'Moose::Meta::Method',
                  'instance_metaclass'  => 'Moose::Meta::Instance',
                  %opts,
              );
  }
  
  sub create {
      my $class = shift;
      my @args = @_;
  
      unshift @args, 'package' if @args % 2 == 1;
      my %options = @args;
  
      (ref $options{roles} eq 'ARRAY')
          || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
              if exists $options{roles};
  
      my $package = delete $options{package};
      my $roles   = delete $options{roles};
  
      my $new_meta = $class->SUPER::create($package, %options);
  
      if ($roles) {
          Moose::Util::apply_all_roles( $new_meta, @$roles );
      }
  
      return $new_meta;
  }
  
  sub _meta_method_class { 'Moose::Meta::Method::Meta' }
  
  sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' }
  
  sub _anon_cache_key {
      my $class = shift;
      my %options = @_;
  
      my $superclass_key = join('|',
          map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) }
      );
  
      my $roles = Data::OptList::mkopt(($options{roles} || []), {
          moniker  => 'role',
          val_test => sub { ref($_[0]) eq 'HASH' },
      });
  
      my @role_keys;
      for my $role_spec (@$roles) {
          my ($role, $params) = @$role_spec;
          $params = { %$params } if $params;
  
          my $key = blessed($role) ? $role->name : $role;
  
          if ($params && %$params) {
              my $alias    = delete $params->{'-alias'}
                          || delete $params->{'alias'}
                          || {};
              my $excludes = delete $params->{'-excludes'}
                          || delete $params->{'excludes'}
                          || [];
              $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
  
              if (%$params) {
                  warn "Roles with parameters cannot be cached. Consider "
                     . "applying the parameters before calling "
                     . "create_anon_class, or using 'weaken => 0' instead";
                  return;
              }
  
              my $alias_key = join('%',
                  map { $_ => $alias->{$_} } sort keys %$alias
              );
              my $excludes_key = join('%',
                  sort @$excludes
              );
              $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>';
          }
  
          push @role_keys, $key;
      }
  
      my $role_key = join('|', sort @role_keys);
  
      # Makes something like Super::Class|Super::Class::2=Role|Role::1
      return join('=', $superclass_key, $role_key);
  }
  
  sub reinitialize {
      my $self = shift;
      my $pkg  = shift;
  
      my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
  
      my %existing_classes;
      if ($meta) {
          %existing_classes = map { $_ => $meta->$_() } qw(
              attribute_metaclass
              method_metaclass
              wrapped_method_metaclass
              instance_metaclass
              constructor_class
              destructor_class
              error_class
          );
      }
  
      return $self->SUPER::reinitialize(
          $pkg,
          %existing_classes,
          @_,
      );
  }
  
  sub add_role {
      my ($self, $role) = @_;
      (blessed($role) && $role->isa('Moose::Meta::Role'))
          || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
      push @{$self->roles} => $role;
  }
  
  sub role_applications {
      my ($self) = @_;
  
      return @{$self->_get_role_applications};
  }
  
  sub add_role_application {
      my ($self, $application) = @_;
      (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
          || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
      push @{$self->_get_role_applications} => $application;
  }
  
  sub calculate_all_roles {
      my $self = shift;
      my %seen;
      grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
  }
  
  sub calculate_all_roles_with_inheritance {
      my $self = shift;
      my %seen;
      grep { !$seen{$_->name}++ }
           map { Class::MOP::class_of($_)->can('calculate_all_roles')
                     ? Class::MOP::class_of($_)->calculate_all_roles
                     : () }
               $self->linearized_isa;
  }
  
  sub does_role {
      my ($self, $role_name) = @_;
  
      (defined $role_name)
          || $self->throw_error("You must supply a role name to look for");
  
      foreach my $class ($self->class_precedence_list) {
          my $meta = Class::MOP::class_of($class);
          # when a Moose metaclass is itself extended with a role,
          # this check needs to be done since some items in the
          # class_precedence_list might in fact be Class::MOP
          # based still.
          next unless $meta && $meta->can('roles');
          foreach my $role (@{$meta->roles}) {
              return 1 if $role->does_role($role_name);
          }
      }
      return 0;
  }
  
  sub excludes_role {
      my ($self, $role_name) = @_;
  
      (defined $role_name)
          || $self->throw_error("You must supply a role name to look for");
  
      foreach my $class ($self->class_precedence_list) {
          my $meta = Class::MOP::class_of($class);
          # when a Moose metaclass is itself extended with a role,
          # this check needs to be done since some items in the
          # class_precedence_list might in fact be Class::MOP
          # based still.
          next unless $meta && $meta->can('roles');
          foreach my $role (@{$meta->roles}) {
              return 1 if $role->excludes_role($role_name);
          }
      }
      return 0;
  }
  
  sub new_object {
      my $self   = shift;
      my $params = @_ == 1 ? $_[0] : {@_};
      my $object = $self->SUPER::new_object($params);
  
      $self->_call_all_triggers($object, $params);
  
      $object->BUILDALL($params) if $object->can('BUILDALL');
  
      return $object;
  }
  
  sub _call_all_triggers {
      my ($self, $object, $params) = @_;
  
      foreach my $attr ( $self->get_all_attributes() ) {
  
          next unless $attr->can('has_trigger') && $attr->has_trigger;
  
          my $init_arg = $attr->init_arg;
          next unless defined $init_arg;
          next unless exists $params->{$init_arg};
  
          $attr->trigger->(
              $object,
              (
                    $attr->should_coerce
                  ? $attr->get_read_method_ref->($object)
                  : $params->{$init_arg}
              ),
          );
      }
  }
  
  sub _generate_fallback_constructor {
      my $self = shift;
      my ($class) = @_;
      return $class . '->Moose::Object::new(@_)'
  }
  
  sub _inline_params {
      my $self = shift;
      my ($params, $class) = @_;
      return (
          'my ' . $params . ' = ',
          $self->_inline_BUILDARGS($class, '@_'),
          ';',
      );
  }
  
  sub _inline_BUILDARGS {
      my $self = shift;
      my ($class, $args) = @_;
  
      my $buildargs = $self->find_method_by_name("BUILDARGS");
  
      if ($args eq '@_'
       && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
          return (
              'do {',
                  'my $params;',
                  'if (scalar @_ == 1) {',
                      'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
                          $self->_inline_throw_error(
                              '"Single parameters to new() must be a HASH ref"',
                              'data => $_[0]',
                          ) . ';',
                      '}',
                      '$params = { %{ $_[0] } };',
                  '}',
                  'elsif (@_ % 2) {',
                      'Carp::carp(',
                          '"The new() method for ' . $class . ' expects a '
                        . 'hash reference or a key/value list. You passed an '
                        . 'odd number of arguments"',
                      ');',
                      '$params = {@_, undef};',
                  '}',
                  'else {',
                      '$params = {@_};',
                  '}',
                  '$params;',
              '}',
          );
      }
      else {
          return $class . '->BUILDARGS(' . $args . ')';
      }
  }
  
  sub _inline_slot_initializer {
      my $self  = shift;
      my ($attr, $idx) = @_;
  
      return (
          '## ' . $attr->name,
          $self->_inline_check_required_attr($attr),
          $self->SUPER::_inline_slot_initializer(@_),
      );
  }
  
  sub _inline_check_required_attr {
      my $self = shift;
      my ($attr) = @_;
  
      return unless defined $attr->init_arg;
      return unless $attr->can('is_required') && $attr->is_required;
      return if $attr->has_default || $attr->has_builder;
  
      return (
          'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
              $self->_inline_throw_error(
                  '"Attribute (' . quotemeta($attr->name) . ') is required"'
              ) . ';',
          '}',
      );
  }
  
  # XXX: these two are duplicated from cmop, because we have to pass the tc stuff
  # through to _inline_set_value - this should probably be fixed, but i'm not
  # quite sure how. -doy
  sub _inline_init_attr_from_constructor {
      my $self = shift;
      my ($attr, $idx) = @_;
  
      my @initial_value = $attr->_inline_set_value(
          '$instance',
          '$params->{\'' . $attr->init_arg . '\'}',
          '$type_constraint_bodies[' . $idx . ']',
          '$type_coercions[' . $idx . ']',
          '$type_constraint_messages[' . $idx . ']',
          'for constructor',
      );
  
      push @initial_value, (
          '$attrs->[' . $idx . ']->set_initial_value(',
              '$instance,',
              $attr->_inline_instance_get('$instance'),
          ');',
      ) if $attr->has_initializer;
  
      return @initial_value;
  }
  
  sub _inline_init_attr_from_default {
      my $self = shift;
      my ($attr, $idx) = @_;
  
      return if $attr->can('is_lazy') && $attr->is_lazy;
      my $default = $self->_inline_default_value($attr, $idx);
      return unless $default;
  
      my @initial_value = (
          'my $default = ' . $default . ';',
          $attr->_inline_set_value(
              '$instance',
              '$default',
              '$type_constraint_bodies[' . $idx . ']',
              '$type_coercions[' . $idx . ']',
              '$type_constraint_messages[' . $idx . ']',
              'for constructor',
          ),
      );
  
      push @initial_value, (
          '$attrs->[' . $idx . ']->set_initial_value(',
              '$instance,',
              $attr->_inline_instance_get('$instance'),
          ');',
      ) if $attr->has_initializer;
  
      return @initial_value;
  }
  
  sub _inline_extra_init {
      my $self = shift;
      return (
          $self->_inline_triggers,
          $self->_inline_BUILDALL,
      );
  }
  
  sub _inline_triggers {
      my $self = shift;
      my @trigger_calls;
  
      my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
      for my $i (0 .. $#attrs) {
          my $attr = $attrs[$i];
  
          next unless $attr->can('has_trigger') && $attr->has_trigger;
  
          my $init_arg = $attr->init_arg;
          next unless defined $init_arg;
  
          push @trigger_calls,
              'if (exists $params->{\'' . $init_arg . '\'}) {',
                  '$triggers->[' . $i . ']->(',
                      '$instance,',
                      $attr->_inline_instance_get('$instance') . ',',
                  ');',
              '}';
      }
  
      return @trigger_calls;
  }
  
  sub _inline_BUILDALL {
      my $self = shift;
  
      my @methods = reverse $self->find_all_methods_by_name('BUILD');
      my @BUILD_calls;
  
      foreach my $method (@methods) {
          push @BUILD_calls,
              '$instance->' . $method->{class} . '::BUILD($params);';
      }
  
      return @BUILD_calls;
  }
  
  sub _eval_environment {
      my $self = shift;
  
      my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
  
      my $triggers = [
          map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef }
              @attrs
      ];
  
      # We need to check if the attribute ->can('type_constraint')
      # since we may be trying to immutabilize a Moose meta class,
      # which in turn has attributes which are Class::MOP::Attribute
      # objects, rather than Moose::Meta::Attribute. And
      # Class::MOP::Attribute attributes have no type constraints.
      # However we need to make sure we leave an undef value there
      # because the inlined code is using the index of the attributes
      # to determine where to find the type constraint
  
      my @type_constraints = map {
          $_->can('type_constraint') ? $_->type_constraint : undef
      } @attrs;
  
      my @type_constraint_bodies = map {
          defined $_ ? $_->_compiled_type_constraint : undef;
      } @type_constraints;
  
      my @type_coercions = map {
          defined $_ && $_->has_coercion
              ? $_->coercion->_compiled_type_coercion
              : undef
      } @type_constraints;
  
      my @type_constraint_messages = map {
          defined $_
              ? ($_->has_message ? $_->message : $_->_default_message)
              : undef
      } @type_constraints;
  
      return {
          %{ $self->SUPER::_eval_environment },
          ((any { defined && $_->has_initializer } @attrs)
              ? ('$attrs' => \[@attrs])
              : ()),
          '$triggers' => \$triggers,
          '@type_coercions' => \@type_coercions,
          '@type_constraint_bodies' => \@type_constraint_bodies,
          '@type_constraint_messages' => \@type_constraint_messages,
          ( map { defined($_) ? %{ $_->inline_environment } : () }
                @type_constraints ),
          # pretty sure this is only going to be closed over if you use a custom
          # error class at this point, but we should still get rid of this
          # at some point
          '$meta'  => \$self,
      };
  }
  
  sub superclasses {
      my $self = shift;
      my $supers = Data::OptList::mkopt(\@_);
      foreach my $super (@{ $supers }) {
          my ($name, $opts) = @{ $super };
          load_class($name, $opts);
          my $meta = Class::MOP::class_of($name);
          $self->throw_error("You cannot inherit from a Moose Role ($name)")
              if $meta && $meta->isa('Moose::Meta::Role')
      }
      return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
  }
  
  ### ---------------------------------------------
  
  sub add_attribute {
      my $self = shift;
      my $attr =
          (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
              ? $_[0]
              : $self->_process_attribute(@_));
      $self->SUPER::add_attribute($attr);
      # it may be a Class::MOP::Attribute, theoretically, which doesn't have
      # 'bare' and doesn't implement this method
      if ($attr->can('_check_associated_methods')) {
          $attr->_check_associated_methods;
      }
      return $attr;
  }
  
  sub add_override_method_modifier {
      my ($self, $name, $method, $_super_package) = @_;
  
      (!$self->has_method($name))
          || $self->throw_error("Cannot add an override method if a local method is already present");
  
      $self->add_method($name => Moose::Meta::Method::Overridden->new(
          method  => $method,
          class   => $self,
          package => $_super_package, # need this for roles
          name    => $name,
      ));
  }
  
  sub add_augment_method_modifier {
      my ($self, $name, $method) = @_;
      (!$self->has_method($name))
          || $self->throw_error("Cannot add an augment method if a local method is already present");
  
      $self->add_method($name => Moose::Meta::Method::Augmented->new(
          method  => $method,
          class   => $self,
          name    => $name,
      ));
  }
  
  ## Private Utility methods ...
  
  sub _find_next_method_by_name_which_is_not_overridden {
      my ($self, $name) = @_;
      foreach my $method ($self->find_all_methods_by_name($name)) {
          return $method->{code}
              if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
      }
      return undef;
  }
  
  ## Metaclass compatibility
  
  sub _base_metaclasses {
      my $self = shift;
      my %metaclasses = $self->SUPER::_base_metaclasses;
      for my $class (keys %metaclasses) {
          $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
      }
      return (
          %metaclasses,
          error_class => 'Moose::Error::Default',
      );
  }
  
  sub _fix_class_metaclass_incompatibility {
      my $self = shift;
      my ($super_meta) = @_;
  
      $self->SUPER::_fix_class_metaclass_incompatibility(@_);
  
      if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
          ($self->is_pristine)
              || confess "Can't fix metaclass incompatibility for "
                       . $self->name
                       . " because it is not pristine.";
          my $super_meta_name = $super_meta->_real_ref_name;
          my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
          my $new_self = $class_meta_subclass_meta_name->reinitialize(
              $self->name,
          );
  
          $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
      }
  }
  
  sub _fix_single_metaclass_incompatibility {
      my $self = shift;
      my ($metaclass_type, $super_meta) = @_;
  
      $self->SUPER::_fix_single_metaclass_incompatibility(@_);
  
      if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
          ($self->is_pristine)
              || confess "Can't fix metaclass incompatibility for "
                       . $self->name
                       . " because it is not pristine.";
          my $super_meta_name = $super_meta->_real_ref_name;
          my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
          my $new_self = $super_meta->reinitialize(
              $self->name,
              $metaclass_type => $class_specific_meta_subclass_meta_name,
          );
  
          $self->_replace_self( $new_self, $super_meta_name );
      }
  }
  
  sub _replace_self {
      my $self      = shift;
      my ( $new_self, $new_class)   = @_;
  
      %$self = %$new_self;
      bless $self, $new_class;
  
      # We need to replace the cached metaclass instance or else when it goes
      # out of scope Class::MOP::Class destroy's the namespace for the
      # metaclass's class, causing much havoc.
      my $weaken = Class::MOP::metaclass_is_weak( $self->name );
      Class::MOP::store_metaclass_by_name( $self->name, $self );
      Class::MOP::weaken_metaclass( $self->name ) if $weaken;
  }
  
  sub _process_attribute {
      my ( $self, $name, @args ) = @_;
  
      @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
  
      if (($name || '') =~ /^\+(.*)/) {
          return $self->_process_inherited_attribute($1, @args);
      }
      else {
          return $self->_process_new_attribute($name, @args);
      }
  }
  
  sub _process_new_attribute {
      my ( $self, $name, @args ) = @_;
  
      $self->attribute_metaclass->interpolate_class_and_new($name, @args);
  }
  
  sub _process_inherited_attribute {
      my ($self, $attr_name, %options) = @_;
      my $inherited_attr = $self->find_attribute_by_name($attr_name);
      (defined $inherited_attr)
          || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
      if ($inherited_attr->isa('Moose::Meta::Attribute')) {
          return $inherited_attr->clone_and_inherit_options(%options);
      }
      else {
          # NOTE:
          # kind of a kludge to handle Class::MOP::Attributes
          return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
      }
  }
  
  # reinitialization support
  
  sub _restore_metaobjects_from {
      my $self = shift;
      my ($old_meta) = @_;
  
      $self->SUPER::_restore_metaobjects_from($old_meta);
  
      for my $role ( @{ $old_meta->roles } ) {
          $self->add_role($role);
      }
  
      for my $application ( @{ $old_meta->_get_role_applications } ) {
          $application->class($self);
          $self->add_role_application ($application);
      }
  }
  
  ## Immutability
  
  sub _immutable_options {
      my ( $self, @args ) = @_;
  
      $self->SUPER::_immutable_options(
          inline_destructor => 1,
  
          # Moose always does this when an attribute is created
          inline_accessors => 0,
  
          @args,
      );
  }
  
  sub _fixup_attributes_after_rebless {
      my $self = shift;
      my ($instance, $rebless_from, %params) = @_;
  
      $self->SUPER::_fixup_attributes_after_rebless(
          $instance,
          $rebless_from,
          %params
      );
  
      $self->_call_all_triggers( $instance, \%params );
  }
  
  ## -------------------------------------------------
  
  our $error_level;
  
  sub throw_error {
      my ( $self, @args ) = @_;
      local $error_level = ($error_level || 0) + 1;
      $self->raise_error($self->create_error(@args));
  }
  
  sub _inline_throw_error {
      my ( $self, @args ) = @_;
      $self->_inline_raise_error($self->_inline_create_error(@args));
  }
  
  sub raise_error {
      my ( $self, @args ) = @_;
      die @args;
  }
  
  sub _inline_raise_error {
      my ( $self, $message ) = @_;
  
      return 'die ' . $message;
  }
  
  sub create_error {
      my ( $self, @args ) = @_;
  
      require Carp::Heavy;
  
      local $error_level = ($error_level || 0 ) + 1;
  
      if ( @args % 2 == 1 ) {
          unshift @args, "message";
      }
  
      my %args = ( metaclass => $self, last_error => $@, @args );
  
      $args{depth} += $error_level;
  
      my $class = ref $self ? $self->error_class : "Moose::Error::Default";
  
      load_class($class);
  
      $class->new(
          Carp::caller_info($args{depth}),
          %args
      );
  }
  
  sub _inline_create_error {
      my ( $self, $msg, $args ) = @_;
      # XXX ignore $args for now, nothing currently uses it anyway
  
      require Carp::Heavy;
  
      my %args = (
          metaclass  => $self,
          last_error => $@,
          message    => $msg,
      );
  
      my $class = ref $self ? $self->error_class : "Moose::Error::Default";
  
      load_class($class);
  
      # don't check inheritance here - the intention is that the class needs
      # to provide a non-inherited inlining method, because falling back to
      # the default inlining method is most likely going to be wrong
      # yes, this is a huge hack, but so is the entire error system, so.
      return
            '$meta->create_error('
          . $msg
          . ( defined $args ? ', ' . $args : q{} ) . ');'
          unless $class->meta->has_method('_inline_new');
  
      $class->_inline_new(
          # XXX ignore this for now too
          # Carp::caller_info($args{depth}),
          %args
      );
  }
  
  1;
  
  # ABSTRACT: The Moose metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Class - The Moose metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Class> that provides
  additional Moose-specific functionality.
  
  To really understand this class, you will need to start with the
  L<Class::MOP::Class> documentation. This class can be understood as a
  set of additional features on top of the basic feature provided by
  that parent class.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
  
  This overrides the parent's method in order to provide its own
  defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
  C<method_metaclass> options.
  
  These all default to the appropriate Moose class.
  
  =item B<< Moose::Meta::Class->create($package_name, %options) >>
  
  This overrides the parent's method in order to accept a C<roles>
  option. This should be an array reference containing roles
  that the class does, each optionally followed by a hashref of options
  (C<-excludes> and C<-alias>).
  
    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
  
  =item B<< Moose::Meta::Class->create_anon_class >>
  
  This overrides the parent's method to accept a C<roles> option, just
  as C<create> does.
  
  It also accepts a C<cache> option. If this is true, then the anonymous
  class will be cached based on its superclasses and roles. If an
  existing anonymous class in the cache has the same superclasses and
  roles, it will be reused.
  
    my $metaclass = Moose::Meta::Class->create_anon_class(
        superclasses => ['Foo'],
        roles        => [qw/Some Roles Go Here/],
        cache        => 1,
    );
  
  Each entry in both the C<superclasses> and the C<roles> option can be
  followed by a hash reference with arguments. The C<superclasses>
  option can be supplied with a L<-version|Class::MOP/Class Loading
  Options> option that ensures the loaded superclass satisfies the
  required version. The C<role> option also takes the C<-version> as an
  argument, but the option hash reference can also contain any other
  role relevant values like exclusions or parameterized role arguments.
  
  =item B<< $metaclass->new_object(%params) >>
  
  This overrides the parent's method in order to add support for
  attribute triggers.
  
  =item B<< $metaclass->superclasses(@superclasses) >>
  
  This is the accessor allowing you to read or change the parents of
  the class.
  
  Each superclass can be followed by a hash reference containing a
  L<-version|Class::MOP/Class Loading Options> value. If the version
  requirement is not satisfied an error will be thrown.
  
  =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
  
  This adds an C<override> method modifier to the package.
  
  =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
  
  This adds an C<augment> method modifier to the package.
  
  =item B<< $metaclass->calculate_all_roles >>
  
  This will return a unique array of C<Moose::Meta::Role> instances
  which are attached to this class.
  
  =item B<< $metaclass->calculate_all_roles_with_inheritance >>
  
  This will return a unique array of C<Moose::Meta::Role> instances
  which are attached to this class, and each of this class's ancestors.
  
  =item B<< $metaclass->add_role($role) >>
  
  This takes a L<Moose::Meta::Role> object, and adds it to the class's
  list of roles. This I<does not> actually apply the role to the class.
  
  =item B<< $metaclass->role_applications >>
  
  Returns a list of L<Moose::Meta::Role::Application::ToClass>
  objects, which contain the arguments to role application.
  
  =item B<< $metaclass->add_role_application($application) >>
  
  This takes a L<Moose::Meta::Role::Application::ToClass> object, and
  adds it to the class's list of role applications. This I<does not>
  actually apply any role to the class; it is only for tracking role
  applications.
  
  =item B<< $metaclass->does_role($role) >>
  
  This returns a boolean indicating whether or not the class does the specified
  role. The role provided can be either a role name or a L<Moose::Meta::Role>
  object. This tests both the class and its parents.
  
  =item B<< $metaclass->excludes_role($role_name) >>
  
  A class excludes a role if it has already composed a role which
  excludes the named role. This tests both the class and its parents.
  
  =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
  
  This overrides the parent's method in order to allow the parameters to
  be provided as a hash reference.
  
  =item B<< $metaclass->constructor_class($class_name) >>
  
  =item B<< $metaclass->destructor_class($class_name) >>
  
  These are the names of classes used when making a class immutable. These
  default to L<Moose::Meta::Method::Constructor> and
  L<Moose::Meta::Method::Destructor> respectively. These accessors are
  read-write, so you can use them to change the class name.
  
  =item B<< $metaclass->error_class($class_name) >>
  
  The name of the class used to throw errors. This defaults to
  L<Moose::Error::Default>, which generates an error with a stacktrace
  just like C<Carp::confess>.
  
  =item B<< $metaclass->throw_error($message, %extra) >>
  
  Throws the error created by C<create_error> using C<raise_error>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_CLASS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Class/Immutable/Trait.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_CLASS_IMMUTABLE_TRAIT';
  package Moose::Meta::Class::Immutable::Trait;
  BEGIN {
    $Moose::Meta::Class::Immutable::Trait::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Class::Immutable::Trait::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP;
  use Scalar::Util qw( blessed );
  
  use base 'Class::MOP::Class::Immutable::Trait';
  
  sub add_role { $_[1]->_immutable_cannot_call }
  
  sub calculate_all_roles {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{calculate_all_roles} ||= [ $self->$orig ] };
  }
  
  sub calculate_all_roles_with_inheritance {
      my $orig = shift;
      my $self = shift;
      @{ $self->{__immutable}{calculate_all_roles_with_inheritance} ||= [ $self->$orig ] };
  }
  
  sub does_role {
      shift;
      my $self = shift;
      my $role = shift;
  
      (defined $role)
          || $self->throw_error("You must supply a role name to look for");
  
      $self->{__immutable}{does_role} ||= { map { $_->name => 1 } $self->calculate_all_roles_with_inheritance };
  
      my $name = blessed $role ? $role->name : $role;
  
      return $self->{__immutable}{does_role}{$name};
  }
  
  1;
  
  # ABSTRACT: Implements immutability for metaclass objects
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Class::Immutable::Trait - Implements immutability for metaclass objects
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class makes some Moose-specific metaclass methods immutable. This
  is deep guts.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_CLASS_IMMUTABLE_TRAIT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Instance.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_INSTANCE';
  
  package Moose::Meta::Instance;
  BEGIN {
    $Moose::Meta::Instance::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Instance::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::MiniTrait;
  
  use base "Class::MOP::Instance";
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  1;
  
  # ABSTRACT: The Moose Instance metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Instance - The Moose Instance metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
      # nothing to see here
  
  =head1 DESCRIPTION
  
  This class provides the low level data storage abstractions for
  attributes.
  
  Using this API directly in your own code violates encapsulation, and
  we recommend that you use the appropriate APIs in
  L<Moose::Meta::Class> and L<Moose::Meta::Attribute> instead. Those
  APIs in turn call the methods in this class as appropriate.
  
  At present, this is an empty subclass of L<Class::MOP::Instance>, so
  you should see that class for all API details.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Instance> is a subclass of L<Class::MOP::Instance>.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_INSTANCE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD';
  package Moose::Meta::Method;
  BEGIN {
    $Moose::Meta::Method::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::MiniTrait;
  
  use base 'Class::MOP::Method';
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  sub _error_thrower {
      my $self = shift;
      require Moose::Meta::Class;
      ( ref $self && $self->associated_metaclass ) || "Moose::Meta::Class";
  }
  
  sub throw_error {
      my $self = shift;
      my $inv = $self->_error_thrower;
      unshift @_, "message" if @_ % 2 == 1;
      unshift @_, method => $self if ref $self;
      unshift @_, $inv;
      my $handler = $inv->can("throw_error");
      goto $handler; # to avoid incrementing depth by 1
  }
  
  sub _inline_throw_error {
      my ( $self, $msg, $args ) = @_;
  
      my $inv = $self->_error_thrower;
      # XXX ugh
      $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
  
      # XXX ugh ugh UGH
      my $class = $self->associated_metaclass;
      if ($class) {
          my $class_name = B::perlstring($class->name);
          my $meth_name = B::perlstring($self->name);
          $args = 'method => Class::MOP::class_of(' . $class_name . ')'
                . '->find_method_by_name(' . $meth_name . '), '
                . (defined $args ? $args : '');
      }
  
      return $inv->_inline_throw_error($msg, $args)
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method - A Moose Method metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Method> that provides
  additional Moose-specific functionality, all of which is private.
  
  To understand this class, you should read the the L<Class::MOP::Method>
  documentation.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Method> is a subclass of L<Class::MOP::Method>.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR';
  
  package Moose::Meta::Method::Accessor;
  BEGIN {
    $Moose::Meta::Method::Accessor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Try::Tiny;
  
  use base 'Moose::Meta::Method',
           'Class::MOP::Method::Accessor';
  
  # multiple inheritance is terrible
  sub new {
      goto &Class::MOP::Method::Accessor::new;
  }
  
  sub _new {
      goto &Class::MOP::Method::Accessor::_new;
  }
  
  sub _error_thrower {
      my $self = shift;
      return $self->associated_attribute
          if ref($self) && defined($self->associated_attribute);
      return $self->SUPER::_error_thrower;
  }
  
  sub _compile_code {
      my $self = shift;
      my @args = @_;
      try {
          $self->SUPER::_compile_code(@args);
      }
      catch {
          $self->throw_error(
              'Could not create writer for '
            . "'" . $self->associated_attribute->name . "' "
            . 'because ' . $_,
              error => $_,
          );
      };
  }
  
  sub _eval_environment {
      my $self = shift;
      return $self->associated_attribute->_eval_environment;
  }
  
  sub _instance_is_inlinable {
      my $self = shift;
      return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
  }
  
  sub _generate_reader_method {
      my $self = shift;
      $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
                                    : $self->SUPER::_generate_reader_method(@_);
  }
  
  sub _generate_writer_method {
      my $self = shift;
      $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
                                    : $self->SUPER::_generate_writer_method(@_);
  }
  
  sub _generate_accessor_method {
      my $self = shift;
      $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
                                    : $self->SUPER::_generate_accessor_method(@_);
  }
  
  sub _generate_predicate_method {
      my $self = shift;
      $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
                                    : $self->SUPER::_generate_predicate_method(@_);
  }
  
  sub _generate_clearer_method {
      my $self = shift;
      $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
                                    : $self->SUPER::_generate_clearer_method(@_);
  }
  
  sub _writer_value_needs_copy {
      shift->associated_attribute->_writer_value_needs_copy(@_);
  }
  
  sub _inline_tc_code {
      shift->associated_attribute->_inline_tc_code(@_);
  }
  
  sub _inline_check_coercion {
      shift->associated_attribute->_inline_check_coercion(@_);
  }
  
  sub _inline_check_constraint {
      shift->associated_attribute->_inline_check_constraint(@_);
  }
  
  sub _inline_check_lazy {
      shift->associated_attribute->_inline_check_lazy(@_);
  }
  
  sub _inline_store_value {
      shift->associated_attribute->_inline_instance_set(@_) . ';';
  }
  
  sub _inline_get_old_value_for_trigger {
      shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
  }
  
  sub _inline_trigger {
      shift->associated_attribute->_inline_trigger(@_);
  }
  
  sub _get_value {
      shift->associated_attribute->_inline_instance_get(@_);
  }
  
  sub _has_value {
      shift->associated_attribute->_inline_instance_has(@_);
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for accessors
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Method::Accessor> that
  provides additional Moose-specific functionality, all of which is
  private.
  
  To understand this class, you should read the the
  L<Class::MOP::Method::Accessor> documentation.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE';
  package Moose::Meta::Method::Accessor::Native;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp qw( confess );
  use Scalar::Util qw( blessed weaken );
  
  use Moose::Role;
  
  around new => sub {
      my $orig = shift;
      my $class   = shift;
      my %options = @_;
  
      $options{curried_arguments} = []
          unless exists $options{curried_arguments};
  
      confess 'You must supply a curried_arguments which is an ARRAY reference'
          unless $options{curried_arguments}
              && ref($options{curried_arguments}) eq 'ARRAY';
  
      my $attr_context = $options{attribute}->definition_context;
      my $desc = 'native delegation method ';
      $desc   .= $options{attribute}->associated_class->name;
      $desc   .= '::' . $options{name};
      $desc   .= " ($options{delegate_to_method})";
      $desc   .= " of attribute " . $options{attribute}->name;
      $options{definition_context} = {
          %{ $attr_context || {} },
          description => $desc,
      };
  
      $options{accessor_type} = 'native';
  
      return $class->$orig(%options);
  };
  
  sub _new {
      my $class = shift;
      my $options = @_ == 1 ? $_[0] : {@_};
  
      return bless $options, $class;
  }
  
  sub root_types { (shift)->{'root_types'} }
  
  sub _initialize_body {
      my $self = shift;
  
      $self->{'body'} = $self->_compile_code( [$self->_generate_method] );
  
      return;
  }
  
  sub _inline_curried_arguments {
      my $self = shift;
  
      return unless @{ $self->curried_arguments };
  
      return 'unshift @_, @curried;';
  }
  
  sub _inline_check_argument_count {
      my $self = shift;
  
      my @code;
  
      if (my $min = $self->_minimum_arguments) {
          push @code, (
              'if (@_ < ' . $min . ') {',
                  $self->_inline_throw_error(
                      sprintf(
                          '"Cannot call %s without at least %s argument%s"',
                          $self->delegate_to_method,
                          $min,
                          ($min == 1 ? '' : 's'),
                      )
                  ) . ';',
              '}',
          );
      }
  
      if (defined(my $max = $self->_maximum_arguments)) {
          push @code, (
              'if (@_ > ' . $max . ') {',
                  $self->_inline_throw_error(
                      sprintf(
                          '"Cannot call %s with %s argument%s"',
                          $self->delegate_to_method,
                          $max ? "more than $max" : 'any',
                          ($max == 1 ? '' : 's'),
                      )
                  ) . ';',
              '}',
          );
      }
  
      return @code;
  }
  
  sub _inline_return_value {
      my $self = shift;
      my ($slot_access, $for_writer) = @_;
  
      return 'return ' . $self->_return_value($slot_access, $for_writer) . ';';
  }
  
  sub _minimum_arguments { 0 }
  sub _maximum_arguments { undef }
  
  override _get_value => sub {
      my $self = shift;
      my ($instance) = @_;
  
      return $self->_slot_access_can_be_inlined
          ? super()
          : $instance . '->$reader';
  };
  
  override _inline_store_value => sub {
      my $self = shift;
      my ($instance, $value) = @_;
  
      return $self->_slot_access_can_be_inlined
          ? super()
          : $instance . '->$writer(' . $value . ');';
  };
  
  override _eval_environment => sub {
      my $self = shift;
  
      my $env = super();
  
      $env->{'@curried'} = $self->curried_arguments;
  
      return $env if $self->_slot_access_can_be_inlined;
  
      my $reader = $self->associated_attribute->get_read_method_ref;
      $reader = $reader->body if blessed $reader;
  
      $env->{'$reader'} = \$reader;
  
      my $writer = $self->associated_attribute->get_write_method_ref;
      $writer = $writer->body if blessed $writer;
  
      $env->{'$writer'} = \$writer;
  
      return $env;
  };
  
  sub _slot_access_can_be_inlined {
      my $self = shift;
  
      return $self->is_inline && $self->_instance_is_inlinable;
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY';
  package Moose::Meta::Method::Accessor::Native::Array;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  use Scalar::Util qw( looks_like_number );
  
  sub _inline_check_var_is_valid_index {
      my $self = shift;
      my ($var) = @_;
  
      return (
          'if (!defined(' . $var . ') || ' . $var . ' !~ /^-?\d+$/) {',
              $self->_inline_throw_error(
                  '"The index passed to ' . $self->delegate_to_method
                . ' must be an integer"',
              ) . ';',
          '}',
      );
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/Writer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_WRITER';
  package Moose::Meta::Method::Accessor::Native::Array::Writer;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::Writer::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::Writer::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
          -excludes => ['_inline_coerce_new_values'],
      },
      'Moose::Meta::Method::Accessor::Native::Array',
      'Moose::Meta::Method::Accessor::Native::Collection';
  
  sub _new_members { '@_' }
  
  sub _copy_old_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @{(' . $slot_access . ')} ]';
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_WRITER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/accessor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_ACCESSOR';
  package Moose::Meta::Method::Accessor::Native::Array::accessor;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::accessor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::accessor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::set' => {
      -excludes => [
          qw( _generate_method
              _minimum_arguments
              _maximum_arguments
              _inline_process_arguments
              _inline_check_arguments
              _return_value)
      ]
      },
      'Moose::Meta::Method::Accessor::Native::Array::get' => {
      -excludes => [
          qw(
              _generate_method
              _minimum_arguments
              _maximum_arguments
              )
      ]
      };
  
  sub _generate_method {
      my $self = shift;
  
      my $inv         = '$self';
      my $slot_access = $self->_get_value($inv);
  
      return (
          'sub {',
              'my ' . $inv . ' = shift;',
              $self->_inline_curried_arguments,
              $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
              # get
              'if (@_ == 1) {',
                  $self->_inline_check_var_is_valid_index('$_[0]'),
                  $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_return_value($slot_access),
              '}',
              # set
              'else {',
                  $self->_inline_writer_core($inv, $slot_access),
              '}',
          '}',
      );
  }
  
  sub _minimum_arguments { 1 }
  sub _maximum_arguments { 2 }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_ACCESSOR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/clear.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_CLEAR';
  package Moose::Meta::Method::Accessor::Native::Array::clear;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::clear::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::clear::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _adds_members { 0 }
  
  sub _potential_value { '[]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = [];';
  }
  
  sub _return_value { '' }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_CLEAR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/count.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_COUNT';
  package Moose::Meta::Method::Accessor::Native::Array::count;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::count::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::count::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'scalar @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_COUNT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/delete.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_DELETE';
  package Moose::Meta::Method::Accessor::Native::Array::delete;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::delete::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::delete::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ],
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return $self->_inline_check_var_is_valid_index('$_[0]');
  }
  
  sub _adds_members { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my @potential = @{ (' . $slot_access . ') }; '
               . '@return = splice @potential, $_[0], 1; '
               . '\@potential; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@return = splice @{ (' . $slot_access . ') }, $_[0], 1;';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$return[0]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_DELETE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/elements.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_ELEMENTS';
  package Moose::Meta::Method::Accessor::Native::Array::elements;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::elements::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::elements::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '@{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_ELEMENTS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/first.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_FIRST';
  package Moose::Meta::Method::Accessor::Native::Array::first;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::first::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::first::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::Util ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to first must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '&List::Util::first($_[0], @{ (' . $slot_access . ') })';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_FIRST

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/first_index.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_FIRST_INDEX';
  package Moose::Meta::Method::Accessor::Native::Array::first_index;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::first_index::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::first_index::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::MoreUtils ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to first_index must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '&List::MoreUtils::first_index($_[0], @{ (' . $slot_access . ') })';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_FIRST_INDEX

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/get.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_GET';
  package Moose::Meta::Method::Accessor::Native::Array::get;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::get::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::get::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::MiniTrait;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ],
      },
      'Moose::Meta::Method::Accessor::Native::Array';
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return $self->_inline_check_var_is_valid_index('$_[0]');
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . '->[ $_[0] ]';
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_GET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/grep.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_GREP';
  package Moose::Meta::Method::Accessor::Native::Array::grep;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::grep::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::grep::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to grep must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'grep { $_[0]->() } @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_GREP

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/insert.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_INSERT';
  package Moose::Meta::Method::Accessor::Native::Array::insert;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::insert::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::insert::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_coerce_new_values
              _new_members
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _minimum_arguments { 2 }
  
  sub _maximum_arguments { 2 }
  
  sub _adds_members { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my @potential = @{ (' . $slot_access . ') }; '
               . 'splice @potential, $_[0], 0, $_[1]; '
               . '\@potential; '
           . '})';
  }
  
  # We need to override this because while @_ can be written to, we cannot write
  # directly to $_[1].
  sub _inline_coerce_new_values {
      my $self = shift;
  
      return unless $self->associated_attribute->should_coerce;
  
      return unless $self->_tc_member_type_can_coerce;
  
      return '@_ = ($_[0], $member_coercion->($_[1]));';
  };
  
  sub _new_members { '$_[1]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return 'splice @{ (' . $slot_access . ') }, $_[0], 0, $_[1];';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . '->[ $_[0] ]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_INSERT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_IS_EMPTY';
  package Moose::Meta::Method::Accessor::Native::Array::is_empty;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::is_empty::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::is_empty::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '@{ (' . $slot_access . ') } ? 0 : 1';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_IS_EMPTY

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/join.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_JOIN';
  package Moose::Meta::Method::Accessor::Native::Array::join;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::join::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::join::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Moose::Util::_STRINGLIKE0($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to join must be a string"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'join $_[0], @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_JOIN

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/map.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_MAP';
  package Moose::Meta::Method::Accessor::Native::Array::map;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::map::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::map::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to map must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'map { $_[0]->() } @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_MAP

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/natatime.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_NATATIME';
  package Moose::Meta::Method::Accessor::Native::Array::natatime;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::natatime::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::natatime::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::MoreUtils ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              _inline_return_value
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 2 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!defined($_[0]) || $_[0] !~ /^\d+$/) {',
              $self->_inline_throw_error(
                  '"The n value passed to natatime must be an integer"',
              ) . ';',
          '}',
          'if (@_ == 2 && !Params::Util::_CODELIKE($_[1])) {',
              $self->_inline_throw_error(
                  '"The second argument passed to natatime must be a code '
                . 'reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _inline_return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return (
          'my $iter = List::MoreUtils::natatime($_[0], @{ (' . $slot_access . ') });',
          'if ($_[1]) {',
              'while (my @vals = $iter->()) {',
                  '$_[1]->(@vals);',
              '}',
          '}',
          'else {',
              'return $iter;',
          '}',
      );
  }
  
  # Not called, but needed to satisfy the Reader role
  sub _return_value { }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_NATATIME

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/pop.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_POP';
  package Moose::Meta::Method::Accessor::Native::Array::pop;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::pop::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::pop::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw( _maximum_arguments
              _inline_capture_return_value
              _inline_optimized_set_new_value
              _return_value )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _adds_members { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @{ (' . $slot_access . ') } > 1 '
               . '? @{ (' . $slot_access . ') }[0..$#{ (' . $slot_access . ') } - 1] '
               . ': () ]';
  }
  
  sub _inline_capture_return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'my $old = ' . $slot_access . '->[-1];';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return 'pop @{ (' . $slot_access . ') };';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$old';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_POP

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/push.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_PUSH';
  package Moose::Meta::Method::Accessor::Native::Array::push;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::push::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::push::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _adds_members { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @{ (' . $slot_access . ') }, @_ ]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return 'push @{ (' . $slot_access . ') }, @_;';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'scalar @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_PUSH

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/reduce.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_REDUCE';
  package Moose::Meta::Method::Accessor::Native::Array::reduce;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::reduce::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::reduce::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::Util ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to reduce must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'List::Util::reduce { $_[0]->($a, $b) } @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_REDUCE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/set.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SET';
  package Moose::Meta::Method::Accessor::Native::Array::set;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::set::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::set::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              _inline_coerce_new_values
              _new_members
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _minimum_arguments { 2 }
  
  sub _maximum_arguments { 2 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return $self->_inline_check_var_is_valid_index('$_[0]');
  }
  
  sub _adds_members { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my @potential = @{ (' . $slot_access . ') }; '
               . '$potential[$_[0]] = $_[1]; '
               . '\@potential; '
           . '})';
  }
  
  # We need to override this because while @_ can be written to, we cannot write
  # directly to $_[1].
  sub _inline_coerce_new_values {
      my $self = shift;
  
      return unless $self->associated_attribute->should_coerce;
  
      return unless $self->_tc_member_type_can_coerce;
  
      return '@_ = ($_[0], $member_coercion->($_[1]));';
  };
  
  sub _new_members { '$_[1]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . '->[$_[0]] = $_[1];';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . '->[$_[0]]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHALLOW_CLONE';
  package Moose::Meta::Method::Accessor::Native::Array::shallow_clone;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::shallow_clone::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::shallow_clone::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 0 }
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @{ (' . $slot_access . ') } ]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHALLOW_CLONE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/shift.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHIFT';
  package Moose::Meta::Method::Accessor::Native::Array::shift;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::shift::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::shift::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_capture_return_value
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _adds_members { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @{ (' . $slot_access . ') } > 1 '
               . '? @{ (' . $slot_access . ') }[1..$#{ (' . $slot_access . ') }] '
               . ': () ]';
  }
  
  sub _inline_capture_return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'my $old = ' . $slot_access . '->[0];';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return 'shift @{ (' . $slot_access . ') };';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$old';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHIFT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHUFFLE';
  package Moose::Meta::Method::Accessor::Native::Array::shuffle;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::shuffle::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::shuffle::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'List::Util::shuffle @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SHUFFLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/sort.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SORT';
  package Moose::Meta::Method::Accessor::Native::Array::sort;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::sort::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::sort::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (@_ && !Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to sort must be a code reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$_[0] '
               . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } '
               . ': sort @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SORT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SORT_IN_PLACE';
  package Moose::Meta::Method::Accessor::Native::Array::sort_in_place;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::sort_in_place::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::sort_in_place::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_check_arguments
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (@_ && !Params::Util::_CODELIKE($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to sort_in_place must be a code '
                . 'reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _adds_members { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ $_[0] '
               . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } '
               . ': sort @{ (' . $slot_access . ') } ]';
  }
  
  sub _return_value { '' }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SORT_IN_PLACE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/splice.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SPLICE';
  package Moose::Meta::Method::Accessor::Native::Array::splice;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::splice::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::splice::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _inline_process_arguments
              _inline_check_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _adds_members { 1 }
  
  sub _inline_process_arguments {
      return (
          'my $idx = shift;',
          'my $len = @_ ? shift : undef;',
      );
  }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          $self->_inline_check_var_is_valid_index('$idx'),
          'if (defined($len) && $len !~ /^-?\d+$/) {',
              $self->_inline_throw_error(
                  '"The length argument passed to splice must be an integer"',
              ) . ';',
          '}',
      );
  }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my @potential = @{ (' . $slot_access . ') }; '
               . '@return = defined $len '
                   . '? (splice @potential, $idx, $len, @_) '
                   . ': (splice @potential, $idx); '
                   . '\@potential;'
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return (
          '@return = defined $len',
              '? (splice @{ (' . $slot_access . ') }, $idx, $len, @_)',
              ': (splice @{ (' . $slot_access . ') }, $idx);',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'wantarray ? @return : $return[-1]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_SPLICE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/uniq.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_UNIQ';
  package Moose::Meta::Method::Accessor::Native::Array::uniq;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::uniq::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::uniq::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::MoreUtils ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'List::MoreUtils::uniq @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_UNIQ

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Array/unshift.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_UNSHIFT';
  package Moose::Meta::Method::Accessor::Native::Array::unshift;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Array::unshift::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Array::unshift::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Array::Writer' => {
      -excludes => [
          qw(
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _adds_members { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '[ @_, @{ (' . $slot_access . ') } ]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return 'unshift @{ (' . $slot_access . ') }, @_;';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'scalar @{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_ARRAY_UNSHIFT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Bool/not.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_NOT';
  package Moose::Meta::Method::Accessor::Native::Bool::not;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Bool::not::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Bool::not::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '!' . $slot_access;
  }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_NOT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Bool/set.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_SET';
  package Moose::Meta::Method::Accessor::Native::Bool::set;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Bool::set::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Bool::set::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value { 1 }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = 1;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_SET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_TOGGLE';
  package Moose::Meta::Method::Accessor::Native::Bool::toggle;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Bool::toggle::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Bool::toggle::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' ? 0 : 1';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = ' . $slot_access . ' ? 0 : 1;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_TOGGLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Bool/unset.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_UNSET';
  package Moose::Meta::Method::Accessor::Native::Bool::unset;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Bool::unset::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Bool::unset::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value { 0 }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = 0;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_BOOL_UNSET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Code/execute.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_CODE_EXECUTE';
  package Moose::Meta::Method::Accessor::Native::Code::execute;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Code::execute::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Code::execute::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader';
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . '->(@_)';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_CODE_EXECUTE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_CODE_EXECUTE_METHOD';
  package Moose::Meta::Method::Accessor::Native::Code::execute_method;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Code::execute_method::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Code::execute_method::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader';
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . '->($self, @_)';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_CODE_EXECUTE_METHOD

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Collection.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COLLECTION';
  package Moose::Meta::Method::Accessor::Native::Collection;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Collection::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Collection::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  requires qw( _adds_members );
  
  sub _inline_coerce_new_values {
      my $self = shift;
  
      return unless $self->associated_attribute->should_coerce;
  
      return unless $self->_tc_member_type_can_coerce;
  
      return (
          '(' . $self->_new_members . ') = map { $member_coercion->($_) }',
                                               $self->_new_members . ';',
      );
  }
  
  sub _tc_member_type_can_coerce {
      my $self = shift;
  
      my $member_tc = $self->_tc_member_type;
  
      return $member_tc && $member_tc->has_coercion;
  }
  
  sub _tc_member_type {
      my $self = shift;
  
      my $tc = $self->associated_attribute->type_constraint;
      while ($tc) {
          return $tc->type_parameter
              if $tc->can('type_parameter');
          $tc = $tc->parent;
      }
  
      return;
  }
  
  sub _writer_value_needs_copy {
      my $self = shift;
  
      return $self->_constraint_must_be_checked
          && !$self->_check_new_members_only;
  }
  
  sub _inline_tc_code {
      my $self = shift;
      my ($value, $tc, $coercion, $message, $is_lazy) = @_;
  
      return unless $self->_constraint_must_be_checked;
  
      if ($self->_check_new_members_only) {
          return unless $self->_adds_members;
  
          return $self->_inline_check_member_constraint($self->_new_members);
      }
      else {
          return (
              $self->_inline_check_coercion($value, $tc, $coercion, $is_lazy),
              $self->_inline_check_constraint($value, $tc, $message, $is_lazy),
          );
      }
  }
  
  sub _check_new_members_only {
      my $self = shift;
  
      my $attr = $self->associated_attribute;
  
      my $tc = $attr->type_constraint;
  
      # If we have a coercion, we could come up with an entirely new value after
      # coercing, so we need to check everything,
      return 0 if $attr->should_coerce && $tc->has_coercion;
  
      # If the parent is our root type (ArrayRef, HashRef, etc), that means we
      # can just check the new members of the collection, because we know that
      # we will always be generating an appropriate collection type.
      #
      # However, if this type has its own constraint (it's Parameteriz_able_,
      # not Paramet_erized_), we don't know what is being checked by the
      # constraint, so we need to check the whole value, not just the members.
      return 1
          if $self->_is_root_type( $tc->parent )
              && $tc->isa('Moose::Meta::TypeConstraint::Parameterized');
  
      return 0;
  }
  
  sub _inline_check_member_constraint {
      my $self = shift;
      my ($new_value) = @_;
  
      my $attr_name = $self->associated_attribute->name;
  
      my $check
          = $self->_tc_member_type->can_be_inlined
          ? '! (' . $self->_tc_member_type->_inline_check('$new_val') . ')'
          : ' !$member_tc->($new_val) ';
  
      return (
          'for my $new_val (' . $new_value . ') {',
              "if ($check) {",
                  $self->_inline_throw_error(
                      '"A new member value for ' . $attr_name
                    . ' does not pass its type constraint because: "' . ' . '
                    . 'do { local $_ = $new_val; $member_message->($new_val) }',
                      'data => $new_val',
                  ) . ';',
              '}',
          '}',
      );
  }
  
  sub _inline_get_old_value_for_trigger {
      my $self = shift;
      my ($instance, $old) = @_;
  
      my $attr = $self->associated_attribute;
      return unless $attr->has_trigger;
  
      return (
          'my ' . $old . ' = ' . $self->_has_value($instance),
              '? ' . $self->_copy_old_value($self->_get_value($instance)),
              ': ();',
      );
  }
  
  around _eval_environment => sub {
      my $orig = shift;
      my $self = shift;
  
      my $env = $self->$orig(@_);
  
      my $member_tc = $self->_tc_member_type;
  
      return $env unless $member_tc;
  
      $env->{'$member_tc'} = \( $member_tc->_compiled_type_constraint );
      $env->{'$member_coercion'} = \(
          $member_tc->coercion->_compiled_type_coercion
      ) if $member_tc->has_coercion;
      $env->{'$member_message'} = \(
          $member_tc->has_message
              ? $member_tc->message
              : $member_tc->_default_message
      );
  
      my $tc_env = $member_tc->inline_environment();
  
      $env = { %{$env}, %{$tc_env} };
  
      return $env;
  };
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COLLECTION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_WRITER';
  package Moose::Meta::Method::Accessor::Native::Counter::Writer;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Counter::Writer::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Counter::Writer::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer';
  
  sub _constraint_must_be_checked {
      my $self = shift;
  
      my $attr = $self->associated_attribute;
  
      return $attr->has_type_constraint
          && ($attr->type_constraint->name =~ /^(?:Num|Int)$/
           || ($attr->should_coerce && $attr->type_constraint->has_coercion)
             );
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_WRITER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Counter/dec.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_DEC';
  package Moose::Meta::Method::Accessor::Native::Counter::dec;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Counter::dec::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Counter::dec::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _minimum_arguments { 0 }
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' - (defined $_[0] ? $_[0] : 1)';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' -= defined $_[0] ? $_[0] : 1;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_DEC

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Counter/inc.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_INC';
  package Moose::Meta::Method::Accessor::Native::Counter::inc;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Counter::inc::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Counter::inc::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _minimum_arguments { 0 }
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' + (defined $_[0] ? $_[0] : 1)';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' += defined $_[0] ? $_[0] : 1;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_INC

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Counter/reset.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_RESET';
  package Moose::Meta::Method::Accessor::Native::Counter::reset;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Counter::reset::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Counter::reset::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      my $attr = $self->associated_attribute;
  
      return '(do { '
               . join(' ', $attr->_inline_generate_default(
                     '$self', '$default_for_reset'
                 )) . ' '
               . '$default_for_reset; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = ' . $self->_potential_value . ';';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_RESET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Counter/set.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_SET';
  package Moose::Meta::Method::Accessor::Native::Counter::set;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Counter::set::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Counter::set::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  sub _maximum_arguments { 1 }
  
  sub _potential_value { '$_[0]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_COUNTER_SET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH';
  package Moose::Meta::Method::Accessor::Native::Hash;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  sub _inline_check_var_is_valid_key {
      my $self = shift;
      my ($var) = @_;
  
      return (
          'if (!defined(' . $var . ')) {',
              $self->_inline_throw_error(
                  '"The key passed to ' . $self->delegate_to_method
                . ' must be a defined value"',
              ) . ';',
          '}',
      );
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_WRITER';
  package Moose::Meta::Method::Accessor::Native::Hash::Writer;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::Writer::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::Writer::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::MOP::MiniTrait;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
          -excludes => ['_inline_coerce_new_values'],
      },
      'Moose::Meta::Method::Accessor::Native::Hash',
      'Moose::Meta::Method::Accessor::Native::Collection';
  
  sub _new_values { '@values' }
  
  sub _copy_old_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '{ %{ (' . $slot_access . ') } }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_WRITER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_ACCESSOR';
  package Moose::Meta::Method::Accessor::Native::Hash::accessor;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::accessor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::accessor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Hash::set' => {
      -excludes => [
          qw(
              _generate_method
              _minimum_arguments
              _maximum_arguments
              )
      ]
      },
      'Moose::Meta::Method::Accessor::Native::Hash::get' => {
      -excludes => [
          qw(
              _generate_method
              _minimum_arguments
              _maximum_arguments
              _inline_check_argument_count
              _inline_check_arguments
              _inline_process_arguments
              _return_value
              )
      ]
      };
  
  sub _generate_method {
      my $self = shift;
  
      my $inv         = '$self';
      my $slot_access = $self->_get_value($inv);
  
      return (
          'sub {',
              'my ' . $inv . ' = shift;',
              $self->_inline_curried_arguments,
              $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
              # get
              'if (@_ == 1) {',
                  $self->_inline_check_var_is_valid_key('$_[0]'),
                  $slot_access . '->{$_[0]}',
              '}',
              # set
              'else {',
                  $self->_inline_writer_core($inv, $slot_access),
              '}',
          '}',
      );
  }
  
  sub _minimum_arguments { 1 }
  sub _maximum_arguments { 2 }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_ACCESSOR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/clear.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_CLEAR';
  package Moose::Meta::Method::Accessor::Native::Hash::clear;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::clear::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::clear::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Hash::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _adds_members { 0 }
  
  sub _potential_value { '{}' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = {};';
  }
  
  sub _return_value { '' }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_CLEAR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/count.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_COUNT';
  package Moose::Meta::Method::Accessor::Native::Hash::count;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::count::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::count::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'scalar keys %{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_COUNT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/defined.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_DEFINED';
  package Moose::Meta::Method::Accessor::Native::Hash::defined;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::defined::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::defined::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ],
      },
      'Moose::Meta::Method::Accessor::Native::Hash';
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return $self->_inline_check_var_is_valid_key('$_[0]');
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'defined ' . $slot_access . '->{ $_[0] }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_DEFINED

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/delete.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_DELETE';
  package Moose::Meta::Method::Accessor::Native::Hash::delete;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::delete::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::delete::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Hash::Writer' => {
      -excludes => [
          qw(
              _inline_optimized_set_new_value
              _return_value
              )
      ],
  };
  
  sub _adds_members { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my %potential = %{ (' . $slot_access . ') }; '
               . '@return = delete @potential{@_}; '
               . '\%potential; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@return = delete @{ (' . $slot_access . ') }{@_};';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'wantarray ? @return : $return[-1]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_DELETE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/elements.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_ELEMENTS';
  package Moose::Meta::Method::Accessor::Native::Hash::elements;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::elements::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::elements::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'map { $_, ' . $slot_access . '->{$_} } '
               . 'keys %{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_ELEMENTS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/exists.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_EXISTS';
  package Moose::Meta::Method::Accessor::Native::Hash::exists;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::exists::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::exists::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ],
      },
      'Moose::Meta::Method::Accessor::Native::Hash';
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return $self->_inline_check_var_is_valid_key('$_[0]');
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = shift;
  
      return 'exists ' . $slot_access . '->{ $_[0] }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_EXISTS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/get.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_GET';
  package Moose::Meta::Method::Accessor::Native::Hash::get;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::get::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::get::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _inline_check_arguments
              )
      ],
      },
      'Moose::Meta::Method::Accessor::Native::Hash';
  
  sub _minimum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'for (@_) {',
              $self->_inline_check_var_is_valid_key('$_'),
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '@_ > 1 '
               . '? @{ (' . $slot_access . ') }{@_} '
               . ': ' . $slot_access . '->{$_[0]}';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_GET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_IS_EMPTY';
  package Moose::Meta::Method::Accessor::Native::Hash::is_empty;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::is_empty::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::is_empty::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'scalar keys %{ (' . $slot_access . ') } ? 0 : 1';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_IS_EMPTY

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/keys.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_KEYS';
  package Moose::Meta::Method::Accessor::Native::Hash::keys;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::keys::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::keys::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'keys %{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_KEYS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/kv.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_KV';
  package Moose::Meta::Method::Accessor::Native::Hash::kv;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::kv::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::kv::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'map { [ $_, ' . $slot_access . '->{$_} ] } '
               . 'keys %{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_KV

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/set.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_SET';
  package Moose::Meta::Method::Accessor::Native::Hash::set;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::set::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::set::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::MoreUtils ();
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Hash::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_process_arguments
              _inline_check_arguments
              _inline_coerce_new_values
              _inline_optimized_set_new_value
              _return_value
              )
      ],
  };
  
  sub _minimum_arguments { 2 }
  
  sub _maximum_arguments { undef }
  
  around _inline_check_argument_count => sub {
      my $orig = shift;
      my $self = shift;
  
      return (
          $self->$orig(@_),
          'if (@_ % 2) {',
              $self->_inline_throw_error(
                  sprintf(
                      '"You must pass an even number of arguments to %s"',
                      $self->delegate_to_method,
                  ),
              ) . ';',
          '}',
      );
  };
  
  sub _inline_process_arguments {
      my $self = shift;
  
      return (
          'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;',
          'my @values_idx = grep { $_ % 2 } 0..$#_;',
      );
  }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'for (@keys_idx) {',
              'if (!defined($_[$_])) {',
                  $self->_inline_throw_error(
                      sprintf(
                          '"Hash keys passed to %s must be defined"',
                          $self->delegate_to_method,
                      ),
                  ) . ';',
              '}',
          '}',
      );
  }
  
  sub _adds_members { 1 }
  
  # We need to override this because while @_ can be written to, we cannot write
  # directly to $_[1].
  sub _inline_coerce_new_values {
      my $self = shift;
  
      return unless $self->associated_attribute->should_coerce;
  
      return unless $self->_tc_member_type_can_coerce;
  
      # Is there a simpler way to do this?
      return (
          'my $iter = List::MoreUtils::natatime(2, @_);',
          '@_ = ();',
          'while (my ($key, $val) = $iter->()) {',
              'push @_, $key, $member_coercion->($val);',
          '}',
      );
  };
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '{ %{ (' . $slot_access . ') }, @_ }';
  }
  
  sub _new_members { '@_[ @values_idx ]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'wantarray '
               . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } '
               . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_SET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_SHALLOW_CLONE';
  package Moose::Meta::Method::Accessor::Native::Hash::shallow_clone;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::shallow_clone::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::shallow_clone::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 0 }
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '{ %{ (' . $slot_access . ') } }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_SHALLOW_CLONE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Hash/values.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_VALUES';
  package Moose::Meta::Method::Accessor::Native::Hash::values;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Hash::values::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Hash::values::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Scalar::Util qw( looks_like_number );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'values %{ (' . $slot_access . ') }';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_HASH_VALUES

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/abs.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_ABS';
  package Moose::Meta::Method::Accessor::Native::Number::abs;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::abs::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::abs::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'abs(' . $slot_access . ')';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = abs(' . $slot_access . ');';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_ABS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/add.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_ADD';
  package Moose::Meta::Method::Accessor::Native::Number::add;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::add::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::add::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' + $_[0]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' += $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_ADD

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/div.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_DIV';
  package Moose::Meta::Method::Accessor::Native::Number::div;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::div::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::div::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' / $_[0]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' /= $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_DIV

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/mod.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_MOD';
  package Moose::Meta::Method::Accessor::Native::Number::mod;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::mod::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::mod::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' % $_[0]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' %= $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_MOD

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/mul.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_MUL';
  package Moose::Meta::Method::Accessor::Native::Number::mul;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::mul::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::mul::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' * $_[0]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' *= $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_MUL

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/set.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_SET';
  package Moose::Meta::Method::Accessor::Native::Number::set;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::set::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::set::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  sub _maximum_arguments { 1 }
  
  sub _potential_value { '$_[0]' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_SET

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Number/sub.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_SUB';
  package Moose::Meta::Method::Accessor::Native::Number::sub;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Number::sub::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Number::sub::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' - $_[0]';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' -= $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_NUMBER_SUB

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Reader.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_READER';
  package Moose::Meta::Method::Accessor::Native::Reader;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Reader::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Reader::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native';
  
  requires '_return_value';
  
  sub _generate_method {
      my $self = shift;
  
      my $inv         = '$self';
      my $slot_access = $self->_get_value($inv);
  
      return (
          'sub {',
              'my ' . $inv . ' = shift;',
              $self->_inline_curried_arguments,
              $self->_inline_reader_core($inv, $slot_access, @_),
          '}',
      );
  }
  
  sub _inline_reader_core {
      my $self = shift;
      my ($inv, $slot_access, @extra) = @_;
  
      return (
          $self->_inline_check_argument_count,
          $self->_inline_process_arguments($inv, $slot_access),
          $self->_inline_check_arguments,
          $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
          $self->_inline_return_value($slot_access),
      );
  }
  
  sub _inline_process_arguments { return }
  
  sub _inline_check_arguments { return }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_READER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/append.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_APPEND';
  package Moose::Meta::Method::Accessor::Native::String::append;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::append::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::append::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '( ' . $slot_access . ' . $_[0] )';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' .= $_[0];';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_APPEND

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/chomp.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CHOMP';
  package Moose::Meta::Method::Accessor::Native::String::chomp;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::chomp::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::chomp::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my $val = ' . $slot_access . '; '
               . '@return = chomp $val; '
               . '$val '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@return = chomp ' . $slot_access . ';';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$return[0]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CHOMP

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/chop.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CHOP';
  package Moose::Meta::Method::Accessor::Native::String::chop;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::chop::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::chop::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my $val = ' . $slot_access . '; '
               . '@return = chop $val; '
               . '$val; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@return = chop ' . $slot_access . ';';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$return[0]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CHOP

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/clear.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CLEAR';
  package Moose::Meta::Method::Accessor::Native::String::clear;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::clear::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::clear::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
  };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value { '""' }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = "";';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_CLEAR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/inc.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_INC';
  package Moose::Meta::Method::Accessor::Native::String::inc;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::inc::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::inc::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _maximum_arguments { 0 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my $val = ' . $slot_access . '; '
               . '$val++; '
               . '$val; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . '++;';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_INC

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/length.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_LENGTH';
  package Moose::Meta::Method::Accessor::Native::String::length;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::length::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::length::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' =>
      { -excludes => ['_maximum_arguments'] };
  
  sub _maximum_arguments { 0 }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return 'length ' . $slot_access;
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_LENGTH

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/match.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_MATCH';
  package Moose::Meta::Method::Accessor::Native::String::match;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::match::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::match::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Util ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              )
      ]
  };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {',
              $self->_inline_throw_error(
                  '"The argument passed to match must be a string or regexp '
                . 'reference"',
              ) . ';',
          '}',
      );
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access . ' =~ $_[0]';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_MATCH

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/prepend.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_PREPEND';
  package Moose::Meta::Method::Accessor::Native::String::prepend;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::prepend::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::prepend::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 1 }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '$_[0] . ' . $slot_access;
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return $slot_access . ' = $_[0] . ' . $slot_access . ';';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_PREPEND

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/replace.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_REPLACE';
  package Moose::Meta::Method::Accessor::Native::String::replace;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::replace::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::replace::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Util ();
  use Params::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _minimum_arguments
              _maximum_arguments
              _inline_check_arguments
              _inline_optimized_set_new_value
              )
      ]
      };
  
  sub _minimum_arguments { 1 }
  
  sub _maximum_arguments { 2 }
  
  sub _inline_check_arguments {
      my $self = shift;
  
      return (
          'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {',
              $self->_inline_throw_error(
                  '"The first argument passed to replace must be a string or '
                . 'regexp reference"'
              ) . ';',
          '}',
          'if (!Moose::Util::_STRINGLIKE0($_[1]) && !Params::Util::_CODELIKE($_[1])) {',
              $self->_inline_throw_error(
                  '"The second argument passed to replace must be a string or '
                . 'code reference"'
              ) . ';',
          '}',
      );
  }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my $val = ' . $slot_access . '; '
               . 'ref $_[1] '
                   . '? $val =~ s/$_[0]/$_[1]->()/e '
                   . ': $val =~ s/$_[0]/$_[1]/; '
               . '$val; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return (
          'ref $_[1]',
              '? ' . $slot_access . ' =~ s/$_[0]/$_[1]->()/e',
              ': ' . $slot_access . ' =~ s/$_[0]/$_[1]/;',
       );
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_REPLACE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/String/substr.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_SUBSTR';
  package Moose::Meta::Method::Accessor::Native::String::substr;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::String::substr::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::String::substr::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Util ();
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native::Reader' => {
      -excludes => [
          qw( _generate_method
              _minimum_arguments
              _maximum_arguments
              _inline_process_arguments
              _inline_check_arguments
              _return_value
              )
      ]
      },
      'Moose::Meta::Method::Accessor::Native::Writer' => {
      -excludes => [
          qw(
              _generate_method
              _minimum_arguments
              _maximum_arguments
              _inline_process_arguments
              _inline_check_arguments
              _inline_optimized_set_new_value
              _return_value
              )
      ]
      };
  
  sub _generate_method {
      my $self = shift;
  
      my $inv         = '$self';
      my $slot_access = $self->_get_value($inv);
  
      return (
          'sub {',
              'my ' . $inv . ' = shift;',
              $self->_inline_curried_arguments,
              'if (@_ == 1 || @_ == 2) {',
                  $self->_inline_reader_core($inv, $slot_access),
              '}',
              'elsif (@_ == 3) {',
                  $self->_inline_writer_core($inv, $slot_access),
              '}',
              'else {',
                  $self->_inline_check_argument_count,
              '}',
          '}',
      );
  }
  
  sub _minimum_arguments { 1 }
  sub _maximum_arguments { 3 }
  
  sub _inline_process_arguments {
      my $self = shift;
      my ($inv, $slot_access) = @_;
  
      return (
          'my $offset = shift;',
          'my $length = @_ ? shift : length ' . $slot_access . ';',
          'my $replacement = shift;',
      );
  }
  
  sub _inline_check_arguments {
      my $self = shift;
      my ($for_writer) = @_;
  
      my @code = (
          'if ($offset !~ /^-?\d+$/) {',
              $self->_inline_throw_error(
                  '"The first argument passed to substr must be an integer"'
              ) . ';',
          '}',
          'if ($length !~ /^-?\d+$/) {',
              $self->_inline_throw_error(
                  '"The second argument passed to substr must be an integer"'
              ) . ';',
          '}',
      );
  
      if ($for_writer) {
          push @code, (
              'if (!Moose::Util::_STRINGLIKE0($replacement)) {',
                  $self->_inline_throw_error(
                      '"The third argument passed to substr must be a string"'
                  ) . ';',
              '}',
          );
      }
  
      return @code;
  }
  
  sub _potential_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return '(do { '
               . 'my $potential = ' . $slot_access . '; '
               . '@return = substr $potential, $offset, $length, $replacement; '
               . '$potential; '
           . '})';
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
      my ($inv, $new, $slot_access) = @_;
  
      return '@return = substr ' . $slot_access . ', '
                             . '$offset, $length, $replacement;';
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access, $for_writer) = @_;
  
      return '$return[0]' if $for_writer;
  
      return 'substr ' . $slot_access . ', $offset, $length';
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_STRING_SUBSTR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Accessor/Native/Writer.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_WRITER';
  package Moose::Meta::Method::Accessor::Native::Writer;
  BEGIN {
    $Moose::Meta::Method::Accessor::Native::Writer::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Accessor::Native::Writer::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use List::MoreUtils qw( any );
  
  use Moose::Role;
  
  with 'Moose::Meta::Method::Accessor::Native';
  
  requires '_potential_value';
  
  sub _generate_method {
      my $self = shift;
  
      my $inv         = '$self';
      my $slot_access = $self->_get_value($inv);
  
      return (
          'sub {',
              'my ' . $inv . ' = shift;',
              $self->_inline_curried_arguments,
              $self->_inline_writer_core($inv, $slot_access),
          '}',
      );
  }
  
  sub _inline_writer_core {
      my $self = shift;
      my ($inv, $slot_access) = @_;
  
      my $potential = $self->_potential_value($slot_access);
      my $old       = '@old';
  
      my @code;
      push @code, (
          $self->_inline_check_argument_count,
          $self->_inline_process_arguments($inv, $slot_access),
          $self->_inline_check_arguments('for writer'),
          $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'),
      );
  
      if ($self->_return_value($slot_access)) {
          # some writers will save the return value in this variable when they
          # generate the potential value.
          push @code, 'my @return;'
      }
  
      push @code, (
          $self->_inline_coerce_new_values,
          $self->_inline_copy_native_value(\$potential),
          $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_message'),
          $self->_inline_get_old_value_for_trigger($inv, $old),
          $self->_inline_capture_return_value($slot_access),
          $self->_inline_set_new_value($inv, $potential, $slot_access),
          $self->_inline_trigger($inv, $slot_access, $old),
          $self->_inline_return_value($slot_access, 'for writer'),
      );
  
      return @code;
  }
  
  sub _inline_process_arguments { return }
  
  sub _inline_check_arguments { return }
  
  sub _inline_coerce_new_values { return }
  
  sub _writer_value_needs_copy {
      my $self = shift;
  
      return $self->_constraint_must_be_checked;
  }
  
  sub _constraint_must_be_checked {
      my $self = shift;
  
      my $attr = $self->associated_attribute;
  
      return $attr->has_type_constraint
          && (!$self->_is_root_type( $attr->type_constraint )
           || ( $attr->should_coerce && $attr->type_constraint->has_coercion)
             );
  }
  
  sub _is_root_type {
      my $self = shift;
      my ($type) = @_;
  
      my $name = $type->name;
  
      return any { $name eq $_ } @{ $self->root_types };
  }
  
  sub _inline_copy_native_value {
      my $self = shift;
      my ($potential_ref) = @_;
  
      return unless $self->_writer_value_needs_copy;
  
      my $code = 'my $potential = ' . ${$potential_ref} . ';';
  
      ${$potential_ref} = '$potential';
  
      return $code;
  }
  
  around _inline_tc_code => sub {
      my $orig = shift;
      my $self = shift;
      my ($value, $tc, $coercion, $message, $for_lazy) = @_;
  
      return unless $for_lazy || $self->_constraint_must_be_checked;
  
      return $self->$orig(@_);
  };
  
  around _inline_check_constraint => sub {
      my $orig = shift;
      my $self = shift;
      my ($value, $tc, $message, $for_lazy) = @_;
  
      return unless $for_lazy || $self->_constraint_must_be_checked;
  
      return $self->$orig(@_);
  };
  
  sub _inline_capture_return_value { return }
  
  sub _inline_set_new_value {
      my $self = shift;
  
      return $self->_inline_store_value(@_)
          if $self->_writer_value_needs_copy
          || !$self->_slot_access_can_be_inlined
          || !$self->_get_is_lvalue;
  
      return $self->_inline_optimized_set_new_value(@_);
  }
  
  sub _get_is_lvalue {
      my $self = shift;
  
      return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue;
  }
  
  sub _inline_optimized_set_new_value {
      my $self = shift;
  
      return $self->_inline_store_value(@_);
  }
  
  sub _return_value {
      my $self = shift;
      my ($slot_access) = @_;
  
      return $slot_access;
  }
  
  no Moose::Role;
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_ACCESSOR_NATIVE_WRITER

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Augmented.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_AUGMENTED';
  package Moose::Meta::Method::Augmented;
  BEGIN {
    $Moose::Meta::Method::Augmented::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Augmented::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base 'Moose::Meta::Method';
  
  sub new {
      my ( $class, %args ) = @_;
  
      # the package can be overridden by roles
      # it is really more like body's compilation stash
      # this is where we need to override the definition of super() so that the
      # body of the code can call the right overridden version
      my $name = $args{name};
      my $meta = $args{class};
  
      my $super = $meta->find_next_method_by_name($name);
  
      (defined $super)
          || $meta->throw_error("You cannot augment '$name' because it has no super method", data => $name);
  
      my $_super_package = $super->package_name;
      # BUT!,... if this is an overridden method ....
      if ($super->isa('Moose::Meta::Method::Overridden')) {
          # we need to be sure that we actually
          # find the next method, which is not
          # an 'override' method, the reason is
          # that an 'override' method will not
          # be the one calling inner()
          my $real_super = $meta->_find_next_method_by_name_which_is_not_overridden($name);
          $_super_package = $real_super->package_name;
      }
  
      my $super_body = $super->body;
  
      my $method = $args{method};
  
      my $body = sub {
          local $Moose::INNER_ARGS{$_super_package} = [ @_ ];
          local $Moose::INNER_BODY{$_super_package} = $method;
          $super_body->(@_);
      };
  
      # FIXME store additional attrs
      $class->wrap(
          $body,
          package_name => $meta->name,
          name         => $name
      );
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for augmented methods
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Augmented - A Moose Method metaclass for augmented methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements method augmentation logic for the L<Moose>
  C<augment> keyword.
  
  The augmentation subroutine reference will be invoked explicitly using
  the C<inner> keyword from the parent class's method definition.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Method::Augmented> is a subclass of L<Moose::Meta::Method>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Method::Augmented->new(%options) >>
  
  This constructs a new object. It accepts the following options:
  
  =over 8
  
  =item * class
  
  The metaclass object for the class in which the augmentation is being
  declared. This option is required.
  
  =item * name
  
  The name of the method which we are augmenting. This method must exist
  in one of the class's superclasses. This option is required.
  
  =item * method
  
  The subroutine reference which implements the augmentation. This
  option is required.
  
  =back
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_AUGMENTED

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Constructor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_CONSTRUCTOR';
  
  package Moose::Meta::Method::Constructor;
  BEGIN {
    $Moose::Meta::Method::Constructor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Constructor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp ();
  use List::MoreUtils 'any';
  use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
  use Try::Tiny;
  
  use base 'Moose::Meta::Method',
           'Class::MOP::Method::Constructor';
  
  sub new {
      my $class   = shift;
      my %options = @_;
  
      my $meta = $options{metaclass};
  
      (ref $options{options} eq 'HASH')
          || $class->throw_error("You must pass a hash of options", data => $options{options});
  
      ($options{package_name} && $options{name})
          || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
  
      my $self = bless {
          'body'          => undef,
          'package_name'  => $options{package_name},
          'name'          => $options{name},
          'options'       => $options{options},
          'associated_metaclass' => $meta,
          'definition_context' => $options{definition_context},
          '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
      } => $class;
  
      # we don't want this creating
      # a cycle in the code, if not
      # needed
      weaken($self->{'associated_metaclass'});
  
      $self->_initialize_body;
  
      return $self;
  }
  
  ## method
  
  sub _initialize_body {
      my $self = shift;
      $self->{'body'} = $self->_generate_constructor_method_inline;
  }
  
  1;
  
  # ABSTRACT: Method Meta Object for constructors
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Constructor - Method Meta Object for constructors
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Method::Constructor> that
  provides additional Moose-specific functionality
  
  To understand this class, you should read the the
  L<Class::MOP::Method::Constructor> documentation as well.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Method::Constructor> is a subclass of
  L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_CONSTRUCTOR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Delegation.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_DELEGATION';
  
  package Moose::Meta::Method::Delegation;
  BEGIN {
    $Moose::Meta::Method::Delegation::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Delegation::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Scalar::Util 'blessed', 'weaken';
  
  use base 'Moose::Meta::Method',
           'Class::MOP::Method::Generated';
  
  
  sub new {
      my $class   = shift;
      my %options = @_;
  
      ( exists $options{attribute} )
          || confess "You must supply an attribute to construct with";
  
      ( blessed( $options{attribute} )
              && $options{attribute}->isa('Moose::Meta::Attribute') )
          || confess
          "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";
  
      ( $options{package_name} && $options{name} )
          || confess
          "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";
  
      ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
              || ( 'CODE' eq ref $options{delegate_to_method} ) )
          || confess
          'You must supply a delegate_to_method which is a method name or a CODE reference';
  
      exists $options{curried_arguments}
          || ( $options{curried_arguments} = [] );
  
      ( $options{curried_arguments} &&
          ( 'ARRAY' eq ref $options{curried_arguments} ) )
          || confess 'You must supply a curried_arguments which is an ARRAY reference';
  
      my $self = $class->_new( \%options );
  
      weaken( $self->{'attribute'} );
  
      $self->_initialize_body;
  
      return $self;
  }
  
  sub _new {
      my $class = shift;
      my $options = @_ == 1 ? $_[0] : {@_};
  
      return bless $options, $class;
  }
  
  sub curried_arguments { (shift)->{'curried_arguments'} }
  
  sub associated_attribute { (shift)->{'attribute'} }
  
  sub delegate_to_method { (shift)->{'delegate_to_method'} }
  
  sub _initialize_body {
      my $self = shift;
  
      my $method_to_call = $self->delegate_to_method;
      return $self->{body} = $method_to_call
          if ref $method_to_call;
  
      my $accessor = $self->_get_delegate_accessor;
  
      my $handle_name = $self->name;
  
      # NOTE: we used to do a goto here, but the goto didn't handle
      # failure correctly (it just returned nothing), so I took that
      # out. However, the more I thought about it, the less I liked it
      # doing the goto, and I preferred the act of delegation being
      # actually represented in the stack trace.  - SL
      # not inlining this, since it won't really speed things up at
      # all... the only thing that would end up different would be
      # interpolating in $method_to_call, and a bunch of things in the
      # error handling that mostly never gets called - doy
      $self->{body} = sub {
          my $instance = shift;
          my $proxy    = $instance->$accessor();
  
          my $error
              = !defined $proxy                 ? ' is not defined'
              : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
              : undef;
  
          if ($error) {
              $self->throw_error(
                  "Cannot delegate $handle_name to $method_to_call because "
                      . "the value of "
                      . $self->associated_attribute->name
                      . $error,
                  method_name => $method_to_call,
                  object      => $instance
              );
          }
          unshift @_, @{ $self->curried_arguments };
          $proxy->$method_to_call(@_);
      };
  }
  
  sub _get_delegate_accessor {
      my $self = shift;
      my $attr = $self->associated_attribute;
  
      # NOTE:
      # always use a named method when
      # possible, if you use the method
      # ref and there are modifiers on
      # the accessors then it will not
      # pick up the modifiers too. Only
      # the named method will assure that
      # we also have any modifiers run.
      # - SL
      my $accessor = $attr->has_read_method
          ? $attr->get_read_method
          : $attr->get_read_method_ref;
  
      $accessor = $accessor->body if Scalar::Util::blessed $accessor;
  
      return $accessor;
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for delegation methods
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a subclass of L<Moose::Meta::Method> for delegation
  methods.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Method::Delegation->new(%options) >>
  
  This creates the delegation methods based on the provided C<%options>.
  
  =over 4
  
  =item I<attribute>
  
  This must be an instance of C<Moose::Meta::Attribute> which this
  accessor is being generated for. This options is B<required>.
  
  =item I<delegate_to_method>
  
  The method in the associated attribute's value to which we
  delegate. This can be either a method name or a code reference.
  
  =item I<curried_arguments>
  
  An array reference of arguments that will be prepended to the argument list for
  any call to the delegating method.
  
  =back
  
  =item B<< $metamethod->associated_attribute >>
  
  Returns the attribute associated with this method.
  
  =item B<< $metamethod->curried_arguments >>
  
  Return any curried arguments that will be passed to the delegated method.
  
  =item B<< $metamethod->delegate_to_method >>
  
  Returns the method to which this method delegates, as passed to the
  constructor.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_DELEGATION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Destructor.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_DESTRUCTOR';
  
  package Moose::Meta::Method::Destructor;
  BEGIN {
    $Moose::Meta::Method::Destructor::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Destructor::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Devel::GlobalDestruction ();
  use Scalar::Util 'blessed', 'weaken';
  use Try::Tiny;
  
  use base 'Moose::Meta::Method',
           'Class::MOP::Method::Inlined';
  
  sub new {
      my $class   = shift;
      my %options = @_;
  
      (ref $options{options} eq 'HASH')
          || $class->throw_error("You must pass a hash of options", data => $options{options});
  
      ($options{package_name} && $options{name})
          || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT");
  
      my $self = bless {
          # from our superclass
          'body'                 => undef,
          'package_name'         => $options{package_name},
          'name'                 => $options{name},
          # ...
          'options'              => $options{options},
          'definition_context'   => $options{definition_context},
          'associated_metaclass' => $options{metaclass},
      } => $class;
  
      # we don't want this creating
      # a cycle in the code, if not
      # needed
      weaken($self->{'associated_metaclass'});
  
      $self->_initialize_body;
  
      return $self;
  }
  
  ## accessors
  
  sub options              { (shift)->{'options'}              }
  
  ## method
  
  sub is_needed {
      my $self      = shift;
      my $metaclass = shift;
  
      ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') )
          || $self->throw_error(
          "The is_needed method expected a metaclass object as its arugment");
  
      return $metaclass->find_method_by_name("DEMOLISHALL");
  }
  
  sub initialize_body {
      Carp::cluck('The initialize_body method has been made private.'
          . " The public version is deprecated and will be removed in a future release.\n");
      shift->_initialize_body;
  }
  
  sub _initialize_body {
      my $self = shift;
      # TODO:
      # the %options should also include a both
      # a call 'initializer' and call 'SUPER::'
      # options, which should cover approx 90%
      # of the possible use cases (even if it
      # requires some adaption on the part of
      # the author, after all, nothing is free)
  
      my $class = $self->associated_metaclass->name;
      my @source = (
          'sub {',
              'my $self = shift;',
              'return ' . $self->_generate_fallback_destructor('$self'),
                  'if Scalar::Util::blessed($self) ne \'' . $class . '\';',
              'local $?;',
              $self->_generate_DEMOLISHALL('$self'),
              'return;',
          '}',
      );
      warn join("\n", @source) if $self->options->{debug};
  
      my $code = try {
          $self->_compile_code(source => \@source);
      }
      catch {
          my $source = join("\n", @source);
          $self->throw_error(
              "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$_",
              error => $_,
              data  => $source,
          );
      };
  
      $self->{'body'} = $code;
  }
  
  sub _generate_fallback_destructor {
      my $self = shift;
      my ($inv) = @_;
  
      return $inv . '->Moose::Object::DESTROY(@_)';
  }
  
  sub _generate_DEMOLISHALL {
      my $self = shift;
      my ($inv) = @_;
  
      my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
      return unless @methods;
  
      return (
          'my $igd = Devel::GlobalDestruction::in_global_destruction;',
          'Try::Tiny::try {',
              (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods),
          '}',
          'Try::Tiny::catch {',
              'die $_;',
          '};',
      );
  }
  
  
  1;
  
  # ABSTRACT: Method Meta Object for destructors
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Destructor - Method Meta Object for destructors
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Class::Generated> that
  provides Moose-specific functionality for inlining destructors.
  
  To understand this class, you should read the the
  L<Class::MOP::Class::Generated> documentation as well.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Method::Destructor> is a subclass of
  L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Generated>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Method::Destructor->new(%options) >>
  
  This constructs a new object. It accepts the following options:
  
  =over 8
  
  =item * package_name
  
  The package for the class in which the destructor is being
  inlined. This option is required.
  
  =item * name
  
  The name of the destructor method. This option is required.
  
  =item * metaclass
  
  The metaclass for the class this destructor belongs to. This is
  optional, as it can be set later by calling C<<
  $metamethod->attach_to_class >>.
  
  =back
  
  =item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >>
  
  Given a L<Moose::Meta::Class> object, this method returns a boolean
  indicating whether the class needs a destructor. If the class or any
  of its parents defines a C<DEMOLISH> method, it needs a destructor.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_DESTRUCTOR

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Meta.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_META';
  
  package Moose::Meta::Method::Meta;
  BEGIN {
    $Moose::Meta::Method::Meta::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Meta::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base 'Moose::Meta::Method',
           'Class::MOP::Method::Meta';
  
  sub _is_caller_mop_internal {
      my $self = shift;
      my ($caller) = @_;
      return 1 if $caller =~ /^Moose(?:::|$)/;
      return $self->SUPER::_is_caller_mop_internal($caller);
  }
  
  # XXX: ugh multiple inheritance
  sub wrap {
      my $class = shift;
      return $class->Class::MOP::Method::Meta::wrap(@_);
  }
  
  sub _make_compatible_with {
      my $self = shift;
      return $self->Class::MOP::Method::Meta::_make_compatible_with(@_);
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for C<meta> methods
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Meta - A Moose Method metaclass for C<meta> methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Method::Meta> that
  provides additional Moose-specific functionality, all of which is
  private.
  
  To understand this class, you should read the the
  L<Class::MOP::Method::Meta> documentation.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_META

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Method/Overridden.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_OVERRIDDEN';
  package Moose::Meta::Method::Overridden;
  BEGIN {
    $Moose::Meta::Method::Overridden::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Method::Overridden::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base 'Moose::Meta::Method';
  
  sub new {
      my ( $class, %args ) = @_;
  
      # the package can be overridden by roles
      # it is really more like body's compilation stash
      # this is where we need to override the definition of super() so that the
      # body of the code can call the right overridden version
      my $super_package = $args{package} || $args{class}->name;
  
      my $name = $args{name};
  
      my $super = $args{class}->find_next_method_by_name($name);
  
      (defined $super)
          || $class->throw_error("You cannot override '$name' because it has no super method", data => $name);
  
      my $super_body = $super->body;
  
      my $method = $args{method};
  
      my $body = sub {
          local $Moose::SUPER_PACKAGE = $super_package;
          local @Moose::SUPER_ARGS = @_;
          local $Moose::SUPER_BODY = $super_body;
          return $method->(@_);
      };
  
      # FIXME do we need this make sure this works for next::method?
      # subname "${super_package}::${name}", $method;
  
      # FIXME store additional attrs
      $class->wrap(
          $body,
          package_name => $args{class}->name,
          name         => $name
      );
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for overridden methods
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Method::Overridden - A Moose Method metaclass for overridden methods
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements method overriding logic for the L<Moose>
  C<override> keyword.
  
  The overriding subroutine's parent will be invoked explicitly using
  the C<super> keyword from the parent class's method definition.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Method::Overridden->new(%options) >>
  
  This constructs a new object. It accepts the following options:
  
  =over 8
  
  =item * class
  
  The metaclass object for the class in which the override is being
  declared. This option is required.
  
  =item * name
  
  The name of the method which we are overriding. This method must exist
  in one of the class's superclasses. This option is required.
  
  =item * method
  
  The subroutine reference which implements the overriding. This option
  is required.
  
  =back
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_METHOD_OVERRIDDEN

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Mixin/AttributeCore.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_MIXIN_ATTRIBUTECORE';
  package Moose::Meta::Mixin::AttributeCore;
  BEGIN {
    $Moose::Meta::Mixin::AttributeCore::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Mixin::AttributeCore::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base 'Class::MOP::Mixin::AttributeCore';
  
  __PACKAGE__->meta->add_attribute(
      'isa' => (
          reader => '_isa_metadata',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'does' => (
          reader => '_does_metadata',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'is' => (
          reader => '_is_metadata',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'required' => (
          reader => 'is_required',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'lazy' => (
          reader => 'is_lazy', Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'lazy_build' => (
          reader => 'is_lazy_build',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'coerce' => (
          reader => 'should_coerce',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'weak_ref' => (
          reader => 'is_weak_ref',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'auto_deref' => (
          reader => 'should_auto_deref',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'type_constraint' => (
          reader    => 'type_constraint',
          predicate => 'has_type_constraint',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'trigger' => (
          reader    => 'trigger',
          predicate => 'has_trigger',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'handles' => (
          reader    => 'handles',
          writer    => '_set_handles',
          predicate => 'has_handles',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'documentation' => (
          reader    => 'documentation',
          predicate => 'has_documentation',
          Class::MOP::_definition_context(),
      )
  );
  
  1;
  
  # ABSTRACT: Core attributes shared by attribute metaclasses
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Mixin::AttributeCore - Core attributes shared by attribute metaclasses
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements the core attributes (aka properties) shared by all Moose
  attributes. See the L<Moose::Meta::Attribute> documentation for API details.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_MIXIN_ATTRIBUTECORE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Object/Trait.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_OBJECT_TRAIT';
  
  package Moose::Meta::Object::Trait;
  BEGIN {
    $Moose::Meta::Object::Trait::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Object::Trait::VERSION = '2.0401';
  }
  
  use Scalar::Util qw(blessed);
  
  sub _get_compatible_metaclass {
      my $orig = shift;
      my $self = shift;
      return $self->$orig(@_)
          || $self->_get_compatible_metaclass_by_role_reconciliation(@_);
  }
  
  sub _get_compatible_metaclass_by_role_reconciliation {
      my $self = shift;
      my ($other_name) = @_;
      my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
  
      return unless Moose::Util::_classes_differ_by_roles_only(
          $meta_name, $other_name
      );
  
      return Moose::Util::_reconcile_roles_for_metaclass(
          $meta_name, $other_name
      );
  }
  
  1;
  
  # ABSTRACT: Some overrides for L<Class::MOP::Object> functionality
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Object::Trait - Some overrides for L<Class::MOP::Object> functionality
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This module is entirely private, you shouldn't ever need to interact with
  it directly.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_OBJECT_TRAIT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE';
  package Moose::Meta::Role;
  BEGIN {
    $Moose::Meta::Role::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Class::Load qw(load_class);
  use Scalar::Util 'blessed';
  use Carp         'confess';
  use Devel::GlobalDestruction 'in_global_destruction';
  
  use Moose::Meta::Class;
  use Moose::Meta::Role::Attribute;
  use Moose::Meta::Role::Method;
  use Moose::Meta::Role::Method::Required;
  use Moose::Meta::Role::Method::Conflicting;
  use Moose::Meta::Method::Meta;
  use Moose::Util qw( ensure_all_roles );
  use Class::MOP::MiniTrait;
  
  use base 'Class::MOP::Module',
           'Class::MOP::Mixin::HasAttributes',
           'Class::MOP::Mixin::HasMethods';
  
  Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  
  ## ------------------------------------------------------------------
  ## NOTE:
  ## I normally don't do this, but I am doing
  ## a whole bunch of meta-programmin in this
  ## module, so it just makes sense. For a clearer
  ## picture of what is going on in the next
  ## several lines of code, look at the really
  ## big comment at the end of this file (right
  ## before the POD).
  ## - SL
  ## ------------------------------------------------------------------
  
  my $META = __PACKAGE__->meta;
  
  ## ------------------------------------------------------------------
  ## attributes ...
  
  # NOTE:
  # since roles are lazy, we hold all the attributes
  # of the individual role in 'stasis' until which
  # time when it is applied to a class. This means
  # keeping a lot of things in hash maps, so we are
  # using a little of that meta-programmin' magic
  # here an saving lots of extra typin. And since
  # many of these attributes above require similar
  # functionality to support them, so we again use
  # the wonders of meta-programmin' to deliver a
  # very compact solution to this normally verbose
  # problem.
  # - SL
  
  foreach my $action (
      {
          name        => 'excluded_roles_map',
          attr_reader => 'get_excluded_roles_map' ,
          methods     => {
              add       => 'add_excluded_roles',
              get_keys  => 'get_excluded_roles_list',
              existence => 'excludes_role',
          }
      },
      {
          name        => 'required_methods',
          attr_reader => 'get_required_methods_map',
          methods     => {
              remove     => 'remove_required_methods',
              get_values => 'get_required_method_list',
              existence  => 'requires_method',
          }
      },
  ) {
  
      my $attr_reader = $action->{attr_reader};
      my $methods     = $action->{methods};
  
      # create the attribute
      $META->add_attribute($action->{name} => (
          reader  => $attr_reader,
          default => sub { {} },
          Class::MOP::_definition_context(),
      ));
  
      # create some helper methods
      $META->add_method($methods->{add} => sub {
          my ($self, @values) = @_;
          $self->$attr_reader->{$_} = undef foreach @values;
      }) if exists $methods->{add};
  
      $META->add_method($methods->{get_keys} => sub {
          my ($self) = @_;
          keys %{$self->$attr_reader};
      }) if exists $methods->{get_keys};
  
      $META->add_method($methods->{get_values} => sub {
          my ($self) = @_;
          values %{$self->$attr_reader};
      }) if exists $methods->{get_values};
  
      $META->add_method($methods->{get} => sub {
          my ($self, $name) = @_;
          $self->$attr_reader->{$name}
      }) if exists $methods->{get};
  
      $META->add_method($methods->{existence} => sub {
          my ($self, $name) = @_;
          exists $self->$attr_reader->{$name} ? 1 : 0;
      }) if exists $methods->{existence};
  
      $META->add_method($methods->{remove} => sub {
          my ($self, @values) = @_;
          delete $self->$attr_reader->{$_} foreach @values;
      }) if exists $methods->{remove};
  }
  
  $META->add_attribute(
      'method_metaclass',
      reader  => 'method_metaclass',
      default => 'Moose::Meta::Role::Method',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'required_method_metaclass',
      reader  => 'required_method_metaclass',
      default => 'Moose::Meta::Role::Method::Required',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'conflicting_method_metaclass',
      reader  => 'conflicting_method_metaclass',
      default => 'Moose::Meta::Role::Method::Conflicting',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'application_to_class_class',
      reader  => 'application_to_class_class',
      default => 'Moose::Meta::Role::Application::ToClass',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'application_to_role_class',
      reader  => 'application_to_role_class',
      default => 'Moose::Meta::Role::Application::ToRole',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'application_to_instance_class',
      reader  => 'application_to_instance_class',
      default => 'Moose::Meta::Role::Application::ToInstance',
      Class::MOP::_definition_context(),
  );
  
  $META->add_attribute(
      'applied_attribute_metaclass',
      reader  => 'applied_attribute_metaclass',
      default => 'Moose::Meta::Attribute',
      Class::MOP::_definition_context(),
  );
  
  # More or less copied from Moose::Meta::Class
  sub initialize {
      my $class = shift;
      my @args = @_;
      unshift @args, 'package' if @args % 2;
      my %opts = @args;
      my $package = delete $opts{package};
      return Class::MOP::get_metaclass_by_name($package)
          || $class->SUPER::initialize($package,
                  'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
                  %opts,
              );
  }
  
  sub reinitialize {
      my $self = shift;
      my $pkg  = shift;
  
      my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
  
      my %existing_classes;
      if ($meta) {
          %existing_classes = map { $_ => $meta->$_() } qw(
              attribute_metaclass
              method_metaclass
              wrapped_method_metaclass
              required_method_metaclass
              conflicting_method_metaclass
              application_to_class_class
              application_to_role_class
              application_to_instance_class
              applied_attribute_metaclass
          );
      }
  
      my %options = @_;
      $options{weaken} = Class::MOP::metaclass_is_weak($meta->name)
          if !exists $options{weaken}
          && blessed($meta)
          && $meta->isa('Moose::Meta::Role');
  
      # don't need to remove generated metaobjects here yet, since we don't
      # yet generate anything in roles. this may change in the future though...
      # keep an eye on that
      my $new_meta = $self->SUPER::reinitialize(
          $pkg,
          %existing_classes,
          %options,
      );
      $new_meta->_restore_metaobjects_from($meta)
          if $meta && $meta->isa('Moose::Meta::Role');
      return $new_meta;
  }
  
  sub _restore_metaobjects_from {
      my $self = shift;
      my ($old_meta) = @_;
  
      $self->_restore_metamethods_from($old_meta);
      $self->_restore_metaattributes_from($old_meta);
  
      for my $role ( @{ $old_meta->get_roles } ) {
          $self->add_role($role);
      }
  }
  
  sub add_attribute {
      my $self = shift;
  
      if (blessed $_[0] && ! $_[0]->isa('Moose::Meta::Role::Attribute') ) {
          my $class = ref $_[0];
          Moose->throw_error( "Cannot add a $class as an attribute to a role" );
      }
      elsif (!blessed($_[0]) && defined($_[0]) && $_[0] =~ /^\+(.*)/) {
          Moose->throw_error( "has '+attr' is not supported in roles" );
      }
  
      return $self->SUPER::add_attribute(@_);
  }
  
  sub _attach_attribute {
      my ( $self, $attribute ) = @_;
  
      $attribute->attach_to_role($self);
  }
  
  sub add_required_methods {
      my $self = shift;
  
      for (@_) {
          my $method = $_;
          if (!blessed($method)) {
              $method = $self->required_method_metaclass->new(
                  name => $method,
              );
          }
          $self->get_required_methods_map->{$method->name} = $method;
      }
  }
  
  sub add_conflicting_method {
      my $self = shift;
  
      my $method;
      if (@_ == 1 && blessed($_[0])) {
          $method = shift;
      }
      else {
          $method = $self->conflicting_method_metaclass->new(@_);
      }
  
      $self->add_required_methods($method);
  }
  
  ## ------------------------------------------------------------------
  ## method modifiers
  
  # NOTE:
  # the before/around/after method modifiers are
  # stored by name, but there can be many methods
  # then associated with that name. So again we have
  # lots of similar functionality, so we can do some
  # meta-programmin' and save some time.
  # - SL
  
  foreach my $modifier_type (qw[ before around after ]) {
  
      my $attr_reader = "get_${modifier_type}_method_modifiers_map";
  
      # create the attribute ...
      $META->add_attribute("${modifier_type}_method_modifiers" => (
          reader  => $attr_reader,
          default => sub { {} },
          Class::MOP::_definition_context(),
      ));
  
      # and some helper methods ...
      $META->add_method("get_${modifier_type}_method_modifiers" => sub {
          my ($self, $method_name) = @_;
          #return () unless exists $self->$attr_reader->{$method_name};
          my $mm = $self->$attr_reader->{$method_name};
          $mm ? @$mm : ();
      });
  
      $META->add_method("has_${modifier_type}_method_modifiers" => sub {
          my ($self, $method_name) = @_;
          # NOTE:
          # for now we assume that if it exists,..
          # it has at least one modifier in it
          (exists $self->$attr_reader->{$method_name}) ? 1 : 0;
      });
  
      $META->add_method("add_${modifier_type}_method_modifier" => sub {
          my ($self, $method_name, $method) = @_;
  
          $self->$attr_reader->{$method_name} = []
              unless exists $self->$attr_reader->{$method_name};
  
          my $modifiers = $self->$attr_reader->{$method_name};
  
          # NOTE:
          # check to see that we aren't adding the
          # same code twice. We err in favor of the
          # first on here, this may not be as expected
          foreach my $modifier (@{$modifiers}) {
              return if $modifier == $method;
          }
  
          push @{$modifiers} => $method;
      });
  
  }
  
  ## ------------------------------------------------------------------
  ## override method mofidiers
  
  $META->add_attribute('override_method_modifiers' => (
      reader  => 'get_override_method_modifiers_map',
      default => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  # NOTE:
  # these are a little different because there
  # can only be one per name, whereas the other
  # method modifiers can have multiples.
  # - SL
  
  sub add_override_method_modifier {
      my ($self, $method_name, $method) = @_;
      (!$self->has_method($method_name))
          || Moose->throw_error("Cannot add an override of method '$method_name' " .
                     "because there is a local version of '$method_name'");
      $self->get_override_method_modifiers_map->{$method_name} = $method;
  }
  
  sub has_override_method_modifier {
      my ($self, $method_name) = @_;
      # NOTE:
      # for now we assume that if it exists,..
      # it has at least one modifier in it
      (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0;
  }
  
  sub get_override_method_modifier {
      my ($self, $method_name) = @_;
      $self->get_override_method_modifiers_map->{$method_name};
  }
  
  ## general list accessor ...
  
  sub get_method_modifier_list {
      my ($self, $modifier_type) = @_;
      my $accessor = "get_${modifier_type}_method_modifiers_map";
      keys %{$self->$accessor};
  }
  
  sub _meta_method_class { 'Moose::Meta::Method::Meta' }
  
  ## ------------------------------------------------------------------
  ## subroles
  
  $META->add_attribute('roles' => (
      reader  => 'get_roles',
      default => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  sub add_role {
      my ($self, $role) = @_;
      (blessed($role) && $role->isa('Moose::Meta::Role'))
          || Moose->throw_error("Roles must be instances of Moose::Meta::Role");
      push @{$self->get_roles} => $role;
      $self->reset_package_cache_flag;
  }
  
  sub calculate_all_roles {
      my $self = shift;
      my %seen;
      grep {
          !$seen{$_->name}++
      } ($self, map {
                    $_->calculate_all_roles
                } @{ $self->get_roles });
  }
  
  sub does_role {
      my ($self, $role) = @_;
      (defined $role)
          || Moose->throw_error("You must supply a role name to look for");
      my $role_name = blessed $role ? $role->name : $role;
      # if we are it,.. then return true
      return 1 if $role_name eq $self->name;
      # otherwise.. check our children
      foreach my $role (@{$self->get_roles}) {
          return 1 if $role->does_role($role_name);
      }
      return 0;
  }
  
  sub find_method_by_name { (shift)->get_method(@_) }
  
  ## ------------------------------------------------------------------
  ## role construction
  ## ------------------------------------------------------------------
  
  sub apply {
      my ($self, $other, %args) = @_;
  
      (blessed($other))
          || Moose->throw_error("You must pass in an blessed instance");
  
      my $application_class;
      if ($other->isa('Moose::Meta::Role')) {
          $application_class = $self->application_to_role_class;
      }
      elsif ($other->isa('Moose::Meta::Class')) {
          $application_class = $self->application_to_class_class;
      }
      else {
          $application_class = $self->application_to_instance_class;
      }
  
      load_class($application_class);
  
      if ( exists $args{'-excludes'} ) {
          # I wish we had coercion here :)
          $args{'-excludes'} = (
              ref $args{'-excludes'} eq 'ARRAY'
              ? $args{'-excludes'}
              : [ $args{'-excludes'} ]
          );
      }
  
      return $application_class->new(%args)->apply($self, $other, \%args);
  }
  
  sub composition_class_roles { }
  
  sub combine {
      my ($class, @role_specs) = @_;
  
      require Moose::Meta::Role::Composite;
  
      my (@roles, %role_params);
      while (@role_specs) {
          my ($role, $params) = @{ splice @role_specs, 0, 1 };
          my $requested_role
              = blessed $role
              ? $role
              : Class::MOP::class_of($role);
  
          my $actual_role = $requested_role->_role_for_combination($params);
          push @roles => $actual_role;
  
          next unless defined $params;
          $role_params{$actual_role->name} = $params;
      }
  
      my $c = Moose::Meta::Role::Composite->new(roles => \@roles);
      return $c->apply_params(\%role_params);
  }
  
  sub _role_for_combination {
      my ($self, $params) = @_;
      return $self;
  }
  
  sub create {
      my $class = shift;
      my @args = @_;
  
      unshift @args, 'package' if @args % 2 == 1;
      my %options = @args;
  
      (ref $options{attributes} eq 'HASH')
          || confess "You must pass a HASH ref of attributes"
              if exists $options{attributes};
  
      (ref $options{methods} eq 'HASH')
          || confess "You must pass a HASH ref of methods"
              if exists $options{methods};
  
      (ref $options{roles} eq 'ARRAY')
          || confess "You must pass an ARRAY ref of roles"
              if exists $options{roles};
  
      my $package      = delete $options{package};
      my $roles        = delete $options{roles};
      my $attributes   = delete $options{attributes};
      my $methods      = delete $options{methods};
      my $meta_name    = exists $options{meta_name}
                           ? delete $options{meta_name}
                           : 'meta';
  
      my $meta = $class->SUPER::create($package => %options);
  
      $meta->_add_meta_method($meta_name)
          if defined $meta_name;
  
      if (defined $attributes) {
          foreach my $attribute_name (keys %{$attributes}) {
              my $attr = $attributes->{$attribute_name};
              $meta->add_attribute(
                  $attribute_name => blessed $attr ? $attr : %{$attr} );
          }
      }
  
      if (defined $methods) {
          foreach my $method_name (keys %{$methods}) {
              $meta->add_method($method_name, $methods->{$method_name});
          }
      }
  
      if ($roles) {
          Moose::Util::apply_all_roles($meta, @$roles);
      }
  
      return $meta;
  }
  
  sub consumers {
      my $self = shift;
      my @consumers;
      for my $meta (Class::MOP::get_all_metaclass_instances) {
          next if $meta->name eq $self->name;
          next unless $meta->isa('Moose::Meta::Class')
                   || $meta->isa('Moose::Meta::Role');
          push @consumers, $meta->name
              if $meta->does_role($self->name);
      }
      return @consumers;
  }
  
  # XXX: something more intelligent here?
  sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' }
  
  sub create_anon_role { shift->create_anon(@_) }
  sub is_anon_role     { shift->is_anon(@_)     }
  
  sub _anon_cache_key {
      my $class = shift;
      my %options = @_;
  
      # XXX fix this duplication (see MMC::_anon_cache_key
      my $roles = Data::OptList::mkopt(($options{roles} || []), {
          moniker  => 'role',
          val_test => sub { ref($_[0]) eq 'HASH' },
      });
  
      my @role_keys;
      for my $role_spec (@$roles) {
          my ($role, $params) = @$role_spec;
          $params = { %$params };
  
          my $key = blessed($role) ? $role->name : $role;
  
          if ($params && %$params) {
              my $alias    = delete $params->{'-alias'}
                          || delete $params->{'alias'}
                          || {};
              my $excludes = delete $params->{'-excludes'}
                          || delete $params->{'excludes'}
                          || [];
              $excludes = [$excludes] unless ref($excludes) eq 'ARRAY';
  
              if (%$params) {
                  warn "Roles with parameters cannot be cached. Consider "
                     . "applying the parameters before calling "
                     . "create_anon_class, or using 'weaken => 0' instead";
                  return;
              }
  
              my $alias_key = join('%',
                  map { $_ => $alias->{$_} } sort keys %$alias
              );
              my $excludes_key = join('%',
                  sort @$excludes
              );
              $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>';
          }
  
          push @role_keys, $key;
      }
  
      # Makes something like Role|Role::1
      return join('|', sort @role_keys);
  }
  
  #####################################################################
  ## NOTE:
  ## This is Moose::Meta::Role as defined by Moose (plus the use of
  ## MooseX::AttributeHelpers module). It is here as a reference to
  ## make it easier to see what is happening above with all the meta
  ## programming. - SL
  #####################################################################
  #
  # has 'roles' => (
  #     metaclass => 'Array',
  #     reader    => 'get_roles',
  #     isa       => 'ArrayRef[Moose::Meta::Role]',
  #     default   => sub { [] },
  #     provides  => {
  #         'push' => 'add_role',
  #     }
  # );
  #
  # has 'excluded_roles_map' => (
  #     metaclass => 'Hash',
  #     reader    => 'get_excluded_roles_map',
  #     isa       => 'HashRef[Str]',
  #     provides  => {
  #         # Not exactly set, cause it sets multiple
  #         'set'    => 'add_excluded_roles',
  #         'keys'   => 'get_excluded_roles_list',
  #         'exists' => 'excludes_role',
  #     }
  # );
  #
  # has 'required_methods' => (
  #     metaclass => 'Hash',
  #     reader    => 'get_required_methods_map',
  #     isa       => 'HashRef[Moose::Meta::Role::Method::Required]',
  #     provides  => {
  #         # not exactly set, or delete since it works for multiple
  #         'set'    => 'add_required_methods',
  #         'delete' => 'remove_required_methods',
  #         'keys'   => 'get_required_method_list',
  #         'exists' => 'requires_method',
  #     }
  # );
  #
  # # the before, around and after modifiers are
  # # HASH keyed by method-name, with ARRAY of
  # # CODE refs to apply in that order
  #
  # has 'before_method_modifiers' => (
  #     metaclass => 'Hash',
  #     reader    => 'get_before_method_modifiers_map',
  #     isa       => 'HashRef[ArrayRef[CodeRef]]',
  #     provides  => {
  #         'keys'   => 'get_before_method_modifiers',
  #         'exists' => 'has_before_method_modifiers',
  #         # This actually makes sure there is an
  #         # ARRAY at the given key, and pushed onto
  #         # it. It also checks for duplicates as well
  #         # 'add'  => 'add_before_method_modifier'
  #     }
  # );
  #
  # has 'after_method_modifiers' => (
  #     metaclass => 'Hash',
  #     reader    =>'get_after_method_modifiers_map',
  #     isa       => 'HashRef[ArrayRef[CodeRef]]',
  #     provides  => {
  #         'keys'   => 'get_after_method_modifiers',
  #         'exists' => 'has_after_method_modifiers',
  #         # This actually makes sure there is an
  #         # ARRAY at the given key, and pushed onto
  #         # it. It also checks for duplicates as well
  #         # 'add'  => 'add_after_method_modifier'
  #     }
  # );
  #
  # has 'around_method_modifiers' => (
  #     metaclass => 'Hash',
  #     reader    =>'get_around_method_modifiers_map',
  #     isa       => 'HashRef[ArrayRef[CodeRef]]',
  #     provides  => {
  #         'keys'   => 'get_around_method_modifiers',
  #         'exists' => 'has_around_method_modifiers',
  #         # This actually makes sure there is an
  #         # ARRAY at the given key, and pushed onto
  #         # it. It also checks for duplicates as well
  #         # 'add'  => 'add_around_method_modifier'
  #     }
  # );
  #
  # # override is similar to the other modifiers
  # # except that it is not an ARRAY of code refs
  # # but instead just a single name->code mapping
  #
  # has 'override_method_modifiers' => (
  #     metaclass => 'Hash',
  #     reader    =>'get_override_method_modifiers_map',
  #     isa       => 'HashRef[CodeRef]',
  #     provides  => {
  #         'keys'   => 'get_override_method_modifier',
  #         'exists' => 'has_override_method_modifier',
  #         'add'    => 'add_override_method_modifier', # checks for local method ..
  #     }
  # );
  #
  #####################################################################
  
  
  1;
  
  # ABSTRACT: The Moose Role metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role - The Moose Role metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a subclass of L<Class::MOP::Module> that provides
  additional Moose-specific functionality.
  
  Its API looks a lot like L<Moose::Meta::Class>, but internally it
  implements many things differently. This may change in the future.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Role> is a subclass of L<Class::MOP::Module>.
  
  =head1 METHODS
  
  =head2 Construction
  
  =over 4
  
  =item B<< Moose::Meta::Role->initialize($role_name) >>
  
  This method creates a new role object with the provided name.
  
  =item B<< Moose::Meta::Role->combine( [ $role => { ... } ], [ $role ], ... ) >>
  
  This method accepts a list of array references. Each array reference
  should contain a role name or L<Moose::Meta::Role> object as its first element. The second element is
  an optional hash reference. The hash reference can contain C<-excludes>
  and C<-alias> keys to control how methods are composed from the role.
  
  The return value is a new L<Moose::Meta::Role::Composite> that
  represents the combined roles.
  
  =item B<< $metarole->composition_class_roles >>
  
  When combining multiple roles using C<combine>, this method is used to obtain a
  list of role names to be applied to the L<Moose::Meta::Role::Composite>
  instance returned by C<combine>. The default implementation returns an empty
  list. Extensions that need to hook into role combination may wrap this method
  to return additional role names.
  
  =item B<< Moose::Meta::Role->create($name, %options) >>
  
  This method is identical to the L<Moose::Meta::Class> C<create>
  method.
  
  =item B<< Moose::Meta::Role->create_anon_role >>
  
  This method is identical to the L<Moose::Meta::Class>
  C<create_anon_class> method.
  
  =item B<< $metarole->is_anon_role >>
  
  Returns true if the role is an anonymous role.
  
  =item B<< $metarole->consumers >>
  
  Returns a list of names of classes and roles which consume this role.
  
  =back
  
  =head2 Role application
  
  =over 4
  
  =item B<< $metarole->apply( $thing, @options ) >>
  
  This method applies a role to the given C<$thing>. That can be another
  L<Moose::Meta::Role>, object, a L<Moose::Meta::Class> object, or a
  (non-meta) object instance.
  
  The options are passed directly to the constructor for the appropriate
  L<Moose::Meta::Role::Application> subclass.
  
  Note that this will apply the role even if the C<$thing> in question already
  C<does> this role.  L<Moose::Util/does_role> is a convenient wrapper for
  finding out if role application is necessary.
  
  =back
  
  =head2 Roles and other roles
  
  =over 4
  
  =item B<< $metarole->get_roles >>
  
  This returns an array reference of roles which this role does. This
  list may include duplicates.
  
  =item B<< $metarole->calculate_all_roles >>
  
  This returns a I<unique> list of all roles that this role does, and
  all the roles that its roles do.
  
  =item B<< $metarole->does_role($role) >>
  
  Given a role I<name> or L<Moose::Meta::Role> object, returns true if this role
  does the given role.
  
  =item B<< $metarole->add_role($role) >>
  
  Given a L<Moose::Meta::Role> object, this adds the role to the list of
  roles that the role does.
  
  =item B<< $metarole->get_excluded_roles_list >>
  
  Returns a list of role names which this role excludes.
  
  =item B<< $metarole->excludes_role($role_name) >>
  
  Given a role I<name>, returns true if this role excludes the named
  role.
  
  =item B<< $metarole->add_excluded_roles(@role_names) >>
  
  Given one or more role names, adds those roles to the list of excluded
  roles.
  
  =back
  
  =head2 Methods
  
  The methods for dealing with a role's methods are all identical in API
  and behavior to the same methods in L<Class::MOP::Class>.
  
  =over 4
  
  =item B<< $metarole->method_metaclass >>
  
  Returns the method metaclass name for the role. This defaults to
  L<Moose::Meta::Role::Method>.
  
  =item B<< $metarole->get_method($name) >>
  
  =item B<< $metarole->has_method($name) >>
  
  =item B<< $metarole->add_method( $name, $body ) >>
  
  =item B<< $metarole->get_method_list >>
  
  =item B<< $metarole->find_method_by_name($name) >>
  
  These methods are all identical to the methods of the same name in
  L<Class::MOP::Package>
  
  =back
  
  =head2 Attributes
  
  As with methods, the methods for dealing with a role's attribute are
  all identical in API and behavior to the same methods in
  L<Class::MOP::Class>.
  
  However, attributes stored in this class are I<not> stored as
  objects. Rather, the attribute definition is stored as a hash
  reference. When a role is composed into a class, this hash reference
  is passed directly to the metaclass's C<add_attribute> method.
  
  This is quite likely to change in the future.
  
  =over 4
  
  =item B<< $metarole->get_attribute($attribute_name) >>
  
  =item B<< $metarole->has_attribute($attribute_name) >>
  
  =item B<< $metarole->get_attribute_list >>
  
  =item B<< $metarole->add_attribute($name, %options) >>
  
  =item B<< $metarole->remove_attribute($attribute_name) >>
  
  =back
  
  =head2 Required methods
  
  =over 4
  
  =item B<< $metarole->get_required_method_list >>
  
  Returns the list of methods required by the role.
  
  =item B<< $metarole->requires_method($name) >>
  
  Returns true if the role requires the named method.
  
  =item B<< $metarole->add_required_methods(@names) >>
  
  Adds the named methods to the role's list of required methods.
  
  =item B<< $metarole->remove_required_methods(@names) >>
  
  Removes the named methods from the role's list of required methods.
  
  =item B<< $metarole->add_conflicting_method(%params) >>
  
  Instantiate the parameters as a L<Moose::Meta::Role::Method::Conflicting>
  object, then add it to the required method list.
  
  =back
  
  =head2 Method modifiers
  
  These methods act like their counterparts in L<Class::MOP::Class> and
  L<Moose::Meta::Class>.
  
  However, method modifiers are simply stored internally, and are not
  applied until the role itself is applied to a class.
  
  =over 4
  
  =item B<< $metarole->add_after_method_modifier($method_name, $method) >>
  
  =item B<< $metarole->add_around_method_modifier($method_name, $method) >>
  
  =item B<< $metarole->add_before_method_modifier($method_name, $method) >>
  
  =item B<< $metarole->add_override_method_modifier($method_name, $method) >>
  
  These methods all add an appropriate modifier to the internal list of
  modifiers.
  
  =item B<< $metarole->has_after_method_modifiers >>
  
  =item B<< $metarole->has_around_method_modifiers >>
  
  =item B<< $metarole->has_before_method_modifiers >>
  
  =item B<< $metarole->has_override_method_modifier >>
  
  Return true if the role has any modifiers of the given type.
  
  =item B<< $metarole->get_after_method_modifiers($method_name) >>
  
  =item B<< $metarole->get_around_method_modifiers($method_name) >>
  
  =item B<< $metarole->get_before_method_modifiers($method_name) >>
  
  Given a method name, returns a list of the appropriate modifiers for
  that method.
  
  =item B<< $metarole->get_override_method_modifier($method_name) >>
  
  Given a method name, returns the override method modifier for that
  method, if it has one.
  
  =back
  
  =head2 Introspection
  
  =over 4
  
  =item B<< Moose::Meta::Role->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Application.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION';
  package Moose::Meta::Role::Application;
  BEGIN {
    $Moose::Meta::Role::Application::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Application::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  __PACKAGE__->meta->add_attribute('method_exclusions' => (
      init_arg => '-excludes',
      reader   => 'get_method_exclusions',
      default  => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('method_aliases' => (
      init_arg => '-alias',
      reader   => 'get_method_aliases',
      default  => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  sub new {
      my ($class, %params) = @_;
      $class->_new(\%params);
  }
  
  sub is_method_excluded {
      my ($self, $method_name) = @_;
      foreach (@{$self->get_method_exclusions}) {
          return 1 if $_ eq $method_name;
      }
      return 0;
  }
  
  sub is_method_aliased {
      my ($self, $method_name) = @_;
      exists $self->get_method_aliases->{$method_name} ? 1 : 0
  }
  
  sub is_aliased_method {
      my ($self, $method_name) = @_;
      my %aliased_names = reverse %{$self->get_method_aliases};
      exists $aliased_names{$method_name} ? 1 : 0;
  }
  
  sub apply {
      my $self = shift;
  
      $self->check_role_exclusions(@_);
      $self->check_required_methods(@_);
      $self->check_required_attributes(@_);
  
      $self->apply_attributes(@_);
      $self->apply_methods(@_);
  
      $self->apply_override_method_modifiers(@_);
  
      $self->apply_before_method_modifiers(@_);
      $self->apply_around_method_modifiers(@_);
      $self->apply_after_method_modifiers(@_);
  }
  
  sub check_role_exclusions           { Carp::croak "Abstract Method" }
  sub check_required_methods          { Carp::croak "Abstract Method" }
  sub check_required_attributes       { Carp::croak "Abstract Method" }
  
  sub apply_attributes                { Carp::croak "Abstract Method" }
  sub apply_methods                   { Carp::croak "Abstract Method" }
  sub apply_override_method_modifiers { Carp::croak "Abstract Method" }
  sub apply_method_modifiers          { Carp::croak "Abstract Method" }
  
  sub apply_before_method_modifiers   { (shift)->apply_method_modifiers('before' => @_) }
  sub apply_around_method_modifiers   { (shift)->apply_method_modifiers('around' => @_) }
  sub apply_after_method_modifiers    { (shift)->apply_method_modifiers('after'  => @_) }
  
  1;
  
  # ABSTRACT: A base class for role application
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Application - A base class for role application
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is the abstract base class for role applications.
  
  The API for this class and its subclasses still needs some
  consideration, and is intentionally not yet documented.
  
  =head2 METHODS
  
  =over 4
  
  =item B<new>
  
  =item B<meta>
  
  =item B<get_method_exclusions>
  
  =item B<is_method_excluded>
  
  =item B<get_method_aliases>
  
  =item B<is_aliased_method>
  
  =item B<is_method_aliased>
  
  =item B<apply>
  
  =item B<check_role_exclusions>
  
  =item B<check_required_methods>
  
  =item B<check_required_attributes>
  
  =item B<apply_attributes>
  
  =item B<apply_methods>
  
  =item B<apply_method_modifiers>
  
  =item B<apply_before_method_modifiers>
  
  =item B<apply_after_method_modifiers>
  
  =item B<apply_around_method_modifiers>
  
  =item B<apply_override_method_modifiers>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Application/RoleSummation.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_ROLESUMMATION';
  package Moose::Meta::Role::Application::RoleSummation;
  BEGIN {
    $Moose::Meta::Role::Application::RoleSummation::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Application::RoleSummation::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util 'blessed';
  
  use Moose::Meta::Role::Composite;
  
  use base 'Moose::Meta::Role::Application';
  
  __PACKAGE__->meta->add_attribute('role_params' => (
      reader  => 'role_params',
      default => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  sub get_exclusions_for_role {
      my ($self, $role) = @_;
      $role = $role->name if blessed $role;
      my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ?
                             '-excludes' : 'excludes';
      if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) {
          if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') {
              return $self->role_params->{$role}->{$excludes_key};
          }
          return [ $self->role_params->{$role}->{$excludes_key} ];
      }
      return [];
  }
  
  sub get_method_aliases_for_role {
      my ($self, $role) = @_;
      $role = $role->name if blessed $role;
      my $alias_key = exists $self->role_params->{$role}->{'-alias'} ?
                          '-alias' : 'alias';
      if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) {
          return $self->role_params->{$role}->{$alias_key};
      }
      return {};
  }
  
  sub is_method_excluded {
      my ($self, $role, $method_name) = @_;
      foreach ($self->get_exclusions_for_role($role->name)) {
          return 1 if $_ eq $method_name;
      }
      return 0;
  }
  
  sub is_method_aliased {
      my ($self, $role, $method_name) = @_;
      exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0
  }
  
  sub is_aliased_method {
      my ($self, $role, $method_name) = @_;
      my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)};
      exists $aliased_names{$method_name} ? 1 : 0;
  }
  
  sub check_role_exclusions {
      my ($self, $c) = @_;
  
      my %excluded_roles;
      for my $role (@{ $c->get_roles }) {
          my $name = $role->name;
  
          for my $excluded ($role->get_excluded_roles_list) {
              push @{ $excluded_roles{$excluded} }, $name;
          }
      }
  
      foreach my $role (@{$c->get_roles}) {
          foreach my $excluded (keys %excluded_roles) {
              next unless $role->does_role($excluded);
  
              my @excluding = @{ $excluded_roles{$excluded} };
  
              require Moose;
              Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded);
          }
      }
  
      $c->add_excluded_roles(keys %excluded_roles);
  }
  
  sub check_required_methods {
      my ($self, $c) = @_;
  
      my %all_required_methods =
          map { $_->name => $_ }
          map { $_->get_required_method_list }
          @{$c->get_roles};
  
      foreach my $role (@{$c->get_roles}) {
          foreach my $required (keys %all_required_methods) {
  
              delete $all_required_methods{$required}
                  if $role->has_method($required)
                  || $self->is_aliased_method($role, $required);
          }
      }
  
      $c->add_required_methods(values %all_required_methods);
  }
  
  sub check_required_attributes {
  
  }
  
  sub apply_attributes {
      my ($self, $c) = @_;
  
      my @all_attributes;
  
      for my $role ( @{ $c->get_roles } ) {
          push @all_attributes,
              map { $role->get_attribute($_) } $role->get_attribute_list;
      }
  
      my %seen;
      foreach my $attr (@all_attributes) {
          my $name = $attr->name;
  
          if ( exists $seen{$name} ) {
              next if $seen{$name}->is_same_as($attr);
  
              my $role1 = $seen{$name}->associated_role->name;
              my $role2 = $attr->associated_role->name;
  
              require Moose;
              Moose->throw_error(
                  "We have encountered an attribute conflict with '$name' "
                      . "during role composition. "
                      . " This attribute is defined in both $role1 and $role2."
                      . " This is a fatal error and cannot be disambiguated." );
          }
  
          $seen{$name} = $attr;
      }
  
      foreach my $attr (@all_attributes) {
          $c->add_attribute( $attr->clone );
      }
  }
  
  sub apply_methods {
      my ($self, $c) = @_;
  
      my @all_methods = map {
          my $role     = $_;
          my $aliases  = $self->get_method_aliases_for_role($role);
          my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) };
          (
              (map {
                  exists $excludes{$_} ? () :
                  +{
                      role   => $role,
                      name   => $_,
                      method => $role->get_method($_),
                  }
              } map { $_->name }
                grep { !$_->isa('Class::MOP::Method::Meta') }
                     $role->_get_local_methods),
              (map {
                  +{
                      role   => $role,
                      name   => $aliases->{$_},
                      method => $role->get_method($_),
                  }
              } keys %$aliases)
          );
      } @{$c->get_roles};
  
      my (%seen, %method_map);
      foreach my $method (@all_methods) {
          my $seen = $seen{$method->{name}};
  
          if ($seen) {
              if ($seen->{method}->body != $method->{method}->body) {
                  $c->add_conflicting_method(
                      name  => $method->{name},
                      roles => [$method->{role}->name, $seen->{role}->name],
                  );
  
                  delete $method_map{$method->{name}};
                  next;
              }
          }
  
          $seen{$method->{name}}       = $method;
          $method_map{$method->{name}} = $method->{method};
      }
  
      $c->add_method($_ => $method_map{$_}) for keys %method_map;
  }
  
  sub apply_override_method_modifiers {
      my ($self, $c) = @_;
  
      my @all_overrides = map {
          my $role = $_;
          map {
              +{
                  name   => $_,
                  method => $role->get_override_method_modifier($_),
              }
          } $role->get_method_modifier_list('override');
      } @{$c->get_roles};
  
      my %seen;
      foreach my $override (@all_overrides) {
          if ( $c->has_method($override->{name}) ){
              require Moose;
              Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " .
                                  "during composition (A local method of the same name as been found). This " .
                                  "is fatal error." )
          }
          if (exists $seen{$override->{name}}) {
              if ( $seen{$override->{name}} != $override->{method} ) {
                  require Moose;
                  Moose->throw_error( "We have encountered an 'override' method conflict during " .
                                      "composition (Two 'override' methods of the same name encountered). " .
                                      "This is fatal error.")
              }
          }
          $seen{$override->{name}} = $override->{method};
      }
  
      $c->add_override_method_modifier(
          $_->{name}, $_->{method}
      ) for @all_overrides;
  
  }
  
  sub apply_method_modifiers {
      my ($self, $modifier_type, $c) = @_;
      my $add = "add_${modifier_type}_method_modifier";
      my $get = "get_${modifier_type}_method_modifiers";
      foreach my $role (@{$c->get_roles}) {
          foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
              $c->$add(
                  $method_name,
                  $_
              ) foreach $role->$get($method_name);
          }
      }
  }
  
  1;
  
  # ABSTRACT: Combine two or more roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Application::RoleSummation - Combine two or more roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  Summation composes two traits, forming the union of non-conflicting
  bindings and 'disabling' the conflicting bindings
  
  =head2 METHODS
  
  =over 4
  
  =item B<new>
  
  =item B<meta>
  
  =item B<role_params>
  
  =item B<get_exclusions_for_role>
  
  =item B<get_method_aliases_for_role>
  
  =item B<is_aliased_method>
  
  =item B<is_method_aliased>
  
  =item B<is_method_excluded>
  
  =item B<apply>
  
  =item B<check_role_exclusions>
  
  =item B<check_required_methods>
  
  =item B<check_required_attributes>
  
  =item B<apply_attributes>
  
  =item B<apply_methods>
  
  =item B<apply_method_modifiers>
  
  =item B<apply_override_method_modifiers>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_ROLESUMMATION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Application/ToClass.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOCLASS';
  package Moose::Meta::Role::Application::ToClass;
  BEGIN {
    $Moose::Meta::Role::Application::ToClass::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Application::ToClass::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use List::MoreUtils 'firstval';
  use Moose::Util  'english_list';
  use Scalar::Util 'weaken', 'blessed';
  
  use base 'Moose::Meta::Role::Application';
  
  __PACKAGE__->meta->add_attribute('role' => (
      reader => 'role',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('class' => (
      accessor => 'class',
      Class::MOP::_definition_context(),
  ));
  
  sub apply {
      my ($self, $role, $class) = @_;
  
      # We need weak_ref in CMOP :(
      weaken($self->{role}  = $role);
      weaken($self->{class} = $class);
  
      $self->SUPER::apply($role, $class);
  
      $class->add_role($role);
      $class->add_role_application($self);
  }
  
  sub check_role_exclusions {
      my ($self, $role, $class) = @_;
      if ($class->excludes_role($role->name)) {
          $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
      }
      foreach my $excluded_role_name ($role->get_excluded_roles_list) {
          if ($class->does_role($excluded_role_name)) {
              $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'");
          }
      }
  }
  
  sub check_required_methods {
      my ($self, $role, $class) = @_;
  
      my @missing;
      my @is_attr;
  
      # NOTE:
      # we might need to move this down below the
      # the attributes so that we can require any
      # attribute accessors. However I am thinking
      # that maybe those are somehow exempt from
      # the require methods stuff.
      foreach my $required_method ($role->get_required_method_list) {
          my $required_method_name = $required_method->name;
  
          if (!$class->find_method_by_name($required_method_name)) {
  
              next if $self->is_aliased_method($required_method_name);
  
              push @missing, $required_method;
          }
      }
  
      return unless @missing;
  
      my $error = '';
  
      @missing = sort { $a->name cmp $b->name } @missing;
      my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing;
  
      if (@conflicts) {
          my $conflict = $conflicts[0];
          my $roles = $conflict->roles_as_english_list;
  
          my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts;
  
          if (@same_role_conflicts == 1) {
              $error
                  .= "Due to a method name conflict in roles "
                  .  $roles
                  . ", the method '"
                  . $conflict->name
                  . "' must be implemented or excluded by '"
                  . $class->name
                  . q{'};
          }
          else {
              my $methods
                  = Moose::Util::english_list( map { q{'} . $_->name . q{'} } @same_role_conflicts );
  
              $error
                  .= "Due to method name conflicts in roles "
                  .  $roles
                  . ", the methods "
                  . $methods
                  . " must be implemented or excluded by '"
                  . $class->name
                  . q{'};
          }
      }
      elsif (@missing) {
          my $noun = @missing == 1 ? 'method' : 'methods';
  
          my $list
              = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing );
  
          $error
              .= q{'}
              . $role->name
              . "' requires the $noun $list "
              . "to be implemented by '"
              . $class->name . q{'};
  
          if (my $meth = firstval { $class->name->can($_) } @missing) {
              $error .= ". If you imported functions intending to use them as "
                      . "methods, you need to explicitly mark them as such, via "
                      . $class->name . "->meta->add_method($meth => \\\&$meth)";
          }
      }
  
      $class->throw_error($error);
  }
  
  sub check_required_attributes {
  
  }
  
  sub apply_attributes {
      my ($self, $role, $class) = @_;
  
      foreach my $attribute_name ($role->get_attribute_list) {
          # it if it has one already
          if ($class->has_attribute($attribute_name) &&
              # make sure we haven't seen this one already too
              $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) {
              next;
          }
          else {
              $class->add_attribute(
                  $role->get_attribute($attribute_name)->attribute_for_class
              );
          }
      }
  }
  
  sub apply_methods {
      my ( $self, $role, $class ) = @_;
  
      foreach my $method ( $role->_get_local_methods ) {
          my $method_name = $method->name;
  
          next if $method->isa('Class::MOP::Method::Meta');
  
          unless ( $self->is_method_excluded($method_name) ) {
  
              my $class_method = $class->get_method($method_name);
  
              next if $class_method && $class_method->body != $method->body;
  
              $class->add_method(
                  $method_name,
                  $method,
              );
          }
  
          next unless $self->is_method_aliased($method_name);
  
          my $aliased_method_name = $self->get_method_aliases->{$method_name};
  
          my $class_method = $class->get_method($aliased_method_name);
  
          if ( $class_method && $class_method->body != $method->body ) {
              $class->throw_error(
                  "Cannot create a method alias if a local method of the same name exists"
              );
          }
  
          $class->add_method(
              $aliased_method_name,
              $method,
          );
      }
  
      # we must reset the cache here since
      # we are just aliasing methods, otherwise
      # the modifiers go wonky.
      $class->reset_package_cache_flag;
  }
  
  sub apply_override_method_modifiers {
      my ($self, $role, $class) = @_;
      foreach my $method_name ($role->get_method_modifier_list('override')) {
          # it if it has one already then ...
          if ($class->has_method($method_name)) {
              next;
          }
          else {
              # if this is not a role, then we need to
              # find the original package of the method
              # so that we can tell the class were to
              # find the right super() method
              my $method = $role->get_override_method_modifier($method_name);
              my ($package) = Class::MOP::get_code_info($method);
              # if it is a class, we just add it
              $class->add_override_method_modifier($method_name, $method, $package);
          }
      }
  }
  
  sub apply_method_modifiers {
      my ($self, $modifier_type, $role, $class) = @_;
      my $add = "add_${modifier_type}_method_modifier";
      my $get = "get_${modifier_type}_method_modifiers";
      foreach my $method_name ($role->get_method_modifier_list($modifier_type)) {
          $class->$add(
              $method_name,
              $_
          ) foreach $role->$get($method_name);
      }
  }
  
  1;
  
  # ABSTRACT: Compose a role into a class
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Application::ToClass - Compose a role into a class
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  =head2 METHODS
  
  =over 4
  
  =item B<new>
  
  =item B<meta>
  
  =item B<apply>
  
  =item B<check_role_exclusions>
  
  =item B<check_required_methods>
  
  =item B<check_required_attributes>
  
  =item B<apply_attributes>
  
  =item B<apply_methods>
  
  =item B<apply_method_modifiers>
  
  =item B<apply_override_method_modifiers>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOCLASS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Application/ToInstance.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOINSTANCE';
  package Moose::Meta::Role::Application::ToInstance;
  BEGIN {
    $Moose::Meta::Role::Application::ToInstance::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Application::ToInstance::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util 'blessed';
  use List::MoreUtils 'all';
  
  use base 'Moose::Meta::Role::Application';
  
  __PACKAGE__->meta->add_attribute('rebless_params' => (
      reader  => 'rebless_params',
      default => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  sub apply {
      my ( $self, $role, $object, $args ) = @_;
  
      my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class';
  
      # This is a special case to handle the case where the object's metaclass
      # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example,
      # when applying a role to a Moose::Meta::Attribute object).
      $obj_meta = 'Moose::Meta::Class'
          unless $obj_meta->isa('Moose::Meta::Class');
  
      my $class = $obj_meta->create_anon_class(
          superclasses => [ blessed($object) ],
          roles => [ $role, keys(%$args) ? ($args) : () ],
          cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args),
      );
  
      $class->rebless_instance( $object, %{ $self->rebless_params } );
  }
  
  1;
  
  # ABSTRACT: Compose a role into an instance
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Application::ToInstance - Compose a role into an instance
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  =head2 METHODS
  
  =over 4
  
  =item B<new>
  
  =item B<meta>
  
  =item B<apply>
  
  =item B<rebless_params>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOINSTANCE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Application/ToRole.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOROLE';
  package Moose::Meta::Role::Application::ToRole;
  BEGIN {
    $Moose::Meta::Role::Application::ToRole::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Application::ToRole::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util    'blessed';
  
  use base 'Moose::Meta::Role::Application';
  
  sub apply {
      my ($self, $role1, $role2) = @_;
      $self->SUPER::apply($role1, $role2);
      $role2->add_role($role1);
  }
  
  sub check_role_exclusions {
      my ($self, $role1, $role2) = @_;
      if ( $role2->excludes_role($role1->name) ) {
          require Moose;
          Moose->throw_error("Conflict detected: " . $role2->name . " excludes role '" . $role1->name . "'");
      }
      foreach my $excluded_role_name ($role1->get_excluded_roles_list) {
          if ( $role2->does_role($excluded_role_name) ) {
              require Moose;
              Moose->throw_error("The class " . $role2->name . " does the excluded role '$excluded_role_name'");
          }
          $role2->add_excluded_roles($excluded_role_name);
      }
  }
  
  sub check_required_methods {
      my ($self, $role1, $role2) = @_;
      foreach my $required_method ($role1->get_required_method_list) {
          my $required_method_name = $required_method->name;
  
          next if $self->is_aliased_method($required_method_name);
  
          $role2->add_required_methods($required_method)
              unless $role2->find_method_by_name($required_method_name);
      }
  }
  
  sub check_required_attributes {
  
  }
  
  sub apply_attributes {
      my ($self, $role1, $role2) = @_;
      foreach my $attribute_name ($role1->get_attribute_list) {
          # it if it has one already
          if ($role2->has_attribute($attribute_name) &&
              # make sure we haven't seen this one already too
              $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) {
  
              my $role2_name = $role2->name;
  
              require Moose;
              Moose->throw_error( "Role '"
                      . $role1->name
                      . "' has encountered an attribute conflict"
                      . " while being composed into '$role2_name'."
                      . " This is a fatal error and cannot be disambiguated."
                      . " The conflicting attribute is named '$attribute_name'." );
          }
          else {
              $role2->add_attribute(
                  $role1->get_attribute($attribute_name)->clone
              );
          }
      }
  }
  
  sub apply_methods {
      my ( $self, $role1, $role2 ) = @_;
      foreach my $method ( $role1->_get_local_methods ) {
  
          my $method_name = $method->name;
  
          next if $method->isa('Class::MOP::Method::Meta');
  
          unless ( $self->is_method_excluded($method_name) ) {
  
              my $role2_method = $role2->get_method($method_name);
              if (   $role2_method
                  && $role2_method->body != $method->body ) {
  
                  # method conflicts between roles result in the method becoming
                  # a requirement
                  $role2->add_conflicting_method(
                      name  => $method_name,
                      roles => [ $role1->name, $role2->name ],
                  );
              }
              else {
                  $role2->add_method(
                      $method_name,
                      $method,
                  );
              }
          }
  
          next unless $self->is_method_aliased($method_name);
  
          my $aliased_method_name = $self->get_method_aliases->{$method_name};
  
          my $role2_method = $role2->get_method($aliased_method_name);
  
          if (   $role2_method
              && $role2_method->body != $method->body ) {
  
              require Moose;
              Moose->throw_error(
                  "Cannot create a method alias if a local method of the same name exists"
              );
          }
  
          $role2->add_method(
              $aliased_method_name,
              $role1->get_method($method_name)
          );
  
          if ( !$role2->has_method($method_name) ) {
              $role2->add_required_methods($method_name)
                  unless $self->is_method_excluded($method_name);
          }
      }
  }
  
  sub apply_override_method_modifiers {
      my ($self, $role1, $role2) = @_;
      foreach my $method_name ($role1->get_method_modifier_list('override')) {
          # it if it has one already then ...
          if ($role2->has_method($method_name)) {
              # if it is being composed into another role
              # we have a conflict here, because you cannot
              # combine an overridden method with a locally
              # defined one
              require Moose;
              Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
                      "during composition (A local method of the same name as been found). This " .
                      "is fatal error.");
          }
          else {
              # if we are a role, we need to make sure
              # we dont have a conflict with the role
              # we are composing into
              if ($role2->has_override_method_modifier($method_name) &&
                  $role2->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) {
  
                  require Moose;
                  Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " .
                          "during composition (Two 'override' methods of the same name encountered). " .
                          "This is fatal error.");
              }
              else {
                  # if there is no conflict,
                  # just add it to the role
                  $role2->add_override_method_modifier(
                      $method_name,
                      $role1->get_override_method_modifier($method_name)
                  );
              }
          }
      }
  }
  
  sub apply_method_modifiers {
      my ($self, $modifier_type, $role1, $role2) = @_;
      my $add = "add_${modifier_type}_method_modifier";
      my $get = "get_${modifier_type}_method_modifiers";
      foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) {
          $role2->$add(
              $method_name,
              $_
          ) foreach $role1->$get($method_name);
      }
  }
  
  
  1;
  
  # ABSTRACT: Compose a role into another role
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Application::ToRole - Compose a role into another role
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  =head2 METHODS
  
  =over 4
  
  =item B<new>
  
  =item B<meta>
  
  =item B<apply>
  
  =item B<check_role_exclusions>
  
  =item B<check_required_methods>
  
  =item B<check_required_attributes>
  
  =item B<apply_attributes>
  
  =item B<apply_methods>
  
  =item B<apply_method_modifiers>
  
  =item B<apply_override_method_modifiers>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_APPLICATION_TOROLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Attribute.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_ATTRIBUTE';
  package Moose::Meta::Role::Attribute;
  BEGIN {
    $Moose::Meta::Role::Attribute::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Attribute::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp 'confess';
  use List::MoreUtils 'all';
  use Scalar::Util 'blessed', 'weaken';
  
  use base 'Moose::Meta::Mixin::AttributeCore', 'Class::MOP::Object';
  
  __PACKAGE__->meta->add_attribute(
      'metaclass' => (
          reader => 'metaclass',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'associated_role' => (
          reader => 'associated_role',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      '_original_role' => (
          reader => '_original_role',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'is' => (
          reader => 'is',
          Class::MOP::_definition_context(),
      )
  );
  
  __PACKAGE__->meta->add_attribute(
      'original_options' => (
          reader => 'original_options',
          Class::MOP::_definition_context(),
      )
  );
  
  sub new {
      my ( $class, $name, %options ) = @_;
  
      (defined $name)
          || confess "You must provide a name for the attribute";
  
      my $role = delete $options{_original_role};
  
      return bless {
          name             => $name,
          original_options => \%options,
          _original_role   => $role,
          %options,
      }, $class;
  }
  
  sub attach_to_role {
      my ( $self, $role ) = @_;
  
      ( blessed($role) && $role->isa('Moose::Meta::Role') )
          || confess
          "You must pass a Moose::Meta::Role instance (or a subclass)";
  
      weaken( $self->{'associated_role'} = $role );
  }
  
  sub original_role {
      my $self = shift;
  
      return $self->_original_role || $self->associated_role;
  }
  
  sub attribute_for_class {
      my $self = shift;
  
      my $metaclass = $self->original_role->applied_attribute_metaclass;
  
      return $metaclass->interpolate_class_and_new(
          $self->name => %{ $self->original_options } );
  }
  
  sub clone {
      my $self = shift;
  
      my $role = $self->original_role;
  
      return ( ref $self )->new(
          $self->name,
          %{ $self->original_options },
          _original_role => $role,
      );
  }
  
  sub is_same_as {
      my $self = shift;
      my $attr = shift;
  
      my $self_options = $self->original_options;
      my $other_options = $attr->original_options;
  
      return 0
          unless ( join q{|}, sort keys %{$self_options} ) eq ( join q{|}, sort keys %{$other_options} );
  
      for my $key ( keys %{$self_options} ) {
          return 0 if defined $self_options->{$key} && ! defined $other_options->{$key};
          return 0 if ! defined $self_options->{$key} && defined $other_options->{$key};
  
          next if all { ! defined } $self_options->{$key}, $other_options->{$key};
  
          return 0 unless $self_options->{$key} eq $other_options->{$key};
      }
  
      return 1;
  }
  
  1;
  
  # ABSTRACT: The Moose attribute metaclass for Roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Attribute - The Moose attribute metaclass for Roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class implements the API for attributes in roles. Attributes in roles are
  more like attribute prototypes than full blown attributes. While they are
  introspectable, they have very little behavior.
  
  =head1 METHODS
  
  This class provides the following methods:
  
  =over 4
  
  =item B<< Moose::Meta::Role::Attribute->new(...) >>
  
  This method accepts all the options that would be passed to the constructor
  for L<Moose::Meta::Attribute>.
  
  =item B<< $attr->metaclass >>
  
  =item B<< $attr->is >>
  
  Returns the option as passed to the constructor.
  
  =item B<< $attr->associated_role >>
  
  Returns the L<Moose::Meta::Role> to which this attribute belongs, if any.
  
  =item B<< $attr->original_role >>
  
  Returns the L<Moose::Meta::Role> in which this attribute was first
  defined. This may not be the same as the value C<associated_role()> in the
  case of composite role, or the case where one role consumes other roles.
  
  =item B<< $attr->original_options >>
  
  Returns a hash reference of options passed to the constructor. This is used
  when creating a L<Moose::Meta::Attribute> object from this object.
  
  =item B<< $attr->attach_to_role($role) >>
  
  Attaches the attribute to the given L<Moose::Meta::Role>.
  
  =item B<< $attr->attribute_for_class($metaclass) >>
  
  Given an attribute metaclass name, this method calls C<<
  $metaclass->interpolate_class_and_new >> to construct an attribute object
  which can be added to a L<Moose::Meta::Class>.
  
  =item B<< $attr->clone >>
  
  Creates a new object identical to the object on which the method is called.
  
  =item B<< $attr->is_same_as($other_attr) >>
  
  Compares two role attributes and returns true if they are identical.
  
  =back
  
  In addition, this class implements all informational predicates implements by
  L<Moose::Meta::Attribute> (and L<Class::MOP::Attribute>).
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_ATTRIBUTE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Composite.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_COMPOSITE';
  package Moose::Meta::Role::Composite;
  BEGIN {
    $Moose::Meta::Role::Composite::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Composite::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Class::Load qw(load_class);
  use Scalar::Util 'blessed';
  
  use base 'Moose::Meta::Role';
  
  # NOTE:
  # we need to override the ->name
  # method from Class::MOP::Package
  # since we don't have an actual
  # package for this.
  # - SL
  __PACKAGE__->meta->add_attribute('name' => (
      reader => 'name',
      Class::MOP::_definition_context(),
  ));
  
  # NOTE:
  # Again, since we don't have a real
  # package to store our methods in,
  # we use a HASH ref instead.
  # - SL
  __PACKAGE__->meta->add_attribute('_methods' => (
      reader  => '_method_map',
      default => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute(
      'application_role_summation_class',
      reader  => 'application_role_summation_class',
      default => 'Moose::Meta::Role::Application::RoleSummation',
      Class::MOP::_definition_context(),
  );
  
  sub new {
      my ($class, %params) = @_;
  
      # the roles param is required ...
      foreach ( @{$params{roles}} ) {
          unless ( $_->isa('Moose::Meta::Role') ) {
              require Moose;
              Moose->throw_error("The list of roles must be instances of Moose::Meta::Role, not $_");
          }
      }
  
      my @composition_roles = map {
          $_->composition_class_roles
      } @{ $params{roles} };
  
      if (@composition_roles) {
          my $meta = Moose::Meta::Class->create_anon_class(
              superclasses => [ $class ],
              roles        => [ @composition_roles ],
              cache        => 1,
          );
          $class = $meta->name;
      }
  
      # and the name is created from the
      # roles if one has not been provided
      $params{name} ||= (join "|" => map { $_->name } @{$params{roles}});
      $class->_new(\%params);
  }
  
  # This is largely a cope of what's in Moose::Meta::Role (itself
  # largely a copy of Class::MOP::Class). However, we can't actually
  # call add_package_symbol, because there's no package to which which
  # add the symbol.
  sub add_method {
      my ($self, $method_name, $method) = @_;
  
      unless ( defined $method_name && $method_name ) {
          Moose->throw_error("You must define a method name");
      }
  
      my $body;
      if (blessed($method)) {
          $body = $method->body;
          if ($method->package_name ne $self->name) {
              $method = $method->clone(
                  package_name => $self->name,
                  name         => $method_name
              ) if $method->can('clone');
          }
      }
      else {
          $body = $method;
          $method = $self->wrap_method_body( body => $body, name => $method_name );
      }
  
      $self->_method_map->{$method_name} = $method;
  }
  
  sub get_method_list {
      my $self = shift;
      return keys %{ $self->_method_map };
  }
  
  sub _get_local_methods {
      my $self = shift;
      return values %{ $self->_method_map };
  }
  
  sub has_method {
      my ($self, $method_name) = @_;
  
      return exists $self->_method_map->{$method_name};
  }
  
  sub get_method {
      my ($self, $method_name) = @_;
  
      return $self->_method_map->{$method_name};
  }
  
  sub apply_params {
      my ($self, $role_params) = @_;
      load_class($self->application_role_summation_class);
  
      $self->application_role_summation_class->new(
          role_params => $role_params,
      )->apply($self);
  
      return $self;
  }
  
  sub reinitialize {
      my ( $class, $old_meta, @args ) = @_;
  
      Moose->throw_error(
          'Moose::Meta::Role::Composite instances can only be reinitialized from an existing metaclass instance'
          )
          if !blessed $old_meta
              || !$old_meta->isa('Moose::Meta::Role::Composite');
  
      my %existing_classes = map { $_ => $old_meta->$_() } qw(
          application_role_summation_class
      );
  
      return $old_meta->meta->clone_object( $old_meta, %existing_classes, @args );
  }
  
  1;
  
  # ABSTRACT: An object to represent the set of roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Composite - An object to represent the set of roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  A composite is a role that consists of a set of two or more roles.
  
  The API of a composite role is almost identical to that of a regular
  role.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Role::Composite> is a subclass of L<Moose::Meta::Role>.
  
  =head2 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Role::Composite->new(%options) >>
  
  This returns a new composite role object. It accepts the same
  options as its parent class, with a few changes:
  
  =over 8
  
  =item * roles
  
  This option is an array reference containing a list of
  L<Moose::Meta::Role> object. This is a required option.
  
  =item * name
  
  If a name is not given, one is generated from the roles provided.
  
  =item * apply_params(\%role_params)
  
  Creates a new RoleSummation role application with C<%role_params> and applies
  the composite role to it. The RoleSummation role application class used is
  determined by the composite role's C<application_role_summation_class>
  attribute.
  
  =item * reinitialize($metaclass)
  
  Like C<< Class::MOP::Package->reinitialize >>, but doesn't allow passing a
  string with the package name, as there is no real package for composite roles.
  
  =back
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_COMPOSITE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Method.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD';
  
  package Moose::Meta::Role::Method;
  BEGIN {
    $Moose::Meta::Role::Method::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Method::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use base 'Moose::Meta::Method';
  
  sub _make_compatible_with {
      my $self = shift;
      my ($other) = @_;
  
      # XXX: this is pretty gross. the issue here is blah blah blah
      # see the comments in CMOP::Method::Meta and CMOP::Method::Wrapped
      return $self unless $other->_is_compatible_with($self->_real_ref_name);
  
      return $self->SUPER::_make_compatible_with(@_);
  }
  
  1;
  
  # ABSTRACT: A Moose Method metaclass for Roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Method - A Moose Method metaclass for Roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is primarily used to mark methods coming from a role
  as being different. Right now it is nothing but a subclass
  of L<Moose::Meta::Method>.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Method/Conflicting.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD_CONFLICTING';
  
  package Moose::Meta::Role::Method::Conflicting;
  BEGIN {
    $Moose::Meta::Role::Method::Conflicting::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Method::Conflicting::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Moose::Util;
  
  use base qw(Moose::Meta::Role::Method::Required);
  
  __PACKAGE__->meta->add_attribute('roles' => (
      reader   => 'roles',
      required => 1,
      Class::MOP::_definition_context(),
  ));
  
  sub roles_as_english_list {
      my $self = shift;
      Moose::Util::english_list( map { q{'} . $_ . q{'} } @{ $self->roles } );
  }
  
  1;
  
  # ABSTRACT: A Moose metaclass for conflicting methods in Roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Method::Conflicting - A Moose metaclass for conflicting methods in Roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Role::Method::Conflicting> is a subclass of
  L<Moose::Meta::Role::Method::Required>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Role::Method::Conflicting->new(%options) >>
  
  This creates a new type constraint based on the provided C<%options>:
  
  =over 8
  
  =item * name
  
  The method name. This is required.
  
  =item * roles
  
  The list of role names that generated the conflict. This is required.
  
  =back
  
  =item B<< $method->name >>
  
  Returns the conflicting method's name, as provided to the constructor.
  
  =item B<< $method->roles >>
  
  Returns the roles that generated this conflicting method, as provided to the
  constructor.
  
  =item B<< $method->roles_as_english_list >>
  
  Returns the roles that generated this conflicting method as an English list.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD_CONFLICTING

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/Role/Method/Required.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD_REQUIRED';
  
  package Moose::Meta::Role::Method::Required;
  BEGIN {
    $Moose::Meta::Role::Method::Required::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::Role::Method::Required::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use overload '""'     => sub { shift->name },   # stringify to method name
               fallback => 1;
  
  use base qw(Class::MOP::Object);
  
  # This is not a Moose::Meta::Role::Method because it has no implementation, it
  # is just a name
  
  __PACKAGE__->meta->add_attribute('name' => (
      reader   => 'name',
      required => 1,
      Class::MOP::_definition_context(),
  ));
  
  sub new { shift->_new(@_) }
  
  1;
  
  # ABSTRACT: A Moose metaclass for required methods in Roles
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::Role::Method::Required - A Moose metaclass for required methods in Roles
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  =head1 INHERITANCE
  
  C<Moose::Meta::Role::Method::Required> is a subclass of L<Class::MOP::Object>.
  It is B<not> a subclass of C<Moose::Meta::Role::Method> since it does not
  provide an implementation of the method.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::Role::Method::Required->new(%options) >>
  
  This creates a new type constraint based on the provided C<%options>:
  
  =over 8
  
  =item * name
  
  The method name. This is required.
  
  =back
  
  =item B<< $method->name >>
  
  Returns the required method's name, as provided to the constructor.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_ROLE_METHOD_REQUIRED

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeCoercion.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECOERCION';
  
  package Moose::Meta::TypeCoercion;
  BEGIN {
    $Moose::Meta::TypeCoercion::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeCoercion::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Moose::Meta::Attribute;
  use Moose::Util::TypeConstraints ();
  
  __PACKAGE__->meta->add_attribute('type_coercion_map' => (
      reader  => 'type_coercion_map',
      default => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute(
      Moose::Meta::Attribute->new('type_constraint' => (
          reader   => 'type_constraint',
          weak_ref => 1,
          Class::MOP::_definition_context(),
      ))
  );
  
  # private accessor
  __PACKAGE__->meta->add_attribute('compiled_type_coercion' => (
      accessor => '_compiled_type_coercion',
      Class::MOP::_definition_context(),
  ));
  
  sub new {
      my $class = shift;
      my $self  = Class::MOP::class_of($class)->new_object(@_);
      $self->compile_type_coercion;
      return $self;
  }
  
  sub compile_type_coercion {
      my $self = shift;
      my @coercion_map = @{$self->type_coercion_map};
      my @coercions;
      while (@coercion_map) {
          my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
          my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name);
  
          unless ( defined $type_constraint ) {
              require Moose;
              Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from");
          }
  
          push @coercions => [
              $type_constraint->_compiled_type_constraint,
              $action
          ];
      }
      $self->_compiled_type_coercion(sub {
          my $thing = shift;
          foreach my $coercion (@coercions) {
              my ($constraint, $converter) = @$coercion;
              if ($constraint->($thing)) {
                  local $_ = $thing;
                  return $converter->($thing);
              }
          }
          return $thing;
      });
  }
  
  sub has_coercion_for_type {
      my ($self, $type_name) = @_;
      my %coercion_map = @{$self->type_coercion_map};
      exists $coercion_map{$type_name} ? 1 : 0;
  }
  
  sub add_type_coercions {
      my ($self, @new_coercion_map) = @_;
  
      my $coercion_map = $self->type_coercion_map;
      my %has_coercion = @$coercion_map;
  
      while (@new_coercion_map) {
          my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2);
  
          if ( exists $has_coercion{$constraint_name} ) {
              require Moose;
              Moose->throw_error("A coercion action already exists for '$constraint_name'")
          }
  
          push @{$coercion_map} => ($constraint_name, $action);
      }
  
      # and re-compile ...
      $self->compile_type_coercion;
  }
  
  sub coerce { $_[0]->_compiled_type_coercion->($_[1]) }
  
  
  1;
  
  # ABSTRACT: The Moose Type Coercion metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  A type coercion object is basically a mapping of one or more type
  constraints and the associated coercions subroutines.
  
  It's unlikely that you will need to instantiate an object of this
  class directly, as it's part of the deep internals of Moose.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeCoercion->new(%options) >>
  
  Creates a new type coercion object, based on the options provided.
  
  =over 8
  
  =item * type_constraint
  
  This is the L<Moose::Meta::TypeConstraint> object for the type that is
  being coerced I<to>.
  
  =back
  
  =item B<< $coercion->type_coercion_map >>
  
  This returns the map of type constraints to coercions as an array
  reference. The values of the array alternate between type names and
  subroutine references which implement the coercion.
  
  The value is an array reference because coercions are tried in the
  order they are added.
  
  =item B<< $coercion->type_constraint >>
  
  This returns the L<Moose::Meta::TypeConstraint> that was passed to the
  constructor.
  
  =item B<< $coercion->has_coercion_for_type($type_name) >>
  
  Returns true if the coercion can coerce the named type.
  
  =item B<< $coercion->add_type_coercions( $type_name => $sub, ... ) >>
  
  This method takes a list of type names and subroutine references. If
  the coercion already has a mapping for a given type, it throws an
  exception.
  
  Coercions are actually
  
  =item B<< $coercion->coerce($value) >>
  
  This method takes a value and applies the first valid coercion it
  finds.
  
  This means that if the value could belong to more than type in the
  coercion object, the first coercion added is used.
  
  =item B<< Moose::Meta::TypeCoercion->meta >>
  
  This will return a L<Class::MOP::Class> instance for this class.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECOERCION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeCoercion/Union.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECOERCION_UNION';
  
  package Moose::Meta::TypeCoercion::Union;
  BEGIN {
    $Moose::Meta::TypeCoercion::Union::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeCoercion::Union::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util 'blessed';
  
  use base 'Moose::Meta::TypeCoercion';
  
  sub compile_type_coercion {
      my $self            = shift;
      my $type_constraint = $self->type_constraint;
  
      (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union'))
       || Moose->throw_error("You can only create a Moose::Meta::TypeCoercion::Union for a " .
                  "Moose::Meta::TypeConstraint::Union, not a $type_constraint");
  
      $self->_compiled_type_coercion(
          sub {
              my $value = shift;
  
              foreach my $type ( grep { $_->has_coercion }
                  @{ $type_constraint->type_constraints } ) {
                  my $temp = $type->coerce($value);
                  return $temp if $type_constraint->check($temp);
              }
  
              return $value;
          }
      );
  }
  
  sub has_coercion_for_type { 0 }
  
  sub add_type_coercions {
      require Moose;
      Moose->throw_error("Cannot add additional type coercions to Union types");
  }
  
  1;
  
  # ABSTRACT: The Moose Type Coercion metaclass for Unions
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeCoercion::Union - The Moose Type Coercion metaclass for Unions
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This is a subclass of L<Moose::Meta::TypeCoercion> that is used for
  L<Moose::Meta::TypeConstraint::Union> objects.
  =head1 METHODS
  
  =over 4
  
  =item B<< $coercion->has_coercion_for_type >>
  
  This method always returns false.
  
  =item B<< $coercion->add_type_coercions >>
  
  This method always throws an error. You cannot add coercions to a
  union type coercion.
  
  =item B<< $coercion->coerce($value) >>
  
  This method will coerce by trying the coercions for each type in the
  union.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECOERCION_UNION

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT';
  
  package Moose::Meta::TypeConstraint;
  BEGIN {
    $Moose::Meta::TypeConstraint::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use overload '0+'     => sub { refaddr(shift) }, # id an object
               '""'     => sub { shift->name },   # stringify to tc name
               bool     => sub { 1 },
               fallback => 1;
  
  use Carp qw(confess);
  use Class::Load qw(load_class);
  use Eval::Closure;
  use Scalar::Util qw(blessed refaddr);
  use Sub::Name qw(subname);
  use Try::Tiny;
  
  use base qw(Class::MOP::Object);
  
  __PACKAGE__->meta->add_attribute('name'       => (
      reader => 'name',
      Class::MOP::_definition_context(),
  ));
  __PACKAGE__->meta->add_attribute('parent'     => (
      reader    => 'parent',
      predicate => 'has_parent',
      Class::MOP::_definition_context(),
  ));
  
  my $null_constraint = sub { 1 };
  __PACKAGE__->meta->add_attribute('constraint' => (
      reader  => 'constraint',
      writer  => '_set_constraint',
      default => sub { $null_constraint },
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('message'   => (
      accessor  => 'message',
      predicate => 'has_message',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('_default_message' => (
      accessor  => '_default_message',
      Class::MOP::_definition_context(),
  ));
  
  # can't make this a default because it has to close over the type name, and
  # cmop attributes don't have lazy
  my $_default_message_generator = sub {
      my $name = shift;
      sub {
          my $value = shift;
          # have to load it late like this, since it uses Moose itself
          my $can_partialdump = try {
              # versions prior to 0.14 had a potential infinite loop bug
              load_class('Devel::PartialDump', { -version => 0.14 });
              1;
          };
          if ($can_partialdump) {
              $value = Devel::PartialDump->new->dump($value);
          }
          else {
              $value = (defined $value ? overload::StrVal($value) : 'undef');
          }
          return "Validation failed for '" . $name . "' with value $value";
      }
  };
  __PACKAGE__->meta->add_attribute('coercion'   => (
      accessor  => 'coercion',
      predicate => 'has_coercion',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
      init_arg  => 'optimized',
      accessor  => 'hand_optimized_type_constraint',
      predicate => 'has_hand_optimized_type_constraint',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('inlined' => (
      init_arg  => 'inlined',
      accessor  => 'inlined',
      predicate => '_has_inlined_type_constraint',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('inline_environment' => (
      init_arg => 'inline_environment',
      accessor => '_inline_environment',
      default  => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  sub parents {
      my $self = shift;
      $self->parent;
  }
  
  # private accessors
  
  __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
      accessor  => '_compiled_type_constraint',
      predicate => '_has_compiled_type_constraint',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('package_defined_in' => (
      accessor => '_package_defined_in',
      Class::MOP::_definition_context(),
  ));
  
  sub new {
      my $class = shift;
      my ($first, @rest) = @_;
      my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
      $args{name} = $args{name} ? "$args{name}" : "__ANON__";
  
      if ( $args{optimized} ) {
          Moose::Deprecated::deprecated(
              feature => 'optimized type constraint sub ref',
              message =>
                  'Providing an optimized subroutine ref for type constraints is deprecated.'
                  . ' Use the inlining feature (inline_as) instead.'
          );
      }
  
      if ( exists $args{message}
        && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) {
          confess("The 'message' parameter must be a coderef");
      }
  
      my $self  = $class->_new(%args);
      $self->compile_type_constraint()
          unless $self->_has_compiled_type_constraint;
      $self->_default_message($_default_message_generator->($self->name))
          unless $self->has_message;
      return $self;
  }
  
  
  
  sub coerce {
      my $self = shift;
  
      my $coercion = $self->coercion;
  
      unless ($coercion) {
          require Moose;
          Moose->throw_error("Cannot coerce without a type coercion");
      }
  
      return $_[0] if $self->check($_[0]);
  
      return $coercion->coerce(@_);
  }
  
  sub assert_coerce {
      my $self = shift;
  
      my $coercion = $self->coercion;
  
      unless ($coercion) {
          require Moose;
          Moose->throw_error("Cannot coerce without a type coercion");
      }
  
      return $_[0] if $self->check($_[0]);
  
      my $result = $coercion->coerce(@_);
  
      $self->assert_valid($result);
  
      return $result;
  }
  
  sub check {
      my ($self, @args) = @_;
      my $constraint_subref = $self->_compiled_type_constraint;
      return $constraint_subref->(@args) ? 1 : undef;
  }
  
  sub validate {
      my ($self, $value) = @_;
      if ($self->_compiled_type_constraint->($value)) {
          return undef;
      }
      else {
          $self->get_message($value);
      }
  }
  
  sub can_be_inlined {
      my $self = shift;
  
      if ( $self->has_parent && $self->constraint == $null_constraint ) {
          return $self->parent->can_be_inlined;
      }
  
      return $self->_has_inlined_type_constraint;
  }
  
  sub _inline_check {
      my $self = shift;
  
      unless ( $self->can_be_inlined ) {
          require Moose;
          Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name );
      }
  
      if ( $self->has_parent && $self->constraint == $null_constraint ) {
          return $self->parent->_inline_check(@_);
      }
  
      return '( do { ' . $self->inlined->( $self, @_ ) . ' } )';
  }
  
  sub inline_environment {
      my $self = shift;
  
      if ( $self->has_parent && $self->constraint == $null_constraint ) {
          return $self->parent->inline_environment;
      }
  
      return $self->_inline_environment;
  }
  
  sub assert_valid {
      my ($self, $value) = @_;
  
      my $error = $self->validate($value);
      return 1 if ! defined $error;
  
      require Moose;
      Moose->throw_error($error);
  }
  
  sub get_message {
      my ($self, $value) = @_;
      my $msg = $self->has_message
          ? $self->message
          : $self->_default_message;
      local $_ = $value;
      return $msg->($value);
  }
  
  ## type predicates ...
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
  
      return 1 if $self == $other;
  
      if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
          return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
      }
  
      return unless $self->constraint == $other->constraint;
  
      if ( $self->has_parent ) {
          return unless $other->has_parent;
          return unless $self->parent->equals( $other->parent );
      } else {
          return if $other->has_parent;
      }
  
      return;
  }
  
  sub is_a_type_of {
      my ($self, $type_or_name) = @_;
  
      my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
  
      ($self->equals($type) || $self->is_subtype_of($type));
  }
  
  sub is_subtype_of {
      my ($self, $type_or_name) = @_;
  
      my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
  
      my $current = $self;
  
      while (my $parent = $current->parent) {
          return 1 if $parent->equals($type);
          $current = $parent;
      }
  
      return 0;
  }
  
  ## compiling the type constraint
  
  sub compile_type_constraint {
      my $self = shift;
      $self->_compiled_type_constraint($self->_actually_compile_type_constraint);
  }
  
  ## type compilers ...
  
  sub _actually_compile_type_constraint {
      my $self = shift;
  
      return $self->_compile_hand_optimized_type_constraint
          if $self->has_hand_optimized_type_constraint;
  
      if ( $self->can_be_inlined ) {
          return eval_closure(
              source      => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
              environment => $self->inline_environment,
          );
      }
  
      my $check = $self->constraint;
      unless ( defined $check ) {
          require Moose;
          Moose->throw_error( "Could not compile type constraint '"
                  . $self->name
                  . "' because no constraint check" );
      }
  
      return $self->_compile_subtype($check)
          if $self->has_parent;
  
      return $self->_compile_type($check);
  }
  
  sub _compile_hand_optimized_type_constraint {
      my $self = shift;
  
      my $type_constraint = $self->hand_optimized_type_constraint;
  
      unless ( ref $type_constraint ) {
          require Moose;
          Moose->throw_error("Hand optimized type constraint is not a code reference");
      }
  
      return $type_constraint;
  }
  
  sub _compile_subtype {
      my ($self, $check) = @_;
  
      # gather all the parent constraintss in order
      my @parents;
      my $optimized_parent;
      foreach my $parent ($self->_collect_all_parents) {
          # if a parent is optimized, the optimized constraint already includes
          # all of its parents tcs, so we can break the loop
          if ($parent->has_hand_optimized_type_constraint) {
              push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
              last;
          }
          else {
              push @parents => $parent->constraint;
          }
      }
  
      @parents = grep { $_ != $null_constraint } reverse @parents;
  
      unless ( @parents ) {
          return $self->_compile_type($check);
      } elsif( $optimized_parent and @parents == 1 ) {
          # the case of just one optimized parent is optimized to prevent
          # looping and the unnecessary localization
          if ( $check == $null_constraint ) {
              return $optimized_parent;
          } else {
              return subname($self->name, sub {
                  return undef unless $optimized_parent->($_[0]);
                  my (@args) = @_;
                  local $_ = $args[0];
                  $check->(@args);
              });
          }
      } else {
          # general case, check all the constraints, from the first parent to ourselves
          my @checks = @parents;
          push @checks, $check if $check != $null_constraint;
          return subname($self->name => sub {
              my (@args) = @_;
              local $_ = $args[0];
              foreach my $check (@checks) {
                  return undef unless $check->(@args);
              }
              return 1;
          });
      }
  }
  
  sub _compile_type {
      my ($self, $check) = @_;
  
      return $check if $check == $null_constraint; # Item, Any
  
      return subname($self->name => sub {
          my (@args) = @_;
          local $_ = $args[0];
          $check->(@args);
      });
  }
  
  ## other utils ...
  
  sub _collect_all_parents {
      my $self = shift;
      my @parents;
      my $current = $self->parent;
      while (defined $current) {
          push @parents => $current;
          $current = $current->parent;
      }
      return @parents;
  }
  
  sub create_child_type {
      my ($self, %opts) = @_;
      my $class = ref $self;
      return $class->new(%opts, parent => $self);
  }
  
  1;
  
  # ABSTRACT: The Moose Type Constraint metaclass
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents a single type constraint. Moose's built-in type
  constraints, as well as constraints you define, are all stored in a
  L<Moose::Meta::TypeConstraint::Registry> object as objects of this
  class.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint->new(%options) >>
  
  This creates a new type constraint based on the provided C<%options>:
  
  =over 8
  
  =item * name
  
  The constraint name. If a name is not provided, it will be set to
  "__ANON__".
  
  =item * parent
  
  A C<Moose::Meta::TypeConstraint> object which is the parent type for
  the type being created. This is optional.
  
  =item * constraint
  
  This is the subroutine reference that implements the actual constraint
  check. This defaults to a subroutine which always returns true.
  
  =item * message
  
  A subroutine reference which is used to generate an error message when
  the constraint fails. This is optional.
  
  =item * coercion
  
  A L<Moose::Meta::TypeCoercion> object representing the coercions to
  the type. This is optional.
  
  =item * inlined
  
  A subroutine which returns a string suitable for inlining this type
  constraint. It will be called as a method on the type constraint object, and
  will receive a single additional parameter, a variable name to be tested
  (usually C<"$_"> or C<"$_[0]">.
  
  This is optional.
  
  =item * inline_environment
  
  A hash reference of variables to close over. The keys are variables names, and
  the values are I<references> to the variables.
  
  =item * optimized
  
  B<This option is deprecated.>
  
  This is a variant of the C<constraint> parameter that is somehow
  optimized. Typically, this means incorporating both the type's
  constraint and all of its parents' constraints into a single
  subroutine reference.
  
  =back
  
  =item B<< $constraint->equals($type_name_or_object) >>
  
  Returns true if the supplied name or type object is the same as the
  current type.
  
  =item B<< $constraint->is_subtype_of($type_name_or_object) >>
  
  Returns true if the supplied name or type object is a parent of the
  current type.
  
  =item B<< $constraint->is_a_type_of($type_name_or_object) >>
  
  Returns true if the given type is the same as the current type, or is
  a parent of the current type. This is a shortcut for checking
  C<equals> and C<is_subtype_of>.
  
  =item B<< $constraint->coerce($value) >>
  
  This will attempt to coerce the value to the type. If the type does not
  have any defined coercions this will throw an error.
  
  If no coercion can produce a value matching C<$constraint>, the original
  value is returned.
  
  =item B<< $constraint->assert_coerce($value) >>
  
  This method behaves just like C<coerce>, but if the result is not valid
  according to C<$constraint>, an error is thrown.
  
  =item B<< $constraint->check($value) >>
  
  Returns true if the given value passes the constraint for the type.
  
  =item B<< $constraint->validate($value) >>
  
  This is similar to C<check>. However, if the type I<is valid> then the
  method returns an explicit C<undef>. If the type is not valid, we call
  C<< $self->get_message($value) >> internally to generate an error
  message.
  
  =item B<< $constraint->assert_valid($value) >>
  
  Like C<check> and C<validate>, this method checks whether C<$value> is
  valid under the constraint.  If it is, it will return true.  If it is not,
  an exception will be thrown with the results of
  C<< $self->get_message($value) >>.
  
  =item B<< $constraint->name >>
  
  Returns the type's name, as provided to the constructor.
  
  =item B<< $constraint->parent >>
  
  Returns the type's parent, as provided to the constructor, if any.
  
  =item B<< $constraint->has_parent >>
  
  Returns true if the type has a parent type.
  
  =item B<< $constraint->parents >>
  
  Returns all of the types parents as an list of type constraint objects.
  
  =item B<< $constraint->constraint >>
  
  Returns the type's constraint, as provided to the constructor.
  
  =item B<< $constraint->get_message($value) >>
  
  This generates a method for the given value. If the type does not have
  an explicit message, we generate a default message.
  
  =item B<< $constraint->has_message >>
  
  Returns true if the type has a message.
  
  =item B<< $constraint->message >>
  
  Returns the type's message as a subroutine reference.
  
  =item B<< $constraint->coercion >>
  
  Returns the type's L<Moose::Meta::TypeCoercion> object, if one
  exists.
  
  =item B<< $constraint->has_coercion >>
  
  Returns true if the type has a coercion.
  
  =item B<< $constraint->can_be_inlined >>
  
  Returns true if this type constraint can be inlined. A type constraint which
  subtypes an inlinable constraint and does not add an additional constraint
  "inherits" its parent type's inlining.
  
  =item B<< $constraint->hand_optimized_type_constraint >>
  
  B<This method is deprecated.>
  
  Returns the type's hand optimized constraint, as provided to the
  constructor via the C<optimized> option.
  
  =item B<< $constraint->has_hand_optimized_type_constraint >>
  
  B<This method is deprecated.>
  
  Returns true if the type has an optimized constraint.
  
  =item B<< $constraint->create_child_type(%options) >>
  
  This returns a new type constraint of the same class using the
  provided C<%options>. The C<parent> option will be the current type.
  
  This method exists so that subclasses of this class can override this
  behavior and change how child types are created.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Class.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_CLASS';
  package Moose::Meta::TypeConstraint::Class;
  BEGIN {
    $Moose::Meta::TypeConstraint::Class::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Class::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use B;
  use Scalar::Util 'blessed';
  use Moose::Util::TypeConstraints ();
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('class' => (
      reader => 'class',
      Class::MOP::_definition_context(),
  ));
  
  my $inliner = sub {
      my $self = shift;
      my $val  = shift;
  
      return 'Scalar::Util::blessed(' . $val . ')'
               . ' && ' . $val . '->isa(' . B::perlstring($self->class) . ')';
  };
  
  sub new {
      my ( $class, %args ) = @_;
  
      $args{parent}
          = Moose::Util::TypeConstraints::find_type_constraint('Object');
  
      my $class_name = $args{class};
      $args{constraint} = sub { $_[0]->isa($class_name) };
  
      $args{inlined} = $inliner;
  
      my $self = $class->SUPER::new( \%args );
  
      $self->compile_type_constraint();
  
      return $self;
  }
  
  sub parents {
      my $self = shift;
      return (
          $self->parent,
          map {
              # FIXME find_type_constraint might find a TC named after the class but that isn't really it
              # I did this anyway since it's a convention that preceded TypeConstraint::Class, and it should DWIM
              # if anybody thinks this problematic please discuss on IRC.
              # a possible fix is to add by attr indexing to the type registry to find types of a certain property
              # regardless of their name
              Moose::Util::TypeConstraints::find_type_constraint($_)
                  ||
              __PACKAGE__->new( class => $_, name => "__ANON__" )
          } Class::MOP::class_of($self->class)->superclasses,
      );
  }
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      if (!defined($other)) {
          if (!ref($type_or_name)) {
              return $self->class eq $type_or_name;
          }
          return;
      }
  
      return unless $other->isa(__PACKAGE__);
  
      return $self->class eq $other->class;
  }
  
  sub is_a_type_of {
      my ($self, $type_or_name) = @_;
  
      ($self->equals($type_or_name) || $self->is_subtype_of($type_or_name));
  }
  
  sub is_subtype_of {
      my ($self, $type_or_name_or_class ) = @_;
  
      my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class);
  
      if ( not defined $type ) {
          if ( not ref $type_or_name_or_class ) {
              # it might be a class
              my $class = $self->class;
              return 1 if $class ne $type_or_name_or_class
                       && $class->isa( $type_or_name_or_class );
          }
          return;
      }
  
      if ( $type->isa(__PACKAGE__) && $type->class ne $self->class) {
          # if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type
          # or it could also just be a type object in this branch
          return $self->class->isa( $type->class );
      } else {
          # the only other thing we are a subtype of is Object
          $self->SUPER::is_subtype_of($type);
      }
  }
  
  # This is a bit counter-intuitive, but a child type of a Class type
  # constraint is not itself a Class type constraint (it has no class
  # attribute). This whole create_child_type thing needs some changing
  # though, probably making MMC->new a factory or something.
  sub create_child_type {
      my ($self, @args) = @_;
      return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  }
  
  sub get_message {
      my $self = shift;
      my ($value) = @_;
  
      if ($self->has_message) {
          return $self->SUPER::get_message(@_);
      }
  
      $value = (defined $value ? overload::StrVal($value) : 'undef');
      return "Validation failed for '" . $self->name . "' with value $value (not isa " . $self->class . ")";
  }
  
  1;
  
  # ABSTRACT: Class/TypeConstraint parallel hierarchy
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents type constraints for a class.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Class> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::Class->new(%options) >>
  
  This creates a new class type constraint based on the given
  C<%options>.
  
  It takes the same options as its parent, with two exceptions. First,
  it requires an additional option, C<class>, which is name of the
  constraint's class.  Second, it automatically sets the parent to the
  C<Object> type.
  
  The constructor also overrides the hand optimized type constraint with
  one it creates internally.
  
  =item B<< $constraint->class >>
  
  Returns the class name associated with the constraint.
  
  =item B<< $constraint->parents >>
  
  Returns all the type's parent types, corresponding to its parent
  classes.
  
  =item B<< $constraint->is_subtype_of($type_name_or_object) >>
  
  If the given type is also a class type, then this checks that the
  type's class is a subclass of the other type's class.
  
  Otherwise it falls back to the implementation in
  L<Moose::Meta::TypeConstraint>.
  
  =item B<< $constraint->create_child_type(%options) >>
  
  This returns a new L<Moose::Meta::TypeConstraint> object with the type
  as its parent.
  
  Note that it does I<not> return a
  C<Moose::Meta::TypeConstraint::Class> object!
  
  =item B<< $constraint->get_message($value) >>
  
  This is the same as L<Moose::Meta::TypeConstraint/get_message> except
  that it explicitly says C<isa> was checked. This is to help users deal
  with accidentally autovivified type constraints.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_CLASS

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/DuckType.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_DUCKTYPE';
  package Moose::Meta::TypeConstraint::DuckType;
  BEGIN {
    $Moose::Meta::TypeConstraint::DuckType::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::DuckType::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use B;
  use Scalar::Util 'blessed';
  use List::MoreUtils qw(all);
  use Moose::Util 'english_list';
  
  use Moose::Util::TypeConstraints ();
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('methods' => (
      accessor => 'methods',
      Class::MOP::_definition_context(),
  ));
  
  my $inliner = sub {
      my $self = shift;
      my $val  = shift;
  
      return $self->parent->_inline_check($val)
           . ' && do {' . "\n"
               . 'my $val = ' . $val . ';' . "\n"
               . '&List::MoreUtils::all(' . "\n"
                   . 'sub { $val->can($_) },' . "\n"
                   . join(', ', map { B::perlstring($_) } @{ $self->methods })
               . ');' . "\n"
           . '}';
  };
  
  sub new {
      my ( $class, %args ) = @_;
  
      $args{parent}
          = Moose::Util::TypeConstraints::find_type_constraint('Object');
  
      my @methods = @{ $args{methods} };
      $args{constraint} = sub {
          my $val = $_[0];
          return all { $val->can($_) } @methods;
      };
  
      $args{inlined} = $inliner;
  
      my $self = $class->SUPER::new(\%args);
  
      $self->compile_type_constraint()
          unless $self->_has_compiled_type_constraint;
  
      return $self;
  }
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      return unless $other->isa(__PACKAGE__);
  
      my @self_methods  = sort @{ $self->methods };
      my @other_methods = sort @{ $other->methods };
  
      return unless @self_methods == @other_methods;
  
      while ( @self_methods ) {
          my $method = shift @self_methods;
          my $other_method = shift @other_methods;
  
          return unless $method eq $other_method;
      }
  
      return 1;
  }
  
  sub create_child_type {
      my ($self, @args) = @_;
      return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  }
  
  sub get_message {
      my $self = shift;
      my ($value) = @_;
  
      if ($self->has_message) {
          return $self->SUPER::get_message(@_);
      }
  
      return $self->SUPER::get_message($value) unless blessed($value);
  
      my @methods = grep { !$value->can($_) } @{ $self->methods };
      my $class = blessed $value;
      $class ||= $value;
  
      return $class
           . " is missing methods "
           . english_list(map { "'$_'" } @methods);
  }
  
  1;
  
  # ABSTRACT: Type constraint for duck typing
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents type constraints based on an enumerated list of
  required methods.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >>
  
  This creates a new duck type constraint based on the given
  C<%options>.
  
  It takes the same options as its parent, with several
  exceptions. First, it requires an additional option, C<methods>. This
  should be an array reference containing a list of required method
  names. Second, it automatically sets the parent to the C<Object> type.
  
  Finally, it ignores any provided C<constraint> option. The constraint
  is generated automatically based on the provided C<methods>.
  
  =item B<< $constraint->methods >>
  
  Returns the array reference of required methods provided to the
  constructor.
  
  =item B<< $constraint->create_child_type >>
  
  This returns a new L<Moose::Meta::TypeConstraint> object with the type
  as its parent.
  
  Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType>
  object!
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_DUCKTYPE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Enum.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_ENUM';
  package Moose::Meta::TypeConstraint::Enum;
  BEGIN {
    $Moose::Meta::TypeConstraint::Enum::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Enum::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use B;
  use Moose::Util::TypeConstraints ();
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('values' => (
      accessor => 'values',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('_inline_var_name' => (
      accessor => '_inline_var_name',
      Class::MOP::_definition_context(),
  ));
  
  my $inliner = sub {
      my $self = shift;
      my $val  = shift;
  
      return 'defined(' . $val . ') '
               . '&& !ref(' . $val . ') '
               . '&& $' . $self->_inline_var_name . '{' . $val . '}';
  };
  
  my $var_suffix = 0;
  
  sub new {
      my ( $class, %args ) = @_;
  
      $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str');
      $args{inlined} = $inliner;
  
      if ( scalar @{ $args{values} } < 1 ) {
          require Moose;
          Moose->throw_error("You must have at least one value to enumerate through");
      }
  
      for (@{ $args{values} }) {
          if (!defined($_)) {
              require Moose;
              Moose->throw_error("Enum values must be strings, not undef");
          }
          elsif (ref($_)) {
              require Moose;
              Moose->throw_error("Enum values must be strings, not '$_'");
          }
      }
  
      my %values = map { $_ => 1 } @{ $args{values} };
      $args{constraint} = sub { $values{ $_[0] } };
  
      my $var_name = 'enums' . $var_suffix++;;
      $args{_inline_var_name} = $var_name;
      $args{inline_environment} = { '%' . $var_name => \%values };
  
      my $self = $class->SUPER::new(\%args);
  
      $self->compile_type_constraint()
          unless $self->_has_compiled_type_constraint;
  
      return $self;
  }
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      return unless $other->isa(__PACKAGE__);
  
      my @self_values  = sort @{ $self->values };
      my @other_values = sort @{ $other->values };
  
      return unless @self_values == @other_values;
  
      while ( @self_values ) {
          my $value = shift @self_values;
          my $other_value = shift @other_values;
  
          return unless $value eq $other_value;
      }
  
      return 1;
  }
  
  sub constraint {
      my $self = shift;
  
      my %values = map { $_ => undef } @{ $self->values };
  
      return sub { exists $values{$_[0]} };
  }
  
  sub create_child_type {
      my ($self, @args) = @_;
      return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  }
  
  1;
  
  # ABSTRACT: Type constraint for enumerated values.
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values.
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents type constraints based on an enumerated list of
  acceptable values.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Enum> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::Enum->new(%options) >>
  
  This creates a new enum type constraint based on the given
  C<%options>.
  
  It takes the same options as its parent, with several
  exceptions. First, it requires an additional option, C<values>. This
  should be an array reference containing a list of valid string
  values. Second, it automatically sets the parent to the C<Str> type.
  
  Finally, it ignores any provided C<constraint> option. The constraint
  is generated automatically based on the provided C<values>.
  
  =item B<< $constraint->values >>
  
  Returns the array reference of acceptable values provided to the
  constructor.
  
  =item B<< $constraint->create_child_type >>
  
  This returns a new L<Moose::Meta::TypeConstraint> object with the type
  as its parent.
  
  Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Enum>
  object!
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_ENUM

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Parameterizable.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_PARAMETERIZABLE';
  package Moose::Meta::TypeConstraint::Parameterizable;
  BEGIN {
    $Moose::Meta::TypeConstraint::Parameterizable::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Parameterizable::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use base 'Moose::Meta::TypeConstraint';
  use Moose::Meta::TypeConstraint::Parameterized;
  use Moose::Util::TypeConstraints ();
  
  use Carp 'confess';
  
  __PACKAGE__->meta->add_attribute('constraint_generator' => (
      accessor  => 'constraint_generator',
      predicate => 'has_constraint_generator',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('inline_generator' => (
      accessor  => 'inline_generator',
      predicate => 'has_inline_generator',
      Class::MOP::_definition_context(),
  ));
  
  sub generate_constraint_for {
      my ($self, $type) = @_;
  
      return unless $self->has_constraint_generator;
  
      return $self->constraint_generator->($type->type_parameter)
          if $type->is_subtype_of($self->name);
  
      return $self->_can_coerce_constraint_from($type)
          if $self->has_coercion
          && $self->coercion->has_coercion_for_type($type->parent->name);
  
      return;
  }
  
  sub _can_coerce_constraint_from {
      my ($self, $type) = @_;
      my $coercion   = $self->coercion;
      my $constraint = $self->constraint_generator->($type->type_parameter);
      return sub {
          local $_ = $coercion->coerce($_);
          $constraint->(@_);
      };
  }
  
  sub generate_inline_for {
      my ($self, $type, $val) = @_;
  
      confess "Can't generate an inline constraint for $type, since none "
            . "was defined"
          unless $self->has_inline_generator;
  
      return '( do { ' . $self->inline_generator->( $self, $type, $val ) . ' } )';
  }
  
  sub _parse_type_parameter {
      my ($self, $type_parameter) = @_;
      return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter);
  }
  
  sub parameterize {
      my ($self, $type_parameter) = @_;
  
      my $contained_tc = $self->_parse_type_parameter($type_parameter);
  
      ## The type parameter should be a subtype of the parent's type parameter
      ## if there is one.
  
      if(my $parent = $self->parent) {
          if($parent->can('type_parameter')) {
              unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) {
                  require Moose;
                  Moose->throw_error("$type_parameter is not a subtype of ".$parent->type_parameter);
              }
          }
      }
  
      if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) {
          my $tc_name = $self->name . '[' . $contained_tc->name . ']';
          return Moose::Meta::TypeConstraint::Parameterized->new(
              name               => $tc_name,
              parent             => $self,
              type_parameter     => $contained_tc,
              parameterized_from => $self,
          );
      }
      else {
          require Moose;
          Moose->throw_error("The type parameter must be a Moose meta type");
      }
  }
  
  
  1;
  
  # ABSTRACT: Type constraints which can take a parameter (ArrayRef)
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Parameterizable - Type constraints which can take a parameter (ArrayRef)
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents a parameterizable type constraint. This is a
  type constraint like C<ArrayRef> or C<HashRef>, that can be
  parameterized and made more specific by specifying a contained
  type. For example, instead of just an C<ArrayRef> of anything, you can
  specify that is an C<ArrayRef[Int]>.
  
  A parameterizable constraint should not be used as an attribute type
  constraint. Instead, when parameterized it creates a
  L<Moose::Meta::TypeConstraint::Parameterized> which should be used.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Parameterizable> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 METHODS
  
  This class is intentionally not documented because the API is
  confusing and needs some work.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_PARAMETERIZABLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Parameterized.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_PARAMETERIZED';
  package Moose::Meta::TypeConstraint::Parameterized;
  BEGIN {
    $Moose::Meta::TypeConstraint::Parameterized::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Parameterized::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util 'blessed';
  use Moose::Util::TypeConstraints;
  use Moose::Meta::TypeConstraint::Parameterizable;
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('type_parameter' => (
      accessor  => 'type_parameter',
      predicate => 'has_type_parameter',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('parameterized_from' => (
      accessor   => 'parameterized_from',
      predicate  => 'has_parameterized_from',
      Class::MOP::_definition_context(),
  ));
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      return unless $other->isa(__PACKAGE__);
  
      return (
          $self->type_parameter->equals( $other->type_parameter )
              and
          $self->parent->equals( $other->parent )
      );
  }
  
  sub compile_type_constraint {
      my $self = shift;
  
      unless ( $self->has_type_parameter ) {
          require Moose;
          Moose->throw_error("You cannot create a Higher Order type without a type parameter");
      }
  
      my $type_parameter = $self->type_parameter;
  
      unless ( blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint') ) {
          require Moose;
          Moose->throw_error("The type parameter must be a Moose meta type");
      }
  
      foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) {
          if (my $constraint = $type->generate_constraint_for($self)) {
              $self->_set_constraint($constraint);
              return $self->SUPER::compile_type_constraint;
          }
      }
  
      # if we get here, then we couldn't
      # find a way to parameterize this type
      require Moose;
      Moose->throw_error("The " . $self->name . " constraint cannot be used, because "
            . $self->parent->name . " doesn't subtype or coerce from a parameterizable type.");
  }
  
  sub can_be_inlined {
      my $self = shift;
  
      return
             $self->has_parameterized_from
          && $self->parameterized_from->has_inline_generator
          && $self->type_parameter->can_be_inlined;
  }
  
  sub inline_environment {
      my $self = shift;
  
      return {
          ($self->has_parameterized_from
              ? (%{ $self->parameterized_from->inline_environment })
              : ()),
          ($self->has_type_parameter
              ? (%{ $self->type_parameter->inline_environment })
              : ()),
      };
  }
  
  sub _inline_check {
      my $self = shift;
  
      return unless $self->can_be_inlined;
  
      return $self->parameterized_from->generate_inline_for( $self->type_parameter, @_ );
  }
  
  sub create_child_type {
      my ($self, %opts) = @_;
      return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self);
  }
  
  1;
  
  # ABSTRACT: Type constraints with a bound parameter (ArrayRef[Int])
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Parameterized - Type constraints with a bound parameter (ArrayRef[Int])
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 METHODS
  
  This class is intentionally not documented because the API is
  confusing and needs some work.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Parameterized> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_PARAMETERIZED

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Registry.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_REGISTRY';
  
  package Moose::Meta::TypeConstraint::Registry;
  BEGIN {
    $Moose::Meta::TypeConstraint::Registry::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Registry::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Scalar::Util 'blessed';
  
  use base 'Class::MOP::Object';
  
  __PACKAGE__->meta->add_attribute('parent_registry' => (
      reader    => 'get_parent_registry',
      writer    => 'set_parent_registry',
      predicate => 'has_parent_registry',
      Class::MOP::_definition_context(),
  ));
  
  __PACKAGE__->meta->add_attribute('type_constraints' => (
      reader  => 'type_constraints',
      default => sub { {} },
      Class::MOP::_definition_context(),
  ));
  
  sub new {
      my $class = shift;
      my $self  = $class->_new(@_);
      return $self;
  }
  
  sub has_type_constraint {
      my ($self, $type_name) = @_;
      ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0
  }
  
  sub get_type_constraint {
      my ($self, $type_name) = @_;
      return unless defined $type_name;
      $self->type_constraints->{$type_name}
  }
  
  sub add_type_constraint {
      my ($self, $type) = @_;
  
      unless ( $type && blessed $type && $type->isa('Moose::Meta::TypeConstraint') ) {
          require Moose;
          Moose->throw_error("No type supplied / type is not a valid type constraint");
      }
  
      $self->type_constraints->{$type->name} = $type;
  }
  
  sub find_type_constraint {
      my ($self, $type_name) = @_;
      return $self->get_type_constraint($type_name)
          if $self->has_type_constraint($type_name);
      return $self->get_parent_registry->find_type_constraint($type_name)
          if $self->has_parent_registry;
      return;
  }
  
  1;
  
  # ABSTRACT: registry for type constraints
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Registry - registry for type constraints
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is a registry that maps type constraint names to
  L<Moose::Meta::TypeConstraint> objects.
  
  Currently, it is only used internally by
  L<Moose::Util::TypeConstraints>, which creates a single global
  registry.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Registry> is a subclass of
  L<Class::MOP::Object>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::Registry->new(%options) >>
  
  This creates a new registry object based on the provided C<%options>:
  
  =over 8
  
  =item * parent_registry
  
  This is an optional L<Moose::Meta::TypeConstraint::Registry>
  object.
  
  =item * type_constraints
  
  This is hash reference of type names to type objects. This is
  optional. Constraints can be added to the registry after it is
  created.
  
  =back
  
  =item B<< $registry->get_parent_registry >>
  
  Returns the registry's parent registry, if it has one.
  
  =item B<< $registry->has_parent_registry >>
  
  Returns true if the registry has a parent.
  
  =item B<< $registry->set_parent_registry($registry) >>
  
  Sets the parent registry.
  
  =item B<< $registry->get_type_constraint($type_name) >>
  
  This returns the L<Moose::Meta::TypeConstraint> object from the
  registry for the given name, if one exists.
  
  =item B<< $registry->has_type_constraint($type_name) >>
  
  Returns true if the registry has a type of the given name.
  
  =item B<< $registry->add_type_constraint($type) >>
  
  Adds a new L<Moose::Meta::TypeConstraint> object to the registry.
  
  =item B<< $registry->find_type_constraint($type_name) >>
  
  This method looks in the current registry for the named type. If the
  type is not found, then this method will look in the registry's
  parent, if it has one.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_REGISTRY

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Role.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_ROLE';
  package Moose::Meta::TypeConstraint::Role;
  BEGIN {
    $Moose::Meta::TypeConstraint::Role::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Role::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use B;
  use Scalar::Util 'blessed';
  use Moose::Util::TypeConstraints ();
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('role' => (
      reader => 'role',
      Class::MOP::_definition_context(),
  ));
  
  my $inliner = sub {
      my $self = shift;
      my $val  = shift;
  
      return 'Moose::Util::does_role('
               . $val . ', '
               . B::perlstring($self->role)
           . ')';
  };
  
  sub new {
      my ( $class, %args ) = @_;
  
      $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
  
      my $role_name = $args{role};
      $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) };
  
      $args{inlined} = $inliner;
  
      my $self = $class->SUPER::new( \%args );
  
      $self->_create_hand_optimized_type_constraint;
      $self->compile_type_constraint();
  
      return $self;
  }
  
  sub _create_hand_optimized_type_constraint {
      my $self = shift;
      my $role = $self->role;
      $self->hand_optimized_type_constraint(
          sub { Moose::Util::does_role($_[0], $role) }
      );
  }
  
  sub parents {
      my $self = shift;
      return (
          $self->parent,
          map {
              # FIXME find_type_constraint might find a TC named after the role but that isn't really it
              # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM
              # if anybody thinks this problematic please discuss on IRC.
              # a possible fix is to add by attr indexing to the type registry to find types of a certain property
              # regardless of their name
              Moose::Util::TypeConstraints::find_type_constraint($_)
                  ||
              __PACKAGE__->new( role => $_, name => "__ANON__" )
          } @{ Class::MOP::class_of($self->role)->get_roles },
      );
  }
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      return unless defined $other;
      return unless $other->isa(__PACKAGE__);
  
      return $self->role eq $other->role;
  }
  
  sub is_a_type_of {
      my ($self, $type_or_name) = @_;
  
      my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      ($self->equals($type) || $self->is_subtype_of($type_or_name));
  }
  
  sub is_subtype_of {
      my ($self, $type_or_name_or_role ) = @_;
  
      if ( not ref $type_or_name_or_role ) {
          # it might be a role
          return 1 if Class::MOP::class_of($self->role)->does_role( $type_or_name_or_role );
      }
  
      my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
  
      return unless defined $type;
  
      if ( $type->isa(__PACKAGE__) ) {
          # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
          # or it could also just be a type object in this branch
          return Class::MOP::class_of($self->role)->does_role( $type->role );
      } else {
          # the only other thing we are a subtype of is Object
          $self->SUPER::is_subtype_of($type);
      }
  }
  
  sub create_child_type {
      my ($self, @args) = @_;
      return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  }
  
  1;
  
  # ABSTRACT: Role/TypeConstraint parallel hierarchy
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class represents type constraints for a role.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Role> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::Role->new(%options) >>
  
  This creates a new role type constraint based on the given
  C<%options>.
  
  It takes the same options as its parent, with two exceptions. First,
  it requires an additional option, C<role>, which is name of the
  constraint's role.  Second, it automatically sets the parent to the
  C<Object> type.
  
  The constructor also overrides the hand optimized type constraint with
  one it creates internally.
  
  =item B<< $constraint->role >>
  
  Returns the role name associated with the constraint.
  
  =item B<< $constraint->parents >>
  
  Returns all the type's parent types, corresponding to the roles that
  its role does.
  
  =item B<< $constraint->is_subtype_of($type_name_or_object) >>
  
  If the given type is also a role type, then this checks that the
  type's role does the other type's role.
  
  Otherwise it falls back to the implementation in
  L<Moose::Meta::TypeConstraint>.
  
  =item B<< $constraint->create_child_type(%options) >>
  
  This returns a new L<Moose::Meta::TypeConstraint> object with the type
  as its parent.
  
  Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role>
  object!
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_ROLE

$fatpacked{"darwin-thread-multi-2level/Moose/Meta/TypeConstraint/Union.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_UNION';
  
  package Moose::Meta::TypeConstraint::Union;
  BEGIN {
    $Moose::Meta::TypeConstraint::Union::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Meta::TypeConstraint::Union::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use metaclass;
  
  use Moose::Meta::TypeCoercion::Union;
  
  use List::MoreUtils qw(all);
  use List::Util qw(first);
  
  use base 'Moose::Meta::TypeConstraint';
  
  __PACKAGE__->meta->add_attribute('type_constraints' => (
      accessor  => 'type_constraints',
      default   => sub { [] },
      Class::MOP::_definition_context(),
  ));
  
  sub new {
      my ($class, %options) = @_;
  
      my $name = join '|' => sort { $a cmp $b }
          map { $_->name } @{ $options{type_constraints} };
  
      my $self = $class->SUPER::new(
          name => $name,
          %options,
      );
  
      $self->_set_constraint(sub { $self->check($_[0]) });
  
      return $self;
  }
  
  # XXX - this is a rather gross implementation of laziness for the benefit of
  # MX::Types. If we try to call ->has_coercion on the objects during object
  # construction, this does not work when defining a recursive constraint with
  # MX::Types.
  sub coercion {
      my $self = shift;
  
      return $self->{coercion} if exists $self->{coercion};
  
      # Using any instead of grep here causes a weird error with some corner
      # cases when MX::Types is in use. See RT #61001.
      if ( grep { $_->has_coercion } @{ $self->type_constraints } ) {
          return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new(
              type_constraint => $self );
      }
      else {
          return $self->{coercion} = undef;
      }
  }
  
  sub has_coercion {
      return defined $_[0]->coercion;
  }
  
  sub _actually_compile_type_constraint {
      my $self = shift;
  
      my @constraints = @{ $self->type_constraints };
  
      return sub {
          my $value = shift;
          foreach my $type (@constraints) {
              return 1 if $type->check($value);
          }
          return undef;
      };
  }
  
  sub can_be_inlined {
      my $self = shift;
  
      # This was originally done with all() from List::MoreUtils, but that
      # caused some sort of bizarro parsing failure under 5.10.
      for my $tc ( @{ $self->type_constraints } ) {
          return 0 unless $tc->can_be_inlined;
      }
  
      return 1;
  }
  
  sub _inline_check {
      my $self = shift;
      my $val  = shift;
  
      return '('
                 . (
                    join ' || ', map { '(' . $_->_inline_check($val) . ')' }
                    @{ $self->type_constraints }
                   )
             . ')';
  }
  
  sub inline_environment {
      my $self = shift;
  
      return { map { %{ $_->inline_environment } }
              @{ $self->type_constraints } };
  }
  
  sub equals {
      my ( $self, $type_or_name ) = @_;
  
      my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  
      return unless $other->isa(__PACKAGE__);
  
      my @self_constraints  = @{ $self->type_constraints };
      my @other_constraints = @{ $other->type_constraints };
  
      return unless @self_constraints == @other_constraints;
  
      # FIXME presort type constraints for efficiency?
      constraint: foreach my $constraint ( @self_constraints ) {
          for ( my $i = 0; $i < @other_constraints; $i++ ) {
              if ( $constraint->equals($other_constraints[$i]) ) {
                  splice @other_constraints, $i, 1;
                  next constraint;
              }
          }
      }
  
      return @other_constraints == 0;
  }
  
  sub parent {
      my $self = shift;
  
      my ($first, @rest) = @{ $self->type_constraints };
  
      for my $parent ( $first->_collect_all_parents ) {
          return $parent if all { $_->is_a_type_of($parent) } @rest;
      }
  
      return;
  }
  
  sub validate {
      my ($self, $value) = @_;
      my $message;
      foreach my $type (@{$self->type_constraints}) {
          my $err = $type->validate($value);
          return unless defined $err;
          $message .= ($message ? ' and ' : '') . $err
              if defined $err;
      }
      return ($message . ' in (' . $self->name . ')') ;
  }
  
  sub find_type_for {
      my ($self, $value) = @_;
  
      return first { $_->check($value) } @{ $self->type_constraints };
  }
  
  sub is_a_type_of {
      my ($self, $type_name) = @_;
  
      return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints };
  }
  
  sub is_subtype_of {
      my ($self, $type_name) = @_;
  
      return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints };
  }
  
  sub create_child_type {
      my ( $self, %opts ) = @_;
  
      my $constraint
          = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
  
      # if we have a type constraint union, and no
      # type check, this means we are just aliasing
      # the union constraint, which means we need to
      # handle this differently.
      # - SL
      if ( not( defined $opts{constraint} )
          && $self->has_coercion ) {
          $constraint->coercion(
              Moose::Meta::TypeCoercion::Union->new(
                  type_constraint => $self,
              )
          );
      }
  
      return $constraint;
  }
  
  1;
  
  # ABSTRACT: A union of Moose type constraints
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This metaclass represents a union of type constraints. A union takes
  multiple type constraints, and is true if any one of its member
  constraints is true.
  
  =head1 INHERITANCE
  
  C<Moose::Meta::TypeConstraint::Union> is a subclass of
  L<Moose::Meta::TypeConstraint>.
  
  =over 4
  
  =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
  
  This creates a new class type constraint based on the given
  C<%options>.
  
  It takes the same options as its parent. It also requires an
  additional option, C<type_constraints>. This is an array reference
  containing the L<Moose::Meta::TypeConstraint> objects that are the
  members of the union type. The C<name> option defaults to the names
  all of these member types sorted and then joined by a pipe (|).
  
  The constructor sets the implementation of the constraint so that is
  simply calls C<check> on the newly created object.
  
  Finally, the constructor also makes sure that the object's C<coercion>
  attribute is a L<Moose::Meta::TypeCoercion::Union> object.
  
  =item B<< $constraint->type_constraints >>
  
  This returns the array reference of C<type_constraints> provided to
  the constructor.
  
  =item B<< $constraint->parent >>
  
  This returns the nearest common ancestor of all the components of the union.
  
  =item B<< $constraint->check($value) >>
  
  =item B<< $constraint->validate($value) >>
  
  These two methods simply call the relevant method on each of the
  member type constraints in the union. If any type accepts the value,
  the value is valid.
  
  With C<validate> the error message returned includes all of the error
  messages returned by the member type constraints.
  
  =item B<< $constraint->equals($type_name_or_object) >>
  
  A type is considered equal if it is also a union type, and the two
  unions have the same member types.
  
  =item B<< $constraint->find_type_for($value) >>
  
  This returns the first member type constraint for which C<check($value)> is
  true, allowing you to determine which of the Union's member type constraints
  a given value matches.
  
  =item B<< $constraint->is_a_type_of($type_name_or_object) >>
  
  This returns true if all of the member type constraints return true
  for the C<is_a_type_of> method.
  
  =item B<< $constraint->is_subtype_of >>
  
  This returns true if all of the member type constraints return true
  for the C<is_a_subtype_of> method.
  
  =item B<< $constraint->create_child_type(%options) >>
  
  This returns a new L<Moose::Meta::TypeConstraint> object with the type
  as its parent.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_META_TYPECONSTRAINT_UNION

$fatpacked{"darwin-thread-multi-2level/Moose/Object.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_OBJECT';
  
  package Moose::Object;
  BEGIN {
    $Moose::Object::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Object::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp ();
  use Devel::GlobalDestruction ();
  use MRO::Compat ();
  use Scalar::Util ();
  use Try::Tiny ();
  
  use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
  use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
  
  sub new {
      my $class = shift;
      my $real_class = Scalar::Util::blessed($class) || $class;
  
      my $params = $real_class->BUILDARGS(@_);
  
      return Class::MOP::Class->initialize($real_class)->new_object($params);
  }
  
  sub BUILDARGS {
      my $class = shift;
      if ( scalar @_ == 1 ) {
          unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
              Class::MOP::class_of($class)->throw_error(
                  "Single parameters to new() must be a HASH ref",
                  data => $_[0] );
          }
          return { %{ $_[0] } };
      }
      elsif ( @_ % 2 ) {
          Carp::carp(
              "The new() method for $class expects a hash reference or a key/value list."
                  . " You passed an odd number of arguments" );
          return { @_, undef };
      }
      else {
          return {@_};
      }
  }
  
  sub BUILDALL {
      # NOTE: we ask Perl if we even
      # need to do this first, to avoid
      # extra meta level calls
      return unless $_[0]->can('BUILD');
      my ($self, $params) = @_;
      foreach my $method (reverse Class::MOP::class_of($self)->find_all_methods_by_name('BUILD')) {
          $method->{code}->execute($self, $params);
      }
  }
  
  sub DEMOLISHALL {
      my $self = shift;
      my ($in_global_destruction) = @_;
  
      # NOTE: we ask Perl if we even
      # need to do this first, to avoid
      # extra meta level calls
      return unless $self->can('DEMOLISH');
  
      my @isa;
      if ( my $meta = Class::MOP::class_of($self ) ) {
          @isa = $meta->linearized_isa;
      } else {
          # We cannot count on being able to retrieve a previously made
          # metaclass, _or_ being able to make a new one during global
          # destruction. However, we should still be able to use mro at
          # that time (at least tests suggest so ;)
          my $class_name = ref $self;
          @isa = @{ mro::get_linear_isa($class_name) }
      }
  
      foreach my $class (@isa) {
          no strict 'refs';
          my $demolish = *{"${class}::DEMOLISH"}{CODE};
          $self->$demolish($in_global_destruction)
              if defined $demolish;
      }
  }
  
  sub DESTROY {
      my $self = shift;
  
      local $?;
  
      Try::Tiny::try {
          $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction);
      }
      Try::Tiny::catch {
          die $_;
      };
  
      return;
  }
  
  # support for UNIVERSAL::DOES ...
  BEGIN {
      my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa";
      eval 'sub DOES {
          my ( $self, $class_or_role_name ) = @_;
          return $self->'.$does.'($class_or_role_name)
              || $self->does($class_or_role_name);
      }';
  }
  
  # new does() methods will be created
  # as appropiate see Moose::Meta::Role
  sub does {
      my ($self, $role_name) = @_;
      my $class = Scalar::Util::blessed($self) || $self;
      my $meta = Class::MOP::Class->initialize($class);
      (defined $role_name)
          || $meta->throw_error("You must supply a role name to does()");
      return 1 if $meta->can('does_role') && $meta->does_role($role_name);
      return 0;
  }
  
  sub dump {
      my $self = shift;
      require Data::Dumper;
      local $Data::Dumper::Maxdepth = shift if @_;
      Data::Dumper::Dumper $self;
  }
  
  1;
  
  # ABSTRACT: The base object for Moose
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Object - The base object for Moose
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 DESCRIPTION
  
  This class is the default base class for all Moose-using classes. When
  you C<use Moose> in this class, your class will inherit from this
  class.
  
  It provides a default constructor and destructor, which run all of the
  C<BUILD> and C<DEMOLISH> methods in the inheritance hierarchy,
  respectively.
  
  You don't actually I<need> to inherit from this in order to use Moose,
  but it makes it easier to take advantage of all of Moose's features.
  
  =head1 METHODS
  
  =over 4
  
  =item B<< Moose::Object->new(%params|$params) >>
  
  This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new
  instance of the appropriate class. Once the instance is created, it
  calls C<< $instance->BUILD($params) >> for each C<BUILD> method in the
  inheritance hierarchy.
  
  =item B<< Moose::Object->BUILDARGS(%params|$params) >>
  
  The default implementation of this method accepts a hash or hash
  reference of named parameters. If it receives a single argument that
  I<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.
  
  =item B<< $object->does($role_name) >>
  
  This returns true if the object does the given role.
  
  =item B<< $object->DOES($class_or_role_name) >>
  
  This is a a Moose role-aware implementation of L<UNIVERSAL/DOES>.
  
  This is effectively the same as writing:
  
    $object->does($name) || $object->isa($name)
  
  This method will work with Perl 5.8, which did not implement
  C<UNIVERSAL::DOES>.
  
  =item B<< $object->dump($maxdepth) >>
  
  This is a handy utility for C<Data::Dumper>ing an object. By default,
  the maximum depth is 1, to avoid making a mess.
  
  =item B<< $object->DESTROY >>
  
  A default destructor is provided, which calls
  C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
  method in the inheritance hierarchy.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_OBJECT

$fatpacked{"darwin-thread-multi-2level/Moose/Role.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ROLE';
  package Moose::Role;
  BEGIN {
    $Moose::Role::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Role::VERSION = '2.0401';
  }
  use strict;
  use warnings;
  
  use Scalar::Util 'blessed';
  use Carp         'croak';
  use Class::Load  'is_class_loaded';
  
  use Sub::Exporter;
  
  use Moose       ();
  use Moose::Util ();
  
  use Moose::Exporter;
  use Moose::Meta::Role;
  use Moose::Util::TypeConstraints;
  
  sub extends {
      croak "Roles do not support 'extends' (you can use 'with' to specialize a role)";
  }
  
  sub with {
      Moose::Util::apply_all_roles( shift, @_ );
  }
  
  sub requires {
      my $meta = shift;
      croak "Must specify at least one method" unless @_;
      $meta->add_required_methods(@_);
  }
  
  sub excludes {
      my $meta = shift;
      croak "Must specify at least one role" unless @_;
      $meta->add_excluded_roles(@_);
  }
  
  sub has {
      my $meta = shift;
      my $name = shift;
      croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
      my %options = ( definition_context => Moose::Util::_caller_info(), @_ );
      my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
      $meta->add_attribute( $_, %options ) for @$attrs;
  }
  
  sub _add_method_modifier {
      my $type = shift;
      my $meta = shift;
  
      if ( ref($_[0]) eq 'Regexp' ) {
          croak "Roles do not currently support regex "
              . " references for $type method modifiers";
      }
  
      Moose::Util::add_method_modifier($meta, $type, \@_);
  }
  
  sub before { _add_method_modifier('before', @_) }
  
  sub after  { _add_method_modifier('after',  @_) }
  
  sub around { _add_method_modifier('around', @_) }
  
  # see Moose.pm for discussion
  sub super {
      return unless $Moose::SUPER_BODY;
      $Moose::SUPER_BODY->(@Moose::SUPER_ARGS);
  }
  
  sub override {
      my $meta = shift;
      my ( $name, $code ) = @_;
      $meta->add_override_method_modifier( $name, $code );
  }
  
  sub inner {
      croak "Roles cannot support 'inner'";
  }
  
  sub augment {
      croak "Roles cannot support 'augment'";
  }
  
  Moose::Exporter->setup_import_methods(
      with_meta => [
          qw( with requires excludes has before after around override )
      ],
      as_is => [
          qw( extends super inner augment ),
          \&Carp::confess,
          \&Scalar::Util::blessed,
      ],
  );
  
  sub init_meta {
      shift;
      my %args = @_;
  
      my $role = $args{for_class};
  
      unless ($role) {
          require Moose;
          Moose->throw_error("Cannot call init_meta without specifying a for_class");
      }
  
      my $metaclass = $args{metaclass} || "Moose::Meta::Role";
      my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta';
  
      Moose->throw_error("The Metaclass $metaclass must be loaded. (Perhaps you forgot to 'use $metaclass'?)")
          unless is_class_loaded($metaclass);
  
      Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Role.")
          unless $metaclass->isa('Moose::Meta::Role');
  
      # make a subtype for each Moose role
      role_type $role unless find_type_constraint($role);
  
      my $meta;
      if ( $meta = Class::MOP::get_metaclass_by_name($role) ) {
          unless ( $meta->isa("Moose::Meta::Role") ) {
              my $error_message = "$role already has a metaclass, but it does not inherit $metaclass ($meta).";
              if ( $meta->isa('Moose::Meta::Class') ) {
                  Moose->throw_error($error_message . ' You cannot make the same thing a role and a class. Remove either Moose or Moose::Role.');
              } else {
                  Moose->throw_error($error_message);
              }
          }
      }
      else {
          $meta = $metaclass->initialize($role);
      }
  
      if (defined $meta_name) {
          # also check for inherited non moose 'meta' method?
          my $existing = $meta->get_method($meta_name);
          if ($existing && !$existing->isa('Class::MOP::Method::Meta')) {
              Carp::cluck "Moose::Role is overwriting an existing method named "
                        . "$meta_name in role $role with a method "
                        . "which returns the class's metaclass. If this is "
                        . "actually what you want, you should remove the "
                        . "existing method, otherwise, you should rename or "
                        . "disable this generated method using the "
                        . "'-meta_name' option to 'use Moose::Role'.";
          }
          $meta->_add_meta_method($meta_name);
      }
  
      return $meta;
  }
  
  1;
  
  # ABSTRACT: The Moose Role
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Role - The Moose Role
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package Eq;
    use Moose::Role; # automatically turns on strict and warnings
  
    requires 'equal';
  
    sub no_equal {
        my ($self, $other) = @_;
        !$self->equal($other);
    }
  
    # ... then in your classes
  
    package Currency;
    use Moose; # automatically turns on strict and warnings
  
    with 'Eq';
  
    sub equal {
        my ($self, $other) = @_;
        $self->as_float == $other->as_float;
    }
  
    # ... and also
  
    package Comparator;
    use Moose;
  
    has compare_to => (
        is      => 'ro',
        does    => 'Eq',
        handles => 'Eq',
    );
  
    # ... which allows
  
    my $currency1 = Currency->new(...);
    my $currency2 = Currency->new(...);
    Comparator->new(compare_to => $currency1)->equal($currency2);
  
  =head1 DESCRIPTION
  
  The concept of roles is documented in L<Moose::Manual::Roles>. This document
  serves as API documentation.
  
  =head1 EXPORTED FUNCTIONS
  
  Moose::Role currently supports all of the functions that L<Moose> exports, but
  differs slightly in how some items are handled (see L</CAVEATS> below for
  details).
  
  Moose::Role also offers two role-specific keyword exports:
  
  =over 4
  
  =item B<requires (@method_names)>
  
  Roles can require that certain methods are implemented by any class which
  C<does> the role.
  
  Note that attribute accessors also count as methods for the purposes
  of satisfying the requirements of a role.
  
  =item B<excludes (@role_names)>
  
  Roles can C<exclude> other roles, in effect saying "I can never be combined
  with these C<@role_names>". This is a feature which should not be used
  lightly.
  
  =back
  
  =head2 B<unimport>
  
  Moose::Role offers a way to remove the keywords it exports, through the
  C<unimport> method. You simply have to say C<no Moose::Role> at the bottom of
  your code for this to work.
  
  =head1 METACLASS
  
  When you use Moose::Role, you can specify traits which will be applied to your
  role metaclass:
  
      use Moose::Role -traits => 'My::Trait';
  
  This is very similar to the attribute traits feature. When you do
  this, your class's C<meta> object will have the specified traits
  applied to it. See L<Moose/Metaclass and Trait Name Resolution> for more
  details.
  
  =head1 APPLYING ROLES
  
  In addition to being applied to a class using the 'with' syntax (see
  L<Moose::Manual::Roles>) and using the L<Moose::Util> 'apply_all_roles'
  method, roles may also be applied to an instance of a class using
  L<Moose::Util> 'apply_all_roles' or the role's metaclass:
  
     MyApp::Test::SomeRole->meta->apply( $instance );
  
  Doing this creates a new, mutable, anonymous subclass, applies the role to that,
  and reblesses. In a debugger, for example, you will see class names of the
  form C< Moose::Meta::Class::__ANON__::SERIAL::6 >, which means that doing a
  'ref' on your instance may not return what you expect. See L<Moose::Object> for
  'DOES'.
  
  Additional params may be added to the new instance by providing
  'rebless_params'. See L<Moose::Meta::Role::Application::ToInstance>.
  
  =head1 CAVEATS
  
  Role support has only a few caveats:
  
  =over 4
  
  =item *
  
  Roles cannot use the C<extends> keyword; it will throw an exception for now.
  The same is true of the C<augment> and C<inner> keywords (not sure those
  really make sense for roles). All other Moose keywords will be I<deferred>
  so that they can be applied to the consuming class.
  
  =item *
  
  Role composition does its best to B<not> be order-sensitive when it comes to
  conflict resolution and requirements detection. However, it is order-sensitive
  when it comes to method modifiers. All before/around/after modifiers are
  included whenever a role is composed into a class, and then applied in the order
  in which the roles are used. This also means that there is no conflict for
  before/around/after modifiers.
  
  In most cases, this will be a non-issue; however, it is something to keep in
  mind when using method modifiers in a role. You should never assume any
  ordering.
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_ROLE

$fatpacked{"darwin-thread-multi-2level/Moose/Util.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL';
  package Moose::Util;
  BEGIN {
    $Moose::Util::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Util::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw(load_class load_first_existing_class);
  use Data::OptList;
  use Params::Util qw( _STRING );
  use Sub::Exporter;
  use Scalar::Util 'blessed';
  use List::Util qw(first);
  use List::MoreUtils qw(any all);
  use overload ();
  use Try::Tiny;
  use Class::MOP;
  
  my @exports = qw[
      find_meta
      does_role
      search_class_by_role
      ensure_all_roles
      apply_all_roles
      with_traits
      get_all_init_args
      get_all_attribute_values
      resolve_metatrait_alias
      resolve_metaclass_alias
      add_method_modifier
      english_list
      meta_attribute_alias
      meta_class_alias
  ];
  
  Sub::Exporter::setup_exporter({
      exports => \@exports,
      groups  => { all => \@exports }
  });
  
  ## some utils for the utils ...
  
  sub find_meta { Class::MOP::class_of(@_) }
  
  ## the functions ...
  
  sub does_role {
      my ($class_or_obj, $role) = @_;
  
      if (try { $class_or_obj->isa('Moose::Object') }) {
          return $class_or_obj->does($role);
      }
  
      my $meta = find_meta($class_or_obj);
  
      return unless defined $meta;
      return unless $meta->can('does_role');
      return 1 if $meta->does_role($role);
      return;
  }
  
  sub search_class_by_role {
      my ($class_or_obj, $role) = @_;
  
      my $meta = find_meta($class_or_obj);
  
      return unless defined $meta;
  
      my $role_name = blessed $role ? $role->name : $role;
  
      foreach my $class ($meta->class_precedence_list) {
  
          my $_meta = find_meta($class);
  
          next unless defined $_meta;
  
          foreach my $role (@{ $_meta->roles || [] }) {
              return $class if $role->name eq $role_name;
          }
      }
  
      return;
  }
  
  # this can possibly behave in unexpected ways because the roles being composed
  # before being applied could differ from call to call; I'm not sure if or how
  # to document this possible quirk.
  sub ensure_all_roles {
      my $applicant = shift;
      _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
  }
  
  sub apply_all_roles {
      my $applicant = shift;
      _apply_all_roles($applicant, undef, @_);
  }
  
  sub _apply_all_roles {
      my $applicant = shift;
      my $role_filter = shift;
  
      unless (@_) {
          require Moose;
          Moose->throw_error("Must specify at least one role to apply to $applicant");
      }
  
      # If @_ contains role meta objects, mkopt will think that they're values,
      # because they're references.  In other words (roleobj1, roleobj2,
      # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ]
      # -- this is no good.  We'll preprocess @_ first to eliminate the potential
      # bug.
      # -- rjbs, 2011-04-08
      my $roles = Data::OptList::mkopt( [@_], {
        moniker   => 'role',
        name_test => sub {
          ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role')
        }
      });
  
      my @role_metas;
      foreach my $role (@$roles) {
          my $meta;
  
          if ( blessed $role->[0] ) {
              $meta = $role->[0];
          }
          else {
              load_class( $role->[0] , $role->[1] );
              $meta = find_meta( $role->[0] );
          }
  
          unless ($meta && $meta->isa('Moose::Meta::Role') ) {
              require Moose;
              Moose->throw_error( "You can only consume roles, "
                      . $role->[0]
                      . " is not a Moose role" );
          }
  
          push @role_metas, [ $meta, $role->[1] ];
      }
  
      if ( defined $role_filter ) {
          @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
      }
  
      return unless @role_metas;
  
      load_class($applicant)
          unless blessed($applicant)
              || Class::MOP::class_of($applicant);
  
      my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
  
      if ( scalar @role_metas == 1 ) {
          my ( $role, $params ) = @{ $role_metas[0] };
          $role->apply( $meta, ( defined $params ? %$params : () ) );
      }
      else {
          Moose::Meta::Role->combine(@role_metas)->apply($meta);
      }
  }
  
  sub with_traits {
      my ($class, @roles) = @_;
      return $class unless @roles;
      return Moose::Meta::Class->create_anon_class(
          superclasses => [$class],
          roles        => \@roles,
          cache        => 1,
      )->name;
  }
  
  # instance deconstruction ...
  
  sub get_all_attribute_values {
      my ($class, $instance) = @_;
      return +{
          map { $_->name => $_->get_value($instance) }
              grep { $_->has_value($instance) }
                  $class->get_all_attributes
      };
  }
  
  sub get_all_init_args {
      my ($class, $instance) = @_;
      return +{
          map { $_->init_arg => $_->get_value($instance) }
              grep { $_->has_value($instance) }
                  grep { defined($_->init_arg) }
                      $class->get_all_attributes
      };
  }
  
  sub resolve_metatrait_alias {
      return resolve_metaclass_alias( @_, trait => 1 );
  }
  
  sub _build_alias_package_name {
      my ($type, $name, $trait) = @_;
      return 'Moose::Meta::'
           . $type
           . '::Custom::'
           . ( $trait ? 'Trait::' : '' )
           . $name;
  }
  
  {
      my %cache;
  
      sub resolve_metaclass_alias {
          my ( $type, $metaclass_name, %options ) = @_;
  
          my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
          return $cache{$cache_key}{$metaclass_name}
              if $cache{$cache_key}{$metaclass_name};
  
          my $possible_full_name = _build_alias_package_name(
              $type, $metaclass_name, $options{trait}
          );
  
          my $loaded_class = load_first_existing_class(
              $possible_full_name,
              $metaclass_name
          );
  
          return $cache{$cache_key}{$metaclass_name}
              = $loaded_class->can('register_implementation')
              ? $loaded_class->register_implementation
              : $loaded_class;
      }
  }
  
  sub add_method_modifier {
      my ( $class_or_obj, $modifier_name, $args ) = @_;
      my $meta
          = $class_or_obj->can('add_before_method_modifier')
          ? $class_or_obj
          : find_meta($class_or_obj);
      my $code                = pop @{$args};
      my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
      if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
          if ( $method_modifier_type eq 'Regexp' ) {
              my @all_methods = $meta->get_all_methods;
              my @matched_methods
                  = grep { $_->name =~ @{$args}[0] } @all_methods;
              $meta->$add_modifier_method( $_->name, $code )
                  for @matched_methods;
          }
          elsif ($method_modifier_type eq 'ARRAY') {
              $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
          }
          else {
              $meta->throw_error(
                  sprintf(
                      "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
                      $modifier_name,
                      $method_modifier_type,
                  )
              );
          }
      }
      else {
          $meta->$add_modifier_method( $_, $code ) for @{$args};
      }
  }
  
  sub english_list {
      my @items = sort @_;
  
      return $items[0] if @items == 1;
      return "$items[0] and $items[1]" if @items == 2;
  
      my $tail = pop @items;
      my $list = join ', ', @items;
      $list .= ', and ' . $tail;
  
      return $list;
  }
  
  sub _caller_info {
      my $level = @_ ? ($_[0] + 1) : 2;
      my %info;
      @info{qw(package file line)} = caller($level);
      return \%info;
  }
  
  sub _create_alias {
      my ($type, $name, $trait, $for) = @_;
      my $package = _build_alias_package_name($type, $name, $trait);
      Class::MOP::Class->initialize($package)->add_method(
          register_implementation => sub { $for }
      );
  }
  
  sub meta_attribute_alias {
      my ($to, $from) = @_;
      $from ||= caller;
      my $meta = Class::MOP::class_of($from);
      my $trait = $meta->isa('Moose::Meta::Role');
      _create_alias('Attribute', $to, $trait, $from);
  }
  
  sub meta_class_alias {
      my ($to, $from) = @_;
      $from ||= caller;
      my $meta = Class::MOP::class_of($from);
      my $trait = $meta->isa('Moose::Meta::Role');
      _create_alias('Class', $to, $trait, $from);
  }
  
  # XXX - this should be added to Params::Util
  sub _STRINGLIKE0 ($) {
      return _STRING( $_[0] )
          || ( defined $_[0]
          && $_[0] eq q{} )
          || ( blessed $_[0]
          && overload::Method( $_[0], q{""} )
          && length "$_[0]" );
  }
  
  sub _reconcile_roles_for_metaclass {
      my ($class_meta_name, $super_meta_name) = @_;
  
      my @role_differences = _role_differences(
          $class_meta_name, $super_meta_name,
      );
  
      # handle the case where we need to fix compatibility between a class and
      # its parent, but all roles in the class are already also done by the
      # parent
      # see t/metaclasses/metaclass_compat_no_fixing_bug.t
      return $super_meta_name
          unless @role_differences;
  
      return Moose::Meta::Class->create_anon_class(
          superclasses => [$super_meta_name],
          roles        => [map { $_->name } @role_differences],
          cache        => 1,
      )->name;
  }
  
  sub _role_differences {
      my ($class_meta_name, $super_meta_name) = @_;
      my @super_role_metas
          = grep { !$_->isa('Moose::Meta::Role::Composite') }
                 $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
                     ? $super_meta_name->meta->calculate_all_roles_with_inheritance
                     : $super_meta_name->meta->can('calculate_all_roles')
                     ? $super_meta_name->meta->calculate_all_roles
                     : ();
      my @role_metas
          = grep { !$_->isa('Moose::Meta::Role::Composite') }
                 $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
                     ? $class_meta_name->meta->calculate_all_roles_with_inheritance
                     : $class_meta_name->meta->can('calculate_all_roles')
                     ? $class_meta_name->meta->calculate_all_roles
                     : ();
      my @differences;
      for my $role_meta (@role_metas) {
          push @differences, $role_meta
              unless any { $_->name eq $role_meta->name } @super_role_metas;
      }
      return @differences;
  }
  
  sub _classes_differ_by_roles_only {
      my ( $self_meta_name, $super_meta_name ) = @_;
  
      my $common_base_name
          = _find_common_base( $self_meta_name, $super_meta_name );
  
      return unless defined $common_base_name;
  
      my @super_meta_name_ancestor_names
          = _get_ancestors_until( $super_meta_name, $common_base_name );
      my @class_meta_name_ancestor_names
          = _get_ancestors_until( $self_meta_name, $common_base_name );
  
      return
          unless all { _is_role_only_subclass($_) }
          @super_meta_name_ancestor_names,
          @class_meta_name_ancestor_names;
  
      return 1;
  }
  
  sub _find_common_base {
      my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
      return unless defined $meta1 && defined $meta2;
  
      # FIXME? This doesn't account for multiple inheritance (not sure
      # if it needs to though). For example, if somewhere in $meta1's
      # history it inherits from both ClassA and ClassB, and $meta2
      # inherits from ClassB & ClassA, does it matter? And what crazy
      # fool would do that anyway?
  
      my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
  
      return first { $meta1_parents{$_} } $meta2->linearized_isa;
  }
  
  sub _get_ancestors_until {
      my ($start_name, $until_name) = @_;
  
      my @ancestor_names;
      for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
          last if $ancestor_name eq $until_name;
          push @ancestor_names, $ancestor_name;
      }
      return @ancestor_names;
  }
  
  sub _is_role_only_subclass {
      my ($meta_name) = @_;
      my $meta = Class::MOP::Class->initialize($meta_name);
      my @parent_names = $meta->superclasses;
  
      # XXX: don't feel like messing with multiple inheritance here... what would
      # that even do?
      return unless @parent_names == 1;
      my ($parent_name) = @parent_names;
      my $parent_meta = Class::MOP::Class->initialize($parent_name);
  
      # only get the roles attached to this particular class, don't look at
      # superclasses
      my @roles = $meta->can('calculate_all_roles')
                      ? $meta->calculate_all_roles
                      : ();
  
      # it's obviously not a role-only subclass if it doesn't do any roles
      return unless @roles;
  
      # loop over all methods that are a part of the current class
      # (not inherited)
      for my $method ( $meta->_get_local_methods ) {
          # always ignore meta
          next if $method->isa('Class::MOP::Method::Meta');
          # we'll deal with attributes below
          next if $method->can('associated_attribute');
          # if the method comes from a role we consumed, ignore it
          next if $meta->can('does_role')
               && $meta->does_role($method->original_package_name);
          # FIXME - this really isn't right. Just because a modifier is
          # defined in a role doesn't mean it isn't _also_ defined in the
          # subclass.
          next if $method->isa('Class::MOP::Method::Wrapped')
               && (
                   (!scalar($method->around_modifiers)
                 || any { $_->has_around_method_modifiers($method->name) } @roles)
                && (!scalar($method->before_modifiers)
                 || any { $_->has_before_method_modifiers($method->name) } @roles)
                && (!scalar($method->after_modifiers)
                 || any { $_->has_after_method_modifiers($method->name) } @roles)
                  );
  
          return 0;
      }
  
      # loop over all attributes that are a part of the current class
      # (not inherited)
      # FIXME - this really isn't right. Just because an attribute is
      # defined in a role doesn't mean it isn't _also_ defined in the
      # subclass.
      for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
          next if any { $_->has_attribute($attr->name) } @roles;
  
          return 0;
      }
  
      return 1;
  }
  
  1;
  
  # ABSTRACT: Utilities for working with Moose classes
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Util - Utilities for working with Moose classes
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    use Moose::Util qw/find_meta does_role search_class_by_role/;
  
    my $meta = find_meta($object) || die "No metaclass found";
  
    if (does_role($object, $role)) {
      print "The object can do $role!\n";
    }
  
    my $class = search_class_by_role($object, 'FooRole');
    print "Nearest class with 'FooRole' is $class\n";
  
  =head1 DESCRIPTION
  
  This module provides a set of utility functions. Many of these
  functions are intended for use in Moose itself or MooseX modules, but
  some of them may be useful for use in your own code.
  
  =head1 EXPORTED FUNCTIONS
  
  =over 4
  
  =item B<find_meta($class_or_obj)>
  
  This method takes a class name or object and attempts to find a
  metaclass for the class, if one exists. It will B<not> create one if it
  does not yet exist.
  
  =item B<does_role($class_or_obj, $role_or_obj)>
  
  Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
  be provided as a name or a L<Moose::Meta::Role> object.
  
  The class must already have a metaclass for this to work. If it doesn't, this
  function simply returns false.
  
  =item B<search_class_by_role($class_or_obj, $role_or_obj)>
  
  Returns the first class in the class's precedence list that does
  C<$role_or_obj>, if any. The role can be either a name or a
  L<Moose::Meta::Role> object.
  
  The class must already have a metaclass for this to work.
  
  =item B<apply_all_roles($applicant, @roles)>
  
  This function applies one or more roles to the given C<$applicant> The
  applicant can be a role name, class name, or object.
  
  The C<$applicant> must already have a metaclass object.
  
  The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
  each of which can be followed by an optional hash reference of options
  (C<-excludes> and C<-alias>).
  
  =item B<ensure_all_roles($applicant, @roles)>
  
  This function is similar to L</apply_all_roles>, but only applies roles that
  C<$applicant> does not already consume.
  
  =item B<with_traits($class_name, @role_names)>
  
  This function creates a new class from C<$class_name> with each of
  C<@role_names> applied. It returns the name of the new class.
  
  =item B<get_all_attribute_values($meta, $instance)>
  
  Returns a hash reference containing all of the C<$instance>'s
  attributes. The keys are attribute names.
  
  =item B<get_all_init_args($meta, $instance)>
  
  Returns a hash reference containing all of the C<init_arg> values for
  the instance's attributes. The values are the associated attribute
  values. If an attribute does not have a defined C<init_arg>, it is
  skipped.
  
  This could be useful in cloning an object.
  
  =item B<resolve_metaclass_alias($category, $name, %options)>
  
  =item B<resolve_metatrait_alias($category, $name, %options)>
  
  Resolves a short name to a full class name. Short names are often used
  when specifying the C<metaclass> or C<traits> option for an attribute:
  
      has foo => (
          metaclass => "Bar",
      );
  
  The name resolution mechanism is covered in
  L<Moose/Metaclass and Trait Name Resolution>.
  
  =item B<meta_class_alias($to[, $from])>
  
  =item B<meta_attribute_alias($to[, $from])>
  
  Create an alias from the class C<$from> (or the current package, if
  C<$from> is unspecified), so that
  L<Moose/Metaclass and Trait Name Resolution> works properly.
  
  =item B<english_list(@items)>
  
  Given a list of scalars, turns them into a proper list in English
  ("one and two", "one, two, three, and four"). This is used to help us
  make nicer error messages.
  
  =back
  
  =head1 TODO
  
  Here is a list of possible functions to write
  
  =over 4
  
  =item discovering original method from modified method
  
  =item search for origin class of a method or attribute
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL

$fatpacked{"darwin-thread-multi-2level/Moose/Util/MetaRole.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_METAROLE';
  package Moose::Util::MetaRole;
  BEGIN {
    $Moose::Util::MetaRole::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Util::MetaRole::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  use Scalar::Util 'blessed';
  
  use Carp qw( croak );
  use List::MoreUtils qw( all );
  use List::Util qw( first );
  use Moose::Deprecated;
  use Scalar::Util qw( blessed );
  
  sub apply_metaroles {
      my %args = @_;
  
      my $for = _metathing_for( $args{for} );
  
      if ( $for->isa('Moose::Meta::Role') ) {
          return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
      }
      else {
          return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
      }
  }
  
  sub _metathing_for {
      my $passed = shift;
  
      my $found
          = blessed $passed
          ? $passed
          : Class::MOP::class_of($passed);
  
      return $found
          if defined $found
              && blessed $found
              && (   $found->isa('Moose::Meta::Role')
                  || $found->isa('Moose::Meta::Class') );
  
      local $Carp::CarpLevel = $Carp::CarpLevel + 1;
  
      my $error_start
          = 'When using Moose::Util::MetaRole, you must pass a Moose class name,'
          . ' role name, metaclass object, or metarole object.';
  
      if ( defined $found && blessed $found ) {
          croak $error_start
              . " You passed $passed, and we resolved this to a "
              . ( blessed $found )
              . ' object.';
      }
  
      if ( defined $passed && !defined $found ) {
          croak $error_start
              . " You passed $passed, and this did not resolve to a metaclass or metarole."
              . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
      }
  
      if ( !defined $passed ) {
          croak $error_start
              . " You passed an undef."
              . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?';
      }
  }
  
  sub _make_new_metaclass {
      my $for     = shift;
      my $roles   = shift;
      my $primary = shift;
  
      return $for unless keys %{$roles};
  
      my $new_metaclass
          = exists $roles->{$primary}
          ? _make_new_class( ref $for, $roles->{$primary} )
          : blessed $for;
  
      my %classes;
  
      for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
          my $attr = first {$_}
              map { $for->meta->find_attribute_by_name($_) } (
              $key . '_metaclass',
              $key . '_class'
          );
  
          my $reader = $attr->get_read_method;
  
          $classes{ $attr->init_arg }
              = _make_new_class( $for->$reader(), $roles->{$key} );
      }
  
      my $new_meta = $new_metaclass->reinitialize( $for, %classes );
  
      return $new_meta;
  }
  
  sub apply_base_class_roles {
      my %args = @_;
  
      my $meta = _metathing_for( $args{for} || $args{for_class} );
      croak 'You can only apply base class roles to a Moose class, not a role.'
          if $meta->isa('Moose::Meta::Role');
  
      my $new_base = _make_new_class(
          $meta->name,
          $args{roles},
          [ $meta->superclasses() ],
      );
  
      $meta->superclasses($new_base)
          if $new_base ne $meta->name();
  }
  
  sub _make_new_class {
      my $existing_class = shift;
      my $roles          = shift;
      my $superclasses   = shift || [$existing_class];
  
      return $existing_class unless $roles;
  
      my $meta = Class::MOP::Class->initialize($existing_class);
  
      return $existing_class
          if $meta->can('does_role') && all  { $meta->does_role($_) }
                                        grep { !ref $_ } @{$roles};
  
      return Moose::Meta::Class->create_anon_class(
          superclasses => $superclasses,
          roles        => $roles,
          cache        => 1,
      )->name();
  }
  
  1;
  
  # ABSTRACT: Apply roles to any metaclass, as well as the object base class
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyApp::Moose;
  
    use Moose ();
    use Moose::Exporter;
    use Moose::Util::MetaRole;
  
    use MyApp::Role::Meta::Class;
    use MyApp::Role::Meta::Method::Constructor;
    use MyApp::Role::Object;
  
    Moose::Exporter->setup_import_methods( also => 'Moose' );
  
    sub init_meta {
        shift;
        my %args = @_;
  
        Moose->init_meta(%args);
  
        Moose::Util::MetaRole::apply_metaroles(
            for             => $args{for_class},
            class_metaroles => {
                class => => ['MyApp::Role::Meta::Class'],
                constructor => ['MyApp::Role::Meta::Method::Constructor'],
            },
        );
  
        Moose::Util::MetaRole::apply_base_class_roles(
            for   => $args{for_class},
            roles => ['MyApp::Role::Object'],
        );
  
        return $args{for_class}->meta();
    }
  
  =head1 DESCRIPTION
  
  This utility module is designed to help authors of Moose extensions
  write extensions that are able to cooperate with other Moose
  extensions. To do this, you must write your extensions as roles, which
  can then be dynamically applied to the caller's metaclasses.
  
  This module makes sure to preserve any existing superclasses and roles
  already set for the meta objects, which means that any number of
  extensions can apply roles in any order.
  
  =head1 USAGE
  
  The easiest way to use this module is through L<Moose::Exporter>, which can
  generate the appropriate C<init_meta> method for you, and make sure it is
  called when imported.
  
  =head1 FUNCTIONS
  
  This module provides two functions.
  
  =head2 apply_metaroles( ... )
  
  This function will apply roles to one or more metaclasses for the specified
  class. It will return a new metaclass object for the class or role passed in
  the "for" parameter.
  
  It accepts the following parameters:
  
  =over 4
  
  =item * for => $name
  
  This specifies the class or for which to alter the meta classes. This can be a
  package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
  L<Moose::Meta::Role>).
  
  =item * class_metaroles => \%roles
  
  This is a hash reference specifying which metaroles will be applied to the
  class metaclass and its contained metaclasses and helper classes.
  
  Each key should in turn point to an array reference of role names.
  
  It accepts the following keys:
  
  =over 8
  
  =item class
  
  =item attribute
  
  =item method
  
  =item wrapped_method
  
  =item instance
  
  =item constructor
  
  =item destructor
  
  =item error
  
  =back
  
  =item * role_metaroles => \%roles
  
  This is a hash reference specifying which metaroles will be applied to the
  role metaclass and its contained metaclasses and helper classes.
  
  It accepts the following keys:
  
  =over 8
  
  =item role
  
  =item attribute
  
  =item method
  
  =item required_method
  
  =item conflicting_method
  
  =item application_to_class
  
  =item application_to_role
  
  =item application_to_instance
  
  =item application_role_summation
  
  =item applied_attribute
  
  =back
  
  =back
  
  =head2 apply_base_class_roles( for => $class, roles => \@roles )
  
  This function will apply the specified roles to the object's base class.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_METAROLE

$fatpacked{"darwin-thread-multi-2level/Moose/Util/TypeConstraints.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS';
  
  package Moose::Util::TypeConstraints;
  BEGIN {
    $Moose::Util::TypeConstraints::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Util::TypeConstraints::VERSION = '2.0401';
  }
  
  use Carp ();
  use List::MoreUtils qw( all any );
  use Scalar::Util qw( blessed reftype );
  use Moose::Exporter;
  
  ## --------------------------------------------------------
  # Prototyped subs must be predeclared because we have a
  # circular dependency with Moose::Meta::Attribute et. al.
  # so in case of us being use'd first the predeclaration
  # ensures the prototypes are in scope when consumers are
  # compiled.
  
  # dah sugah!
  sub where (&);
  sub via (&);
  sub message (&);
  sub optimize_as (&);
  sub inline_as (&);
  
  ## --------------------------------------------------------
  
  use Moose::Deprecated;
  use Moose::Meta::TypeConstraint;
  use Moose::Meta::TypeConstraint::Union;
  use Moose::Meta::TypeConstraint::Parameterized;
  use Moose::Meta::TypeConstraint::Parameterizable;
  use Moose::Meta::TypeConstraint::Class;
  use Moose::Meta::TypeConstraint::Role;
  use Moose::Meta::TypeConstraint::Enum;
  use Moose::Meta::TypeConstraint::DuckType;
  use Moose::Meta::TypeCoercion;
  use Moose::Meta::TypeCoercion::Union;
  use Moose::Meta::TypeConstraint::Registry;
  
  Moose::Exporter->setup_import_methods(
      as_is => [
          qw(
              type subtype class_type role_type maybe_type duck_type
              as where message optimize_as inline_as
              coerce from via
              enum union
              find_type_constraint
              register_type_constraint
              match_on_type )
      ],
  );
  
  ## --------------------------------------------------------
  ## type registry and some useful functions for it
  ## --------------------------------------------------------
  
  my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
  
  sub get_type_constraint_registry {$REGISTRY}
  sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
  
  sub export_type_constraints_as_functions {
      my $pkg = caller();
      no strict 'refs';
      foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
          my $tc = $REGISTRY->get_type_constraint($constraint)
              ->_compiled_type_constraint;
          *{"${pkg}::${constraint}"}
              = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
      }
  }
  
  sub create_type_constraint_union {
      _create_type_constraint_union(\@_);
  }
  
  sub create_named_type_constraint_union {
      my $name = shift;
      _create_type_constraint_union($name, \@_);
  }
  
  sub _create_type_constraint_union {
      my $name;
      $name = shift if @_ > 1;
      my @tcs = @{ shift() };
  
      my @type_constraint_names;
  
      if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) {
          @type_constraint_names = _parse_type_constraint_union( $tcs[0] );
      }
      else {
          @type_constraint_names = @tcs;
      }
  
      ( scalar @type_constraint_names >= 2 )
          || __PACKAGE__->_throw_error(
          "You must pass in at least 2 type names to make a union");
  
      my @type_constraints = map {
          find_or_parse_type_constraint($_)
              || __PACKAGE__->_throw_error(
              "Could not locate type constraint ($_) for the union");
      } @type_constraint_names;
  
      my %options = (
        type_constraints => \@type_constraints
      );
      $options{name} = $name if defined $name;
  
      return Moose::Meta::TypeConstraint::Union->new(%options);
  }
  
  
  sub create_parameterized_type_constraint {
      my $type_constraint_name = shift;
      my ( $base_type, $type_parameter )
          = _parse_parameterized_type_constraint($type_constraint_name);
  
      ( defined $base_type && defined $type_parameter )
          || __PACKAGE__->_throw_error(
          "Could not parse type name ($type_constraint_name) correctly");
  
      if ( $REGISTRY->has_type_constraint($base_type) ) {
          my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
          return _create_parameterized_type_constraint(
              $base_type_tc,
              $type_parameter
          );
      }
      else {
          __PACKAGE__->_throw_error(
              "Could not locate the base type ($base_type)");
      }
  }
  
  sub _create_parameterized_type_constraint {
      my ( $base_type_tc, $type_parameter ) = @_;
      if ( $base_type_tc->can('parameterize') ) {
          return $base_type_tc->parameterize($type_parameter);
      }
      else {
          return Moose::Meta::TypeConstraint::Parameterized->new(
              name   => $base_type_tc->name . '[' . $type_parameter . ']',
              parent => $base_type_tc,
              type_parameter =>
                  find_or_create_isa_type_constraint($type_parameter),
          );
      }
  }
  
  #should we also support optimized checks?
  sub create_class_type_constraint {
      my ( $class, $options ) = @_;
  
  # too early for this check
  #find_type_constraint("ClassName")->check($class)
  #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
  
      my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) );
  
      if (my $type = $REGISTRY->get_type_constraint($class)) {
          if (!($type->isa('Moose::Meta::TypeConstraint::Class') && $type->class eq $class)) {
              _confess(
                  "The type constraint '$class' has already been created in "
                . $type->_package_defined_in
                . " and cannot be created again in "
                . $pkg_defined_in )
          }
      }
  
      my %options = (
          class              => $class,
          name               => $class,
          package_defined_in => $pkg_defined_in,
          %{ $options || {} },
      );
  
      $options{name} ||= "__ANON__";
  
      my $tc = Moose::Meta::TypeConstraint::Class->new(%options);
      $REGISTRY->add_type_constraint($tc);
      return $tc;
  }
  
  sub create_role_type_constraint {
      my ( $role, $options ) = @_;
  
  # too early for this check
  #find_type_constraint("ClassName")->check($class)
  #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
  
      my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) );
  
      if (my $type = $REGISTRY->get_type_constraint($role)) {
          if (!($type->isa('Moose::Meta::TypeConstraint::Role') && $type->role eq $role)) {
              _confess(
                  "The type constraint '$role' has already been created in "
                . $type->_package_defined_in
                . " and cannot be created again in "
                . $pkg_defined_in )
          }
      }
  
      my %options = (
          role               => $role,
          name               => $role,
          package_defined_in => $pkg_defined_in,
          %{ $options || {} },
      );
  
      $options{name} ||= "__ANON__";
  
      my $tc = Moose::Meta::TypeConstraint::Role->new(%options);
      $REGISTRY->add_type_constraint($tc);
      return $tc;
  }
  
  sub find_or_create_type_constraint {
      my ( $type_constraint_name, $options_for_anon_type ) = @_;
  
      if ( my $constraint
          = find_or_parse_type_constraint($type_constraint_name) ) {
          return $constraint;
      }
      elsif ( defined $options_for_anon_type ) {
  
          # NOTE:
          # if there is no $options_for_anon_type
          # specified, then we assume they don't
          # want to create one, and return nothing.
  
          # otherwise assume that we should create
          # an ANON type with the $options_for_anon_type
          # options which can be passed in. It should
          # be noted that these don't get registered
          # so we need to return it.
          # - SL
          return Moose::Meta::TypeConstraint->new(
              name => '__ANON__',
              %{$options_for_anon_type}
          );
      }
  
      return;
  }
  
  sub find_or_create_isa_type_constraint {
      my ($type_constraint_name, $options) = @_;
      find_or_parse_type_constraint($type_constraint_name)
          || create_class_type_constraint($type_constraint_name, $options);
  }
  
  sub find_or_create_does_type_constraint {
      my ($type_constraint_name, $options) = @_;
      find_or_parse_type_constraint($type_constraint_name)
          || create_role_type_constraint($type_constraint_name, $options);
  }
  
  sub find_or_parse_type_constraint {
      my $type_constraint_name = normalize_type_constraint_name(shift);
      my $constraint;
  
      if ( $constraint = find_type_constraint($type_constraint_name) ) {
          return $constraint;
      }
      elsif ( _detect_type_constraint_union($type_constraint_name) ) {
          $constraint = create_type_constraint_union($type_constraint_name);
      }
      elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
          $constraint
              = create_parameterized_type_constraint($type_constraint_name);
      }
      else {
          return;
      }
  
      $REGISTRY->add_type_constraint($constraint);
      return $constraint;
  }
  
  sub normalize_type_constraint_name {
      my $type_constraint_name = shift;
      $type_constraint_name =~ s/\s//g;
      return $type_constraint_name;
  }
  
  sub _confess {
      my $error = shift;
  
      local $Carp::CarpLevel = $Carp::CarpLevel + 1;
      Carp::confess($error);
  }
  
  ## --------------------------------------------------------
  ## exported functions ...
  ## --------------------------------------------------------
  
  sub find_type_constraint {
      my $type = shift;
  
      if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) {
          return $type;
      }
      else {
          return unless $REGISTRY->has_type_constraint($type);
          return $REGISTRY->get_type_constraint($type);
      }
  }
  
  sub register_type_constraint {
      my $constraint = shift;
      __PACKAGE__->_throw_error("can't register an unnamed type constraint")
          unless defined $constraint->name;
      $REGISTRY->add_type_constraint($constraint);
      return $constraint;
  }
  
  # type constructors
  
  sub type {
      my $name = shift;
  
      my %p = map { %{$_} } @_;
  
      return _create_type_constraint(
          $name, undef, $p{where}, $p{message},
          $p{optimize_as}, $p{inline_as},
      );
  }
  
  sub subtype {
      if ( @_ == 1 && !ref $_[0] ) {
          __PACKAGE__->_throw_error(
              'A subtype cannot consist solely of a name, it must have a parent'
          );
      }
  
      # The blessed check is mostly to accommodate MooseX::Types, which
      # uses an object which overloads stringification as a type name.
      my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
  
      my %p = map { %{$_} } @_;
  
      # subtype Str => where { ... };
      if ( !exists $p{as} ) {
          $p{as} = $name;
          $name = undef;
      }
  
      return _create_type_constraint(
          $name, $p{as}, $p{where}, $p{message},
          $p{optimize_as}, $p{inline_as},
      );
  }
  
  sub class_type {
      create_class_type_constraint(@_);
  }
  
  sub role_type ($;$) {
      create_role_type_constraint(@_);
  }
  
  sub maybe_type {
      my ($type_parameter) = @_;
  
      register_type_constraint(
          $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter)
      );
  }
  
  sub duck_type {
      my ( $type_name, @methods ) = @_;
      if ( ref $type_name eq 'ARRAY' && !@methods ) {
          @methods   = @$type_name;
          $type_name = undef;
      }
      if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) {
          @methods = @{ $methods[0] };
      }
  
      register_type_constraint(
          create_duck_type_constraint(
              $type_name,
              \@methods,
          )
      );
  }
  
  sub coerce {
      my ( $type_name, @coercion_map ) = @_;
      _install_type_coercions( $type_name, \@coercion_map );
  }
  
  # The trick of returning @_ lets us avoid having to specify a
  # prototype. Perl will parse this:
  #
  # subtype 'Foo'
  #     => as 'Str'
  #     => where { ... }
  #
  # as this:
  #
  # subtype( 'Foo', as( 'Str', where { ... } ) );
  #
  # If as() returns all its extra arguments, this just works, and
  # preserves backwards compatibility.
  sub as { { as => shift }, @_ }
  sub where (&)       { { where       => $_[0] } }
  sub message (&)     { { message     => $_[0] } }
  sub optimize_as (&) { { optimize_as => $_[0] } }
  sub inline_as (&)   { { inline_as   => $_[0] } }
  
  sub from    {@_}
  sub via (&) { $_[0] }
  
  sub enum {
      my ( $type_name, @values ) = @_;
  
      # NOTE:
      # if only an array-ref is passed then
      # you get an anon-enum
      # - SL
      if ( ref $type_name eq 'ARRAY' ) {
          @values == 0
              || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?");
  
          @values    = @$type_name;
          $type_name = undef;
      }
      if ( @values == 1 && ref $values[0] eq 'ARRAY' ) {
          @values = @{ $values[0] };
      }
  
      register_type_constraint(
          create_enum_type_constraint(
              $type_name,
              \@values,
          )
      );
  }
  
  sub union {
    my ( $type_name, @constraints ) = @_;
    if ( ref $type_name eq 'ARRAY' ) {
      @constraints == 0
        || __PACKAGE__->_throw_error("union called with an array reference and additional arguments.");
      @constraints = @$type_name;
      $type_name   = undef;
    }
    if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) {
      @constraints = @{ $constraints[0] };
    }
    if ( defined $type_name ) {
      return register_type_constraint(
        create_named_type_constraint_union( $type_name, @constraints )
      );
    }
    return create_type_constraint_union( @constraints );
  }
  
  sub create_enum_type_constraint {
      my ( $type_name, $values ) = @_;
  
      Moose::Meta::TypeConstraint::Enum->new(
          name => $type_name || '__ANON__',
          values => $values,
      );
  }
  
  sub create_duck_type_constraint {
      my ( $type_name, $methods ) = @_;
  
      Moose::Meta::TypeConstraint::DuckType->new(
          name => $type_name || '__ANON__',
          methods => $methods,
      );
  }
  
  sub match_on_type {
      my ($to_match, @cases) = @_;
      my $default;
      if (@cases % 2 != 0) {
          $default = pop @cases;
          (ref $default eq 'CODE')
              || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default");
      }
      while (@cases) {
          my ($type, $action) = splice @cases, 0, 2;
  
          unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) {
              $type = find_or_parse_type_constraint($type)
                   || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'")
          }
  
          (ref $action eq 'CODE')
              || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action");
  
          if ($type->check($to_match)) {
              local $_ = $to_match;
              return $action->($to_match);
          }
      }
      (defined $default)
          || __PACKAGE__->_throw_error("No cases matched for $to_match");
      {
          local $_ = $to_match;
          return $default->($to_match);
      }
  }
  
  
  ## --------------------------------------------------------
  ## desugaring functions ...
  ## --------------------------------------------------------
  
  sub _create_type_constraint ($$$;$$) {
      my $name      = shift;
      my $parent    = shift;
      my $check     = shift;
      my $message   = shift;
      my $optimized = shift;
      my $inlined   = shift;
  
      my $pkg_defined_in = scalar( caller(1) );
  
      if ( defined $name ) {
          my $type = $REGISTRY->get_type_constraint($name);
  
          ( $type->_package_defined_in eq $pkg_defined_in )
              || _confess(
                    "The type constraint '$name' has already been created in "
                  . $type->_package_defined_in
                  . " and cannot be created again in "
                  . $pkg_defined_in )
              if defined $type;
  
          $name =~ /^[\w:\.]+$/
              or die qq{$name contains invalid characters for a type name.}
              . qq{ Names can contain alphanumeric character, ":", and "."\n};
      }
  
      my %opts = (
          name               => $name,
          package_defined_in => $pkg_defined_in,
  
          ( $check     ? ( constraint => $check )     : () ),
          ( $message   ? ( message    => $message )   : () ),
          ( $optimized ? ( optimized  => $optimized ) : () ),
          ( $inlined   ? ( inlined    => $inlined )   : () ),
      );
  
      my $constraint;
      if (
          defined $parent
          and $parent
          = blessed $parent
          ? $parent
          : find_or_create_isa_type_constraint($parent)
          ) {
          $constraint = $parent->create_child_type(%opts);
      }
      else {
          $constraint = Moose::Meta::TypeConstraint->new(%opts);
      }
  
      $REGISTRY->add_type_constraint($constraint)
          if defined $name;
  
      return $constraint;
  }
  
  sub _install_type_coercions ($$) {
      my ( $type_name, $coercion_map ) = @_;
      my $type = find_type_constraint($type_name);
      ( defined $type )
          || __PACKAGE__->_throw_error(
          "Cannot find type '$type_name', perhaps you forgot to load it");
      if ( $type->has_coercion ) {
          $type->coercion->add_type_coercions(@$coercion_map);
      }
      else {
          my $type_coercion = Moose::Meta::TypeCoercion->new(
              type_coercion_map => $coercion_map,
              type_constraint   => $type
          );
          $type->coercion($type_coercion);
      }
  }
  
  ## --------------------------------------------------------
  ## type notation parsing ...
  ## --------------------------------------------------------
  
  {
  
      # All I have to say is mugwump++ cause I know
      # do not even have enough regexp-fu to be able
      # to have written this (I can only barely
      # understand it as it is)
      # - SL
  
      use re "eval";
  
      my $valid_chars = qr{[\w:\.]};
      my $type_atom   = qr{ (?>$valid_chars+) }x;
      my $ws          = qr{ (?>\s*) }x;
      my $op_union    = qr{ $ws \| $ws }x;
  
      my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
      if (Class::MOP::IS_RUNNING_ON_5_10) {
          my $type_pattern
              = q{  (?&type_atom)  (?: \[ (?&ws)  (?&any)  (?&ws) \] )? };
          my $type_capture_parts_pattern
              = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? };
          my $type_with_parameter_pattern
              = q{  (?&type_atom)      \[ (?&ws)  (?&any)  (?&ws) \]    };
          my $union_pattern
              = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
          my $any_pattern
              = q{ (?&type) | (?&union) };
  
          my $defines = qr{(?(DEFINE)
              (?<valid_chars>         $valid_chars)
              (?<type_atom>           $type_atom)
              (?<ws>                  $ws)
              (?<op_union>            $op_union)
              (?<type>                $type_pattern)
              (?<type_capture_parts>  $type_capture_parts_pattern)
              (?<type_with_parameter> $type_with_parameter_pattern)
              (?<union>               $union_pattern)
              (?<any>                 $any_pattern)
          )}x;
  
          $type                = qr{ $type_pattern                $defines }x;
          $type_capture_parts  = qr{ $type_capture_parts_pattern  $defines }x;
          $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
          $union               = qr{ $union_pattern               $defines }x;
          $any                 = qr{ $any_pattern                 $defines }x;
      }
      else {
          $type
              = qr{  $type_atom  (?: \[ $ws  (??{$any})  $ws \] )? }x;
          $type_capture_parts
              = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x;
          $type_with_parameter
              = qr{  $type_atom      \[ $ws  (??{$any})  $ws \]    }x;
          $union
              = qr{ $type (?> (?: $op_union $type )+ ) }x;
          $any
              = qr{ $type | $union }x;
      }
  
  
      sub _parse_parameterized_type_constraint {
          { no warnings 'void'; $any; }  # force capture of interpolated lexical
          $_[0] =~ m{ $type_capture_parts }x;
          return ( $1, $2 );
      }
  
      sub _detect_parameterized_type_constraint {
          { no warnings 'void'; $any; }  # force capture of interpolated lexical
          $_[0] =~ m{ ^ $type_with_parameter $ }x;
      }
  
      sub _parse_type_constraint_union {
          { no warnings 'void'; $any; }  # force capture of interpolated lexical
          my $given = shift;
          my @rv;
          while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
              push @rv => $1;
          }
          ( pos($given) eq length($given) )
              || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
                  . pos($given)
                  . " and str-length="
                  . length($given)
                  . ")" );
          @rv;
      }
  
      sub _detect_type_constraint_union {
          { no warnings 'void'; $any; }  # force capture of interpolated lexical
          $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
      }
  }
  
  ## --------------------------------------------------------
  # define some basic built-in types
  ## --------------------------------------------------------
  
  # By making these classes immutable before creating all the types in
  # Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow
  # MOP-based accessors.
  $_->make_immutable(
      inline_constructor => 1,
      constructor_name   => "_new",
  
      # these are Class::MOP accessors, so they need inlining
      inline_accessors => 1
      ) for grep { $_->is_mutable }
      map { Class::MOP::class_of($_) }
      qw(
      Moose::Meta::TypeConstraint
      Moose::Meta::TypeConstraint::Union
      Moose::Meta::TypeConstraint::Parameterized
      Moose::Meta::TypeConstraint::Parameterizable
      Moose::Meta::TypeConstraint::Class
      Moose::Meta::TypeConstraint::Role
      Moose::Meta::TypeConstraint::Enum
      Moose::Meta::TypeConstraint::DuckType
      Moose::Meta::TypeConstraint::Registry
  );
  
  require Moose::Util::TypeConstraints::Builtins;
  Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY);
  
  my @PARAMETERIZABLE_TYPES
      = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe];
  
  sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
  
  sub add_parameterizable_type {
      my $type = shift;
      ( blessed $type
              && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
          || __PACKAGE__->_throw_error(
          "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
          );
      push @PARAMETERIZABLE_TYPES => $type;
  }
  
  ## --------------------------------------------------------
  # end of built-in types ...
  ## --------------------------------------------------------
  
  {
      my @BUILTINS = list_all_type_constraints();
      sub list_all_builtin_type_constraints {@BUILTINS}
  }
  
  sub _throw_error {
      shift;
      require Moose;
      unshift @_, 'Moose';
      goto &Moose::throw_error;
  }
  
  1;
  
  # ABSTRACT: Type constraint system for Moose
  
  
  
  =pod
  
  =head1 NAME
  
  Moose::Util::TypeConstraints - Type constraint system for Moose
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    use Moose::Util::TypeConstraints;
  
    subtype 'Natural',
        as 'Int',
        where { $_ > 0 };
  
    subtype 'NaturalLessThanTen',
        as 'Natural',
        where { $_ < 10 },
        message { "This number ($_) is not less than ten!" };
  
    coerce 'Num',
        from 'Str',
        via { 0+$_ };
  
    class_type 'DateTimeClass', { class => 'DateTime' };
  
    role_type 'Barks', { role => 'Some::Library::Role::Barks' };
  
    enum 'RGBColors', [qw(red green blue)];
  
    union 'StringOrArray', [qw( String Array )];
  
    no Moose::Util::TypeConstraints;
  
  =head1 DESCRIPTION
  
  This module provides Moose with the ability to create custom type
  constraints to be used in attribute definition.
  
  =head2 Important Caveat
  
  This is B<NOT> a type system for Perl 5. These are type constraints,
  and they are not used by Moose unless you tell it to. No type
  inference is performed, expressions are not typed, etc. etc. etc.
  
  A type constraint is at heart a small "check if a value is valid"
  function. A constraint can be associated with an attribute. This
  simplifies parameter validation, and makes your code clearer to read,
  because you can refer to constraints by name.
  
  =head2 Slightly Less Important Caveat
  
  It is B<always> a good idea to quote your type names.
  
  This prevents Perl from trying to execute the call as an indirect
  object call. This can be an issue when you have a subtype with the
  same name as a valid class.
  
  For instance:
  
    subtype DateTime => as Object => where { $_->isa('DateTime') };
  
  will I<just work>, while this:
  
    use DateTime;
    subtype DateTime => as Object => where { $_->isa('DateTime') };
  
  will fail silently and cause many headaches. The simple way to solve
  this, as well as future proof your subtypes from classes which have
  yet to have been created, is to quote the type name:
  
    use DateTime;
    subtype 'DateTime', as 'Object', where { $_->isa('DateTime') };
  
  =head2 Default Type Constraints
  
  This module also provides a simple hierarchy for Perl 5 types, here is
  that hierarchy represented visually.
  
    Any
    Item
        Bool
        Maybe[`a]
        Undef
        Defined
            Value
                Str
                    Num
                        Int
                    ClassName
                    RoleName
            Ref
                ScalarRef[`a]
                ArrayRef[`a]
                HashRef[`a]
                CodeRef
                RegexpRef
                GlobRef
                FileHandle
                Object
  
  B<NOTE:> Any type followed by a type parameter C<[`a]> can be
  parameterized, this means you can say:
  
    ArrayRef[Int]    # an array of integers
    HashRef[CodeRef] # a hash of str to CODE ref mappings
    ScalarRef[Int]   # a reference to an integer
    Maybe[Str]       # value may be a string, may be undefined
  
  If Moose finds a name in brackets that it does not recognize as an
  existing type, it assumes that this is a class name, for example
  C<ArrayRef[DateTime]>.
  
  B<NOTE:> Unless you parameterize a type, then it is invalid to include
  the square brackets. I.e. C<ArrayRef[]> will be treated as a new type
  name, I<not> as a parameterization of C<ArrayRef>.
  
  B<NOTE:> The C<Undef> type constraint for the most part works
  correctly now, but edge cases may still exist, please use it
  sparingly.
  
  B<NOTE:> The C<ClassName> type constraint does a complex package
  existence check. This means that your class B<must> be loaded for this
  type constraint to pass.
  
  B<NOTE:> The C<RoleName> constraint checks a string is a I<package
  name> which is a role, like C<'MyApp::Role::Comparable'>.
  
  =head2 Type Constraint Naming
  
  Type name declared via this module can only contain alphanumeric
  characters, colons (:), and periods (.).
  
  Since the types created by this module are global, it is suggested
  that you namespace your types just as you would namespace your
  modules. So instead of creating a I<Color> type for your
  B<My::Graphics> module, you would call the type
  I<My::Graphics::Types::Color> instead.
  
  =head2 Use with Other Constraint Modules
  
  This module can play nicely with other constraint modules with some
  slight tweaking. The C<where> clause in types is expected to be a
  C<CODE> reference which checks its first argument and returns a
  boolean. Since most constraint modules work in a similar way, it
  should be simple to adapt them to work with Moose.
  
  For instance, this is how you could use it with
  L<Declare::Constraints::Simple> to declare a completely new type.
  
    type 'HashOfArrayOfObjects',
        where {
            IsHashRef(
                -keys   => HasLength,
                -values => IsArrayRef(IsObject)
            )->(@_);
        };
  
  For more examples see the F<t/examples/example_w_DCS.t> test
  file.
  
  Here is an example of using L<Test::Deep> and its non-test
  related C<eq_deeply> function.
  
    type 'ArrayOfHashOfBarsAndRandomNumbers',
        where {
            eq_deeply($_,
                array_each(subhashof({
                    bar           => isa('Bar'),
                    random_number => ignore()
                })))
          };
  
  For a complete example see the
  F<t/examples/example_w_TestDeep.t> test file.
  
  =head2 Error messages
  
  Type constraints can also specify custom error messages, for when they fail to
  validate. This is provided as just another coderef, which receives the invalid
  value in C<$_>, as in:
  
    subtype 'PositiveInt',
         as 'Int',
         where { $_ > 0 },
         message { "$_ is not a positive integer!" };
  
  If no message is specified, a default message will be used, which indicates
  which type constraint was being used and what value failed. If
  L<Devel::PartialDump> (version 0.14 or higher) is installed, it will be used to
  display the invalid value, otherwise it will just be printed as is.
  
  =head1 FUNCTIONS
  
  =head2 Type Constraint Constructors
  
  The following functions are used to create type constraints.  They
  will also register the type constraints your create in a global
  registry that is used to look types up by name.
  
  See the L</SYNOPSIS> for an example of how to use these.
  
  =over 4
  
  =item B<< subtype 'Name', as 'Parent', where { } ... >>
  
  This creates a named subtype.
  
  If you provide a parent that Moose does not recognize, it will
  automatically create a new class type constraint for this name.
  
  When creating a named type, the C<subtype> function should either be
  called with the sugar helpers (C<where>, C<message>, etc), or with a
  name and a hashref of parameters:
  
   subtype( 'Foo', { where => ..., message => ... } );
  
  The valid hashref keys are C<as> (the parent), C<where>, C<message>,
  and C<optimize_as>.
  
  =item B<< subtype as 'Parent', where { } ... >>
  
  This creates an unnamed subtype and will return the type
  constraint meta-object, which will be an instance of
  L<Moose::Meta::TypeConstraint>.
  
  When creating an anonymous type, the C<subtype> function should either
  be called with the sugar helpers (C<where>, C<message>, etc), or with
  just a hashref of parameters:
  
   subtype( { where => ..., message => ... } );
  
  =item B<class_type ($class, ?$options)>
  
  Creates a new subtype of C<Object> with the name C<$class> and the
  metaclass L<Moose::Meta::TypeConstraint::Class>.
  
    # Create a type called 'Box' which tests for objects which ->isa('Box')
    class_type 'Box';
  
  By default, the name of the type and the name of the class are the same, but
  you can specify both separately.
  
    # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box');
    class_type 'Box', { class => 'ObjectLibrary::Box' };
  
  =item B<role_type ($role, ?$options)>
  
  Creates a C<Role> type constraint with the name C<$role> and the
  metaclass L<Moose::Meta::TypeConstraint::Role>.
  
    # Create a type called 'Walks' which tests for objects which ->does('Walks')
    role_type 'Walks';
  
  By default, the name of the type and the name of the role are the same, but
  you can specify both separately.
  
    # Create a type called 'Walks' which tests for objects which ->does('MooseX::Role::Walks');
    role_type 'Walks', { role => 'MooseX::Role::Walks' };
  
  =item B<maybe_type ($type)>
  
  Creates a type constraint for either C<undef> or something of the
  given type.
  
  =item B<duck_type ($name, \@methods)>
  
  This will create a subtype of Object and test to make sure the value
  C<can()> do the methods in C<\@methods>.
  
  This is intended as an easy way to accept non-Moose objects that
  provide a certain interface. If you're using Moose classes, we
  recommend that you use a C<requires>-only Role instead.
  
  =item B<duck_type (\@methods)>
  
  If passed an ARRAY reference as the only parameter instead of the
  C<$name>, C<\@methods> pair, this will create an unnamed duck type.
  This can be used in an attribute definition like so:
  
    has 'cache' => (
        is  => 'ro',
        isa => duck_type( [qw( get_set )] ),
    );
  
  =item B<enum ($name, \@values)>
  
  This will create a basic subtype for a given set of strings.
  The resulting constraint will be a subtype of C<Str> and
  will match any of the items in C<\@values>. It is case sensitive.
  See the L</SYNOPSIS> for a simple example.
  
  B<NOTE:> This is not a true proper enum type, it is simply
  a convenient constraint builder.
  
  =item B<enum (\@values)>
  
  If passed an ARRAY reference as the only parameter instead of the
  C<$name>, C<\@values> pair, this will create an unnamed enum. This
  can then be used in an attribute definition like so:
  
    has 'sort_order' => (
        is  => 'ro',
        isa => enum([qw[ ascending descending ]]),
    );
  
  =item B<union ($name, \@constraints)>
  
  This will create a basic subtype where any of the provided constraints
  may match in order to satisfy this constraint.
  
  =item B<union (\@constraints)>
  
  If passed an ARRAY reference as the only parameter instead of the
  C<$name>, C<\@constraints> pair, this will create an unnamed union.
  This can then be used in an attribute definition like so:
  
    has 'items' => (
        is => 'ro',
        isa => union([qw[ Str ArrayRef ]]),
    );
  
  This is similar to the existing string union:
  
    isa => 'Str|ArrayRef'
  
  except that it supports anonymous elements as child constraints:
  
    has 'color' => (
      isa => 'ro',
      isa => union([ 'Int',  enum([qw[ red green blue ]]) ]),
    );
  
  =item B<as 'Parent'>
  
  This is just sugar for the type constraint construction syntax.
  
  It takes a single argument, which is the name of a parent type.
  
  =item B<where { ... }>
  
  This is just sugar for the type constraint construction syntax.
  
  It takes a subroutine reference as an argument. When the type
  constraint is tested, the reference is run with the value to be tested
  in C<$_>. This reference should return true or false to indicate
  whether or not the constraint check passed.
  
  =item B<message { ... }>
  
  This is just sugar for the type constraint construction syntax.
  
  It takes a subroutine reference as an argument. When the type
  constraint fails, then the code block is run with the value provided
  in C<$_>. This reference should return a string, which will be used in
  the text of the exception thrown.
  
  =item B<inline_as { ... }>
  
  This can be used to define a "hand optimized" inlinable version of your type
  constraint.
  
  You provide a subroutine which will be called I<as a method> on a
  L<Moose::Meta::TypeConstraint> object. It will receive a single parameter, the
  name of the variable to check, typically something like C<"$_"> or C<"$_[0]">.
  
  The subroutine should return a code string suitable for inlining. You can
  assume that the check will be wrapped in parentheses when it is inlined.
  
  The inlined code should include any checks that your type's parent types
  do. If your parent type constraint defines its own inlining, you can simply use
  that to avoid repeating code. For example, here is the inlining code for the
  C<Value> type, which is a subtype of C<Defined>:
  
      sub {
          $_[0]->parent()->_inline_check($_[1])
          . ' && !ref(' . $_[1] . ')'
      }
  
  =item B<optimize_as { ... }>
  
  B<This feature is deprecated, use C<inline_as> instead.>
  
  This can be used to define a "hand optimized" version of your
  type constraint which can be used to avoid traversing a subtype
  constraint hierarchy.
  
  B<NOTE:> You should only use this if you know what you are doing.
  All the built in types use this, so your subtypes (assuming they
  are shallow) will not likely need to use this.
  
  =item B<< type 'Name', where { } ... >>
  
  This creates a base type, which has no parent.
  
  The C<type> function should either be called with the sugar helpers
  (C<where>, C<message>, etc), or with a name and a hashref of
  parameters:
  
    type( 'Foo', { where => ..., message => ... } );
  
  The valid hashref keys are C<where>, C<message>, and C<inlined_as>.
  
  =back
  
  =head2 Type Constraint Utilities
  
  =over 4
  
  =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >>
  
  This is a utility function for doing simple type based dispatching similar to
  match/case in OCaml and case/of in Haskell. It is not as featureful as those
  languages, nor does not it support any kind of automatic destructuring
  bind. Here is a simple Perl pretty printer dispatching over the core Moose
  types.
  
    sub ppprint {
        my $x = shift;
        match_on_type $x => (
            HashRef => sub {
                my $hash = shift;
                '{ '
                    . (
                    join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) }
                        sort keys %$hash
                    ) . ' }';
            },
            ArrayRef => sub {
                my $array = shift;
                '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]';
            },
            CodeRef   => sub {'sub { ... }'},
            RegexpRef => sub { 'qr/' . $_ . '/' },
            GlobRef   => sub { '*' . B::svref_2object($_)->NAME },
            Object    => sub { $_->can('to_string') ? $_->to_string : $_ },
            ScalarRef => sub { '\\' . ppprint( ${$_} ) },
            Num       => sub {$_},
            Str       => sub { '"' . $_ . '"' },
            Undef     => sub {'undef'},
            => sub { die "I don't know what $_ is" }
        );
    }
  
  Or a simple JSON serializer:
  
    sub to_json {
        my $x = shift;
        match_on_type $x => (
            HashRef => sub {
                my $hash = shift;
                '{ '
                    . (
                    join ", " =>
                        map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) }
                        sort keys %$hash
                    ) . ' }';
            },
            ArrayRef => sub {
                my $array = shift;
                '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]';
            },
            Num   => sub {$_},
            Str   => sub { '"' . $_ . '"' },
            Undef => sub {'null'},
            => sub { die "$_ is not acceptable json type" }
        );
    }
  
  The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can
  be either a string type or a L<Moose::Meta::TypeConstraint> object, and
  C<\&action> is a subroutine reference. This function will dispatch on the
  first match for C<$value>. It is possible to have a catch-all by providing an
  additional subroutine reference as the final argument to C<match_on_type>.
  
  =back
  
  =head2 Type Coercion Constructors
  
  You can define coercions for type constraints, which allow you to
  automatically transform values to something valid for the type
  constraint. If you ask your accessor to coerce, then Moose will run
  the type-coercion code first, followed by the type constraint
  check. This feature should be used carefully as it is very powerful
  and could easily take off a limb if you are not careful.
  
  See the L</SYNOPSIS> for an example of how to use these.
  
  =over 4
  
  =item B<< coerce 'Name', from 'OtherName', via { ... }  >>
  
  This defines a coercion from one type to another. The C<Name> argument
  is the type you are coercing I<to>.
  
  To define multiple coercions, supply more sets of from/via pairs:
  
    coerce 'Name',
      from 'OtherName', via { ... },
      from 'ThirdName', via { ... };
  
  =item B<from 'OtherName'>
  
  This is just sugar for the type coercion construction syntax.
  
  It takes a single type name (or type object), which is the type being
  coerced I<from>.
  
  =item B<via { ... }>
  
  This is just sugar for the type coercion construction syntax.
  
  It takes a subroutine reference. This reference will be called with
  the value to be coerced in C<$_>. It is expected to return a new value
  of the proper type for the coercion.
  
  =back
  
  =head2 Creating and Finding Type Constraints
  
  These are additional functions for creating and finding type
  constraints. Most of these functions are not available for
  importing. The ones that are importable as specified.
  
  =over 4
  
  =item B<find_type_constraint($type_name)>
  
  This function can be used to locate the L<Moose::Meta::TypeConstraint>
  object for a named type.
  
  This function is importable.
  
  =item B<register_type_constraint($type_object)>
  
  This function will register a L<Moose::Meta::TypeConstraint> with the
  global type registry.
  
  This function is importable.
  
  =item B<normalize_type_constraint_name($type_constraint_name)>
  
  This method takes a type constraint name and returns the normalized
  form. This removes any whitespace in the string.
  
  =item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
  
  =item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)>
  
  This can take a union type specification like C<'Int|ArrayRef[Int]'>,
  or a list of names. It returns a new
  L<Moose::Meta::TypeConstraint::Union> object.
  
  =item B<create_parameterized_type_constraint($type_name)>
  
  Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
  this will create a new L<Moose::Meta::TypeConstraint::Parameterized>
  object. The C<BaseType> must exist already exist as a parameterizable
  type.
  
  =item B<create_class_type_constraint($class, $options)>
  
  Given a class name this function will create a new
  L<Moose::Meta::TypeConstraint::Class> object for that class name.
  
  The C<$options> is a hash reference that will be passed to the
  L<Moose::Meta::TypeConstraint::Class> constructor (as a hash).
  
  =item B<create_role_type_constraint($role, $options)>
  
  Given a role name this function will create a new
  L<Moose::Meta::TypeConstraint::Role> object for that role name.
  
  The C<$options> is a hash reference that will be passed to the
  L<Moose::Meta::TypeConstraint::Role> constructor (as a hash).
  
  =item B<create_enum_type_constraint($name, $values)>
  
  Given a enum name this function will create a new
  L<Moose::Meta::TypeConstraint::Enum> object for that enum name.
  
  =item B<create_duck_type_constraint($name, $methods)>
  
  Given a duck type name this function will create a new
  L<Moose::Meta::TypeConstraint::DuckType> object for that enum name.
  
  =item B<find_or_parse_type_constraint($type_name)>
  
  Given a type name, this first attempts to find a matching constraint
  in the global registry.
  
  If the type name is a union or parameterized type, it will create a
  new object of the appropriate, but if given a "regular" type that does
  not yet exist, it simply returns false.
  
  When given a union or parameterized type, the member or base type must
  already exist.
  
  If it creates a new union or parameterized type, it will add it to the
  global registry.
  
  =item B<find_or_create_isa_type_constraint($type_name)>
  
  =item B<find_or_create_does_type_constraint($type_name)>
  
  These functions will first call C<find_or_parse_type_constraint>. If
  that function does not return a type, a new type object will
  be created.
  
  The C<isa> variant will use C<create_class_type_constraint> and the
  C<does> variant will use C<create_role_type_constraint>.
  
  =item B<get_type_constraint_registry>
  
  Returns the L<Moose::Meta::TypeConstraint::Registry> object which
  keeps track of all type constraints.
  
  =item B<list_all_type_constraints>
  
  This will return a list of type constraint names in the global
  registry. You can then fetch the actual type object using
  C<find_type_constraint($type_name)>.
  
  =item B<list_all_builtin_type_constraints>
  
  This will return a list of builtin type constraints, meaning those
  which are defined in this module. See the L<Default Type Constraints>
  section for a complete list.
  
  =item B<export_type_constraints_as_functions>
  
  This will export all the current type constraints as functions into
  the caller's namespace (C<Int()>, C<Str()>, etc). Right now, this is
  mostly used for testing, but it might prove useful to others.
  
  =item B<get_all_parameterizable_types>
  
  This returns all the parameterizable types that have been registered,
  as a list of type objects.
  
  =item B<add_parameterizable_type($type)>
  
  Adds C<$type> to the list of parameterizable types
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS

$fatpacked{"darwin-thread-multi-2level/Moose/Util/TypeConstraints/Builtins.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS_BUILTINS';
  package Moose::Util::TypeConstraints::Builtins;
  BEGIN {
    $Moose::Util::TypeConstraints::Builtins::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Moose::Util::TypeConstraints::Builtins::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw( is_class_loaded );
  use List::MoreUtils ();
  use Scalar::Util qw( blessed looks_like_number reftype );
  
  sub type { goto &Moose::Util::TypeConstraints::type }
  sub subtype { goto &Moose::Util::TypeConstraints::subtype }
  sub as { goto &Moose::Util::TypeConstraints::as }
  sub where (&) { goto &Moose::Util::TypeConstraints::where }
  sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as }
  sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as }
  
  sub define_builtins {
      my $registry = shift;
  
      type 'Any'    # meta-type including all
          => where {1}
          => inline_as { '1' };
  
      subtype 'Item'  # base type
          => as 'Any'
          => inline_as { '1' };
  
      subtype 'Undef'
          => as 'Item'
          => where { !defined($_) }
          => inline_as {
              '!defined(' . $_[1] . ')'
          };
  
      subtype 'Defined'
          => as 'Item'
          => where { defined($_) }
          => inline_as {
              'defined(' . $_[1] . ')'
          };
  
      subtype 'Bool'
          => as 'Item'
          => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
          => inline_as {
              '('
                  . '!defined(' . $_[1] . ') '
                  . '|| ' . $_[1] . ' eq "" '
                  . '|| (' . $_[1] . '."") eq "1" '
                  . '|| (' . $_[1] . '."") eq "0"'
              . ')'
          };
  
      subtype 'Value'
          => as 'Defined'
          => where { !ref($_) }
          => inline_as {
              $_[0]->parent()->_inline_check($_[1])
              . ' && !ref(' . $_[1] . ')'
          };
  
      subtype 'Ref'
          => as 'Defined'
          => where { ref($_) }
              # no need to call parent - ref also checks for definedness
          => inline_as { 'ref(' . $_[1] . ')' };
  
      subtype 'Str'
          => as 'Value'
          => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' }
          => inline_as {
              $_[0]->parent()->_inline_check($_[1])
              . ' && ('
                  . 'ref(\\' . $_[1] . ') eq "SCALAR"'
                  . ' || ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR"'
              . ')'
          };
  
      my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value');
      subtype 'Num'
          => as 'Str'
          => where { Scalar::Util::looks_like_number($_) }
          => inline_as {
              # the long Str tests are redundant here
              $value_type->_inline_check($_[1])
              . ' && Scalar::Util::looks_like_number(' . $_[1] . ')'
          };
  
      subtype 'Int'
          => as 'Num'
          => where { (my $val = $_) =~ /\A-?[0-9]+\z/ }
          => inline_as {
              $value_type->_inline_check($_[1])
              . ' && (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/'
          };
  
      subtype 'CodeRef'
          => as 'Ref'
          => where { ref($_) eq 'CODE' }
          => inline_as { 'ref(' . $_[1] . ') eq "CODE"' };
  
      subtype 'RegexpRef'
          => as 'Ref'
          => where( \&_RegexpRef )
          => inline_as {
              'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')'
          };
  
      subtype 'GlobRef'
          => as 'Ref'
          => where { ref($_) eq 'GLOB' }
          => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' };
  
      # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
      # filehandle
      subtype 'FileHandle'
          => as 'Ref'
          => where {
              (ref($_) eq "GLOB" && Scalar::Util::openhandle($_))
           || (blessed($_) && $_->isa("IO::Handle"));
          }
          => inline_as {
              '(ref(' . $_[1] . ') eq "GLOB" '
              . '&& Scalar::Util::openhandle(' . $_[1] . ')) '
              . '|| (Scalar::Util::blessed(' . $_[1] . ') '
              . '&& ' . $_[1] . '->isa("IO::Handle"))'
          };
  
      subtype 'Object'
          => as 'Ref'
          => where { blessed($_) }
          => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };
  
      subtype 'ClassName'
          => as 'Str'
          => where { is_class_loaded($_) }
              # the long Str tests are redundant here
          => inline_as { 'Class::Load::is_class_loaded(' . $_[1] . ')' };
  
      subtype 'RoleName'
          => as 'ClassName'
          => where {
              (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
          }
          => inline_as {
              $_[0]->parent()->_inline_check($_[1])
              . ' && do {'
                  . 'my $meta = Class::MOP::class_of(' . $_[1] . ');'
                  . '$meta && $meta->isa("Moose::Meta::Role");'
              . '}'
          };
  
      $registry->add_type_constraint(
          Moose::Meta::TypeConstraint::Parameterizable->new(
              name               => 'ScalarRef',
              package_defined_in => __PACKAGE__,
              parent =>
                  Moose::Util::TypeConstraints::find_type_constraint('Ref'),
              constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
              constraint_generator => sub {
                  my $type_parameter = shift;
                  my $check = $type_parameter->_compiled_type_constraint;
                  return sub {
                      return $check->( ${$_} );
                  };
              },
              inlined => sub {
                  'ref(' . $_[1] . ') eq "SCALAR" '
                    . '|| ref(' . $_[1] . ') eq "REF"'
              },
              inline_generator => sub {
                  my $self           = shift;
                  my $type_parameter = shift;
                  my $val            = shift;
                  '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") '
                    . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}')
              },
          )
      );
  
      $registry->add_type_constraint(
          Moose::Meta::TypeConstraint::Parameterizable->new(
              name               => 'ArrayRef',
              package_defined_in => __PACKAGE__,
              parent =>
                  Moose::Util::TypeConstraints::find_type_constraint('Ref'),
              constraint => sub { ref($_) eq 'ARRAY' },
              constraint_generator => sub {
                  my $type_parameter = shift;
                  my $check = $type_parameter->_compiled_type_constraint;
                  return sub {
                      foreach my $x (@$_) {
                          ( $check->($x) ) || return;
                      }
                      1;
                      }
              },
              inlined          => sub { 'ref(' . $_[1] . ') eq "ARRAY"' },
              inline_generator => sub {
                  my $self           = shift;
                  my $type_parameter = shift;
                  my $val            = shift;
  
                  'do {'
                      . 'my $check = ' . $val . ';'
                      . 'ref($check) eq "ARRAY" '
                          . '&& &List::MoreUtils::all('
                              . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
                              . '@{$check}'
                          . ')'
                  . '}';
              },
          )
      );
  
      $registry->add_type_constraint(
          Moose::Meta::TypeConstraint::Parameterizable->new(
              name               => 'HashRef',
              package_defined_in => __PACKAGE__,
              parent =>
                  Moose::Util::TypeConstraints::find_type_constraint('Ref'),
              constraint => sub { ref($_) eq 'HASH' },
              constraint_generator => sub {
                  my $type_parameter = shift;
                  my $check = $type_parameter->_compiled_type_constraint;
                  return sub {
                      foreach my $x ( values %$_ ) {
                          ( $check->($x) ) || return;
                      }
                      1;
                      }
              },
              inlined          => sub { 'ref(' . $_[1] . ') eq "HASH"' },
              inline_generator => sub {
                  my $self           = shift;
                  my $type_parameter = shift;
                  my $val            = shift;
  
                  'do {'
                      . 'my $check = ' . $val . ';'
                      . 'ref($check) eq "HASH" '
                          . '&& &List::MoreUtils::all('
                              . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
                              . 'values %{$check}'
                          . ')'
                  . '}';
              },
          )
      );
  
      $registry->add_type_constraint(
          Moose::Meta::TypeConstraint::Parameterizable->new(
              name               => 'Maybe',
              package_defined_in => __PACKAGE__,
              parent =>
                  Moose::Util::TypeConstraints::find_type_constraint('Item'),
              constraint           => sub {1},
              constraint_generator => sub {
                  my $type_parameter = shift;
                  my $check = $type_parameter->_compiled_type_constraint;
                  return sub {
                      return 1 if not( defined($_) ) || $check->($_);
                      return;
                      }
              },
              inlined          => sub {'1'},
              inline_generator => sub {
                  my $self           = shift;
                  my $type_parameter = shift;
                  my $val            = shift;
                  '!defined(' . $val . ') '
                    . '|| (' . $type_parameter->_inline_check($val) . ')'
              },
          )
      );
  }
  
  1;
  
  __END__
  
  =pod
  
  =for pod_coverage_needs_some_pod
  
  =cut
  
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS_BUILTINS

$fatpacked{"darwin-thread-multi-2level/Moose/Util/TypeConstraints/OptimizedConstraints.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS_OPTIMIZEDCONSTRAINTS';
  package Moose::Util::TypeConstraints::OptimizedConstraints;
  
  use strict;
  use warnings;
  
  use Class::MOP;
  use Moose::Deprecated;
  use Scalar::Util 'blessed', 'looks_like_number';
  
  our $VERSION   = '1.20';
  $VERSION = eval $VERSION;
  our $AUTHORITY = 'cpan:STEVAN';
  
  sub Value { defined($_[0]) && !ref($_[0]) }
  
  sub Ref { ref($_[0]) }
  
  # We need to use a temporary here to flatten LVALUEs, for instance as in
  # Str(substr($_,0,255)).
  sub Str {
      my $value = $_[0];
      defined($value) && ref(\$value) eq 'SCALAR'
  }
  
  sub Num { !ref($_[0]) && looks_like_number($_[0]) }
  
  # using a temporary here because regex matching promotes an IV to a PV,
  # and that confuses some things (like JSON.pm)
  sub Int {
      my $value = $_[0];
      defined($value) && !ref($value) && $value =~ /^-?[0-9]+$/
  }
  
  sub ScalarRef { ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' }
  sub ArrayRef  { ref($_[0]) eq 'ARRAY'  }
  sub HashRef   { ref($_[0]) eq 'HASH'   }
  sub CodeRef   { ref($_[0]) eq 'CODE'   }
  sub RegexpRef { ref($_[0]) eq 'Regexp' }
  sub GlobRef   { ref($_[0]) eq 'GLOB'   }
  
  sub FileHandle { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) or blessed($_[0]) && $_[0]->isa("IO::Handle") }
  
  sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
  
  sub Role {
      Moose::Deprecated::deprecated(
          feature => 'Role type',
          message =>
              'The Role type has been deprecated. Maybe you meant to create a RoleName type?'
      );
      blessed( $_[0] ) && $_[0]->can('does');
  }
  
  sub ClassName {
      return Class::MOP::is_class_loaded( $_[0] );
  }
  
  sub RoleName {
      ClassName($_[0])
      && (Class::MOP::class_of($_[0]) || return)->isa('Moose::Meta::Role')
  }
  
  # NOTE:
  # we have XS versions too, ...
  # 04:09 <@konobi> nothingmuch: konobi.co.uk/code/utilsxs.tar.gz
  # 04:09 <@konobi> or utilxs.tar.gz iirc
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Moose::Util::TypeConstraints::OptimizedConstraints - Optimized constraint
  bodies for various moose types
  
  =head1 DESCRIPTION
  
  This file contains the hand optimized versions of Moose type constraints,
  no user serviceable parts inside.
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item C<Value>
  
  =item C<Ref>
  
  =item C<Str>
  
  =item C<Num>
  
  =item C<Int>
  
  =item C<ScalarRef>
  
  =item C<ArrayRef>
  
  =item C<HashRef>
  
  =item C<CodeRef>
  
  =item C<RegexpRef>
  
  =item C<GlobRef>
  
  =item C<FileHandle>
  
  =item C<Object>
  
  =item C<Role>
  
  =item C<ClassName>
  
  =item C<RoleName>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 2007-2009 by Infinity Interactive, Inc.
  
  L<http://www.iinteractive.com>
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_MOOSE_UTIL_TYPECONSTRAINTS_OPTIMIZEDCONSTRAINTS

$fatpacked{"darwin-thread-multi-2level/Package/Stash/XS.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_PACKAGE_STASH_XS';
  package Package::Stash::XS;
  BEGIN {
    $Package::Stash::XS::VERSION = '0.25';
  }
  use strict;
  use warnings;
  # 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.25
  
  =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) 2011 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
  
DARWIN-THREAD-MULTI-2LEVEL_PACKAGE_STASH_XS

$fatpacked{"darwin-thread-multi-2level/Params/Classify.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_PARAMS_CLASSIFY';
  =head1 NAME
  
  Params::Classify - argument type classification
  
  =head1 SYNOPSIS
  
  	use Params::Classify qw(
  		scalar_class
  		is_undef check_undef
  		is_string check_string
  		is_number check_number
  		is_glob check_glob
  		is_regexp check_regexp
  		is_ref check_ref ref_type
  		is_blessed check_blessed blessed_class
  		is_strictly_blessed check_strictly_blessed
  		is_able check_able
  	);
  
  	$c = scalar_class($arg);
  
  	if(is_undef($arg)) {
  	check_undef($arg);
  
  	if(is_string($arg)) {
  	check_string($arg);
  	if(is_number($arg)) {
  	check_number($arg);
  
  	if(is_glob($arg)) {
  	check_glob($arg);
  	if(is_regexp($arg)) {
  	check_regexp($arg);
  
  	if(is_ref($arg)) {
  	check_ref($arg);
  	$t = ref_type($arg);
  	if(is_ref($arg, "HASH")) {
  	check_ref($arg, "HASH");
  
  	if(is_blessed($arg)) {
  	check_blessed($arg);
  	if(is_blessed($arg, "IO::Handle")) {
  	check_blessed($arg, "IO::Handle");
  	$c = blessed_class($arg);
  	if(is_strictly_blessed($arg, "IO::Pipe::End")) {
  	check_strictly_blessed($arg, "IO::Pipe::End");
  	if(is_able($arg, ["print", "flush"])) {
  	check_able($arg, ["print", "flush"]);
  
  =head1 DESCRIPTION
  
  This module provides various type-testing functions.  These are intended
  for functions that, unlike most Perl code, care what type of data they
  are operating on.  For example, some functions wish to behave differently
  depending on the type of their arguments (like overloaded functions
  in C++).
  
  There are two flavours of function in this module.  Functions of the first
  flavour only provide type classification, to allow code to discriminate
  between argument types.  Functions of the second flavour package up the
  most common type of type discrimination: checking that an argument is
  of an expected type.  The functions come in matched pairs, of the two
  flavours, and so the type enforcement functions handle only the simplest
  requirements for arguments of the types handled by the classification
  functions.  Enforcement of more complex types may, of course, be built
  using the classification functions, or it may be more convenient to use
  a module designed for the more complex job, such as L<Params::Validate>.
  
  This module is implemented in XS, with a pure Perl backup version for
  systems that can't handle XS.
  
  =cut
  
  package Params::Classify;
  
  { use 5.006001; }
  use warnings;
  use strict;
  
  our $VERSION = "0.013";
  
  use parent "Exporter";
  our @EXPORT_OK = qw(
  	scalar_class
  	is_undef check_undef
  	is_string check_string
  	is_number check_number
  	is_glob check_glob
  	is_regexp check_regexp
  	is_ref check_ref ref_type
  	is_blessed check_blessed blessed_class
  	is_strictly_blessed check_strictly_blessed
  	is_able check_able
  );
  
  eval { local $SIG{__DIE__};
  	require XSLoader;
  	XSLoader::load(__PACKAGE__, $VERSION);
  };
  
  if($@ eq "") {
  	close(DATA);
  } else {
  	(my $filename = __FILE__) =~ tr# -~##cd;
  	local $/ = undef;
  	my $pp_code = "#line 128 \"$filename\"\n".<DATA>;
  	close(DATA);
  	{
  		local $SIG{__DIE__};
  		eval $pp_code;
  	}
  	die $@ if $@ ne "";
  }
  
  sub is_string($);
  sub is_number($) {
  	return 0 unless &is_string;
  	my $warned;
  	local $SIG{__WARN__} = sub { $warned = 1; };
  	my $arg = $_[0];
  	{ no warnings "void"; 0 + $arg; }
  	return !$warned;
  }
  
  sub check_number($) {
  	die "argument is not a number\n" unless &is_number;
  }
  
  1;
  
  __DATA__
  
  use Scalar::Util 1.01 qw(blessed reftype);
  
  =head1 TYPE CLASSIFICATION
  
  This module divides up scalar values into the following classes:
  
  =over
  
  =item *
  
  undef
  
  =item *
  
  string (defined ordinary scalar)
  
  =item *
  
  typeglob (yes, typeglobs fit into scalar variables)
  
  =item *
  
  regexp (first-class regular expression objects in Perl 5.11 onwards)
  
  =item *
  
  reference to unblessed object (further classified by physical data type
  of the referenced object)
  
  =item *
  
  reference to blessed object (further classified by class blessed into)
  
  =back
  
  These classes are mutually exclusive and should be exhaustive.  This
  classification has been chosen as the most useful when one wishes to
  discriminate between types of scalar.  Other classifications are possible.
  (For example, the two reference classes are distinguished by a feature of
  the referenced object; Perl does not internally treat this as a feature
  of the reference.)
  
  =head1 FUNCTIONS
  
  Each of these functions takes one scalar argument (I<ARG>) to be tested,
  possibly with other arguments specifying details of the test.  Any scalar
  value is acceptable for the argument to be tested.  Each C<is_> function
  returns a simple truth value result, which is true iff I<ARG> is of the
  type being checked for.  Each C<check_> function will return normally
  if the argument is of the type being checked for, or will C<die> if it
  is not.
  
  =head2 Classification
  
  =over
  
  =item scalar_class(ARG)
  
  Determines which of the five classes described above I<ARG> falls into.
  Returns "B<UNDEF>", "B<STRING>", "B<GLOB>", "B<REGEXP>", "B<REF>", or
  "B<BLESSED>" accordingly.
  
  =cut
  
  sub scalar_class($) {
  	my $type = reftype(\$_[0]);
  	if($type eq "SCALAR") {
  		$type = defined($_[0]) ? "STRING" : "UNDEF";
  	} elsif($type eq "REF") {
  		$type = "BLESSED" if defined(blessed($_[0]));
  	}
  	$type;
  }
  
  =back
  
  =head2 The Undefined Value
  
  =over
  
  =item is_undef(ARG)
  
  =item check_undef(ARG)
  
  Check whether I<ARG> is C<undef>.  C<is_undef(ARG)> is precisely
  equivalent to C<!defined(ARG)>, and is included for completeness.
  
  =cut
  
  sub is_undef($) { !defined($_[0]) }
  
  sub check_undef($) {
  	die "argument is not undefined\n" unless &is_undef;
  }
  
  =back
  
  =head2 Strings
  
  =over
  
  =item is_string(ARG)
  
  =item check_string(ARG)
  
  Check whether I<ARG> is defined and is an ordinary scalar value (not a
  reference, typeglob, or regexp).  This is what one usually thinks of as a
  string in Perl.  In fact, any scalar (including C<undef> and references)
  can be coerced to a string, but if you're trying to classify a scalar
  then you don't want to do that.
  
  =cut
  
  sub is_string($) { defined($_[0]) && reftype(\$_[0]) eq "SCALAR" }
  
  sub check_string($) {
  	die "argument is not a string\n" unless &is_string;
  }
  
  =item is_number(ARG)
  
  =item check_number(ARG)
  
  Check whether I<ARG> is defined and an ordinary scalar (i.e.,
  satisfies L</is_string> above) and is an acceptable number to Perl.
  This is what one usually thinks of as a number.
  
  Note that simple (L</is_string>-satisfying) scalars may have independent
  numeric and string values, despite the usual pretence that they have
  only one value.  Such a scalar is deemed to be a number if I<either> it
  already has a numeric value (e.g., was generated by a numeric literal
  or an arithmetic computation) I<or> its string value has acceptable
  syntax for a number (so it can be converted).  Where a scalar has
  separate numeric and string values (see L<Scalar::Util/dualvar>), it is
  possible for it to have an acceptable numeric value while its string
  value does I<not> have acceptable numeric syntax.  Be careful to use
  such a value only in a numeric context, if you are using it as a number.
  L<Scalar::Number/scalar_num_part> extracts the numeric part of a
  scalar as an ordinary number.  (C<0+ARG> suffices for that unless you
  need to preserve floating point signed zeroes.)
  
  A number may be either a native integer or a native floating point
  value, and there are several subtypes of floating point value.
  For classification, and other handling of numbers in scalars, see
  L<Scalar::Number>.  For details of the two numeric data types, see
  L<Data::Integer> and L<Data::Float>.
  
  This function differs from C<looks_like_number> (see
  L<Scalar::Util/looks_like_number>; also L<perlapi/looks_like_number>
  for a lower-level description) in excluding C<undef>, typeglobs,
  and references.  Why C<looks_like_number> returns true for C<undef>
  or typeglobs is anybody's guess.  References, if treated as numbers,
  evaluate to the address in memory that they reference; this is useful
  for comparing references for equality, but it is not otherwise useful
  to treat references as numbers.  Blessed references may have overloaded
  numeric operators, but if so then they don't necessarily behave like
  ordinary numbers.  C<looks_like_number> is also confused by dualvars:
  it looks at the string portion of the scalar.
  
  =back
  
  =head2 Typeglobs
  
  =over
  
  =item is_glob(ARG)
  
  =item check_glob(ARG)
  
  Check whether I<ARG> is a typeglob.
  
  =cut
  
  sub is_glob($) { reftype(\$_[0]) eq "GLOB" }
  
  sub check_glob($) {
  	die "argument is not a typeglob\n" unless &is_glob;
  }
  
  =back
  
  =head2 Regexps
  
  =over
  
  =item is_regexp(ARG)
  
  =item check_regexp(ARG)
  
  Check whether I<ARG> is a regexp object.
  
  =cut
  
  sub is_regexp($) { reftype(\$_[0]) eq "REGEXP" }
  
  sub check_regexp($) {
  	die "argument is not a regexp\n" unless &is_regexp;
  }
  
  =back
  
  =head2 References to Unblessed Objects
  
  =over
  
  =item is_ref(ARG)
  
  =item check_ref(ARG)
  
  Check whether I<ARG> is a reference to an unblessed object.  If it
  is, then the referenced data type can be determined using C<ref_type>
  (see below), which will return a string such as "HASH" or "SCALAR".
  
  =item ref_type(ARG)
  
  Returns C<undef> if I<ARG> is not a reference to an unblessed object.
  Otherwise, determines what type of object is referenced.  Returns
  "B<SCALAR>", "B<ARRAY>", "B<HASH>", "B<CODE>", "B<FORMAT>", or "B<IO>"
  accordingly.
  
  Note that, unlike C<ref>, this does not distinguish between different
  types of referenced scalar.  A reference to a string and a reference to
  a reference will both return "B<SCALAR>".  Consequently, what C<ref_type>
  returns for a particular reference will not change due to changes in
  the value of the referent, except for the referent being blessed.
  
  =item is_ref(ARG, TYPE)
  
  =item check_ref(ARG, TYPE)
  
  Check whether I<ARG> is a reference to an unblessed object of type
  I<TYPE>, as determined by L</ref_type>.  I<TYPE> must be a string.
  Possible I<TYPE>s are "B<SCALAR>", "B<ARRAY>", "B<HASH>", "B<CODE>",
  "B<FORMAT>", and "B<IO>".
  
  =cut
  
  {
  	my %xlate_reftype = (
  		REF    => "SCALAR",
  		SCALAR => "SCALAR",
  		LVALUE => "SCALAR",
  		GLOB   => "SCALAR",
  		REGEXP => "SCALAR",
  		ARRAY  => "ARRAY",
  		HASH   => "HASH",
  		CODE   => "CODE",
  		FORMAT => "FORMAT",
  		IO     => "IO",
  	);
  
  	my %reftype_ok = map { ($_ => undef) } qw(
  		SCALAR ARRAY HASH CODE FORMAT IO
  	);
  
  	sub ref_type($) {
  		my $reftype = &reftype;
  		return undef unless
  			defined($reftype) && !defined(blessed($_[0]));
  		my $xlated_reftype = $xlate_reftype{$reftype};
  		die "unknown reftype `$reftype', please update Params::Classify"
  			unless defined $xlated_reftype;
  		$xlated_reftype;
  	}
  
  	sub is_ref($;$) {
  		if(@_ == 2) {
  			die "reference type argument is not a string\n"
  				unless is_string($_[1]);
  			die "invalid reference type\n"
  				unless exists $reftype_ok{$_[1]};
  		}
  		my $reftype = reftype($_[0]);
  		return undef unless
  			defined($reftype) && !defined(blessed($_[0]));
  		return 1 if @_ != 2;
  		my $xlated_reftype = $xlate_reftype{$reftype};
  		die "unknown reftype `$reftype', please update Params::Classify"
  			unless defined $xlated_reftype;
  		return $xlated_reftype eq $_[1];
  	}
  }
  
  sub check_ref($;$) {
  	unless(&is_ref) {
  		die "argument is not a reference to plain ".
  			(@_ == 2 ? lc($_[1]) : "object")."\n";
  	}
  }
  
  =back
  
  =head2 References to Blessed Objects
  
  =over
  
  =item is_blessed(ARG)
  
  =item check_blessed(ARG)
  
  Check whether I<ARG> is a reference to a blessed object.  If it is,
  then the class into which the object was blessed can be determined using
  L</blessed_class>.
  
  =item is_blessed(ARG, CLASS)
  
  =item check_blessed(ARG, CLASS)
  
  Check whether I<ARG> is a reference to a blessed object that claims to
  be an instance of I<CLASS> (via its C<isa> method; see L<perlobj/isa>).
  I<CLASS> must be a string, naming a Perl class.
  
  =cut
  
  sub is_blessed($;$) {
  	die "class argument is not a string\n"
  		if @_ == 2 && !is_string($_[1]);
  	return defined(blessed($_[0])) && (@_ != 2 || $_[0]->isa($_[1]));
  }
  
  sub check_blessed($;$) {
  	unless(&is_blessed) {
  		die "argument is not a reference to blessed ".
  			(@_ == 2 ? $_[1] : "object")."\n";
  	}
  }
  
  =item blessed_class(ARG)
  
  Returns C<undef> if I<ARG> is not a reference to a blessed object.
  Otherwise, returns the class into which the object is blessed.
  
  C<ref> (see L<perlfunc/ref>) gives the same result on references
  to blessed objects, but different results on other types of value.
  C<blessed_class> is actually identical to L<Scalar::Util/blessed>.
  
  =cut
  
  *blessed_class = \&blessed;
  
  =item is_strictly_blessed(ARG)
  
  =item check_strictly_blessed(ARG)
  
  Check whether I<ARG> is a reference to a blessed object, identically
  to L</is_blessed>.  This exists only for symmetry; the useful form of
  C<is_strictly_blessed> appears below.
  
  =item is_strictly_blessed(ARG, CLASS)
  
  =item check_strictly_blessed(ARG, CLASS)
  
  Check whether I<ARG> is a reference to an object blessed into I<CLASS>
  exactly.  I<CLASS> must be a string, naming a Perl class.  Because this
  excludes subclasses, this is rarely what one wants, but there are some
  specialised occasions where it is useful.
  
  =cut
  
  sub is_strictly_blessed($;$) {
  	return &is_blessed unless @_ == 2;
  	die "class argument is not a string\n" unless is_string($_[1]);
  	my $blessed = blessed($_[0]);
  	return defined($blessed) && $blessed eq $_[1];
  }
  
  sub check_strictly_blessed($;$) {
  	return &check_blessed unless @_ == 2;
  	unless(&is_strictly_blessed) {
  		die "argument is not a reference to strictly blessed $_[1]\n";
  	}
  }
  
  =item is_able(ARG)
  
  =item check_able(ARG)
  
  Check whether I<ARG> is a reference to a blessed object, identically
  to L</is_blessed>.  This exists only for symmetry; the useful form of
  C<is_able> appears below.
  
  =item is_able(ARG, METHODS)
  
  =item check_able(ARG, METHODS)
  
  Check whether I<ARG> is a reference to a blessed object that claims to
  implement the methods specified by I<METHODS> (via its C<can> method;
  see L<perlobj/can>).  I<METHODS> must be either a single method name or
  a reference to an array of method names.  Each method name is a string.
  This interface check is often more appropriate than a direct ancestry
  check (such as L</is_blessed> performs).
  
  =cut
  
  sub _check_methods_arg($) {
  	return if &is_string;
  	die "methods argument is not a string or array\n"
  		unless is_ref($_[0], "ARRAY");
  	foreach(@{$_[0]}) {
  		die "method name is not a string\n" unless is_string($_);
  	}
  }
  
  sub is_able($;$) {
  	return &is_blessed unless @_ == 2;
  	_check_methods_arg($_[1]);
  	return 0 unless defined blessed $_[0];
  	foreach my $method (ref($_[1]) eq "" ? $_[1] : @{$_[1]}) {
  		return 0 unless $_[0]->can($method);
  	}
  	return 1;
  }
  
  sub check_able($;$) {
  	return &check_blessed unless @_ == 2;
  	_check_methods_arg($_[1]);
  	unless(defined blessed $_[0]) {
  		my $desc = ref($_[1]) eq "" ?
  				"method \"$_[1]\""
  			: @{$_[1]} == 0 ?
  				"at all"
  			:
  				"method \"".$_[1]->[0]."\"";
  		die "argument is not able to perform $desc\n";
  	}
  	foreach my $method (ref($_[1]) eq "" ? $_[1] : @{$_[1]}) {
  		die "argument is not able to perform method \"$method\"\n"
  			unless $_[0]->can($method);
  	}
  }
  
  =back
  
  =head1 BUGS
  
  Probably ought to handle something like L<Params::Validate>'s scalar
  type specification system, which makes much the same distinctions.
  
  =head1 SEE ALSO
  
  L<Data::Float>,
  L<Data::Integer>,
  L<Params::Validate>,
  L<Scalar::Number>,
  L<Scalar::Util>
  
  =head1 AUTHOR
  
  Andrew Main (Zefram) <zefram@fysh.org>
  
  =head1 COPYRIGHT
  
  Copyright (C) 2004, 2006, 2007, 2009, 2010
  Andrew Main (Zefram) <zefram@fysh.org>
  
  Copyright (C) 2009, 2010 PhotoBox Ltd
  
  =head1 LICENSE
  
  This module is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =cut
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_PARAMS_CLASSIFY

$fatpacked{"darwin-thread-multi-2level/Params/Util.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_PARAMS_UTIL';
  package Params::Util;
  
  =pod
  
  =head1 NAME
  
  Params::Util - Simple, compact and correct param-checking functions
  
  =head1 SYNOPSIS
  
    # Import some functions
    use Params::Util qw{_SCALAR _HASH _INSTANCE};
    
    # If you are lazy, or need a lot of them...
    use Params::Util ':ALL';
    
    sub foo {
        my $object  = _INSTANCE(shift, 'Foo') or return undef;
        my $image   = _SCALAR(shift)          or return undef;
        my $options = _HASH(shift)            or return undef;
        # etc...
    }
  
  =head1 DESCRIPTION
  
  C<Params::Util> provides a basic set of importable functions that makes
  checking parameters a hell of a lot easier
  
  While they can be (and are) used in other contexts, the main point
  behind this module is that the functions B<both> Do What You Mean,
  and Do The Right Thing, so they are most useful when you are getting
  params passed into your code from someone and/or somewhere else
  and you can't really trust the quality.
  
  Thus, C<Params::Util> is of most use at the edges of your API, where
  params and data are coming in from outside your code.
  
  The functions provided by C<Params::Util> check in the most strictly
  correct manner known, are documented as thoroughly as possible so their
  exact behaviour is clear, and heavily tested so make sure they are not
  fooled by weird data and Really Bad Things.
  
  To use, simply load the module providing the functions you want to use
  as arguments (as shown in the SYNOPSIS).
  
  To aid in maintainability, C<Params::Util> will B<never> export by
  default.
  
  You must explicitly name the functions you want to export, or use the
  C<:ALL> param to just have it export everything (although this is not
  recommended if you have any _FOO functions yourself with which future
  additions to C<Params::Util> may clash)
  
  =head1 FUNCTIONS
  
  =cut
  
  use 5.00503;
  use strict;
  require overload;
  require Exporter;
  require Scalar::Util;
  require DynaLoader;
  
  use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS};
  
  $VERSION   = '1.01';
  @ISA       = qw{
  	Exporter
  	DynaLoader
  };
  @EXPORT_OK = qw{
  	_STRING     _IDENTIFIER
  	_CLASS      _CLASSISA   _SUBCLASS  _DRIVER
  	_NUMBER     _POSINT     _NONNEGINT
  	_SCALAR     _SCALAR0
  	_ARRAY      _ARRAY0     _ARRAYLIKE
  	_HASH       _HASH0      _HASHLIKE
  	_CODE       _CODELIKE
  	_INVOCANT   _REGEX      _INSTANCE
  	_SET        _SET0
  	_HANDLE
  };
  %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
  
  eval {
  	local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
  	bootstrap Params::Util $VERSION;
  	1;
  } unless $ENV{PERL_PARAMS_UTIL_PP};
  
  
  
  
  
  #####################################################################
  # Param Checking Functions
  
  =pod
  
  =head2 _STRING $string
  
  The C<_STRING> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a normal non-false string of non-zero length.
  
  Note that this will NOT do anything magic to deal with the special
  C<'0'> false negative case, but will return it.
  
    # '0' not considered valid data
    my $name = _STRING(shift) or die "Bad name";
    
    # '0' is considered valid data
    my $string = _STRING($_[0]) ? shift : die "Bad string";
  
  Please also note that this function expects a normal string. It does
  not support overloading or other magic techniques to get a string.
  
  Returns the string as a conveince if it is a valid string, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_STRING;
  sub _STRING ($) {
  	(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _IDENTIFIER $string
  
  The C<_IDENTIFIER> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a valid Perl identifier.
  
  Returns the string as a convenience if it is a valid identifier, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_IDENTIFIER;
  sub _IDENTIFIER ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CLASS $string
  
  The C<_CLASS> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a valid Perl class.
  
  This function only checks that the format is valid, not that the
  class is actually loaded. It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CLASS;
  sub _CLASS ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CLASSISA $string, $class
  
  The C<_CLASSISA> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a particularly class, or a subclass of it.
  
  This function checks that the format is valid and calls the -E<gt>isa
  method on the class name. It does not check that the class is actually
  loaded.
  
  It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CLASSISA;
  sub _CLASSISA ($$) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SUBCLASS $string, $class
  
  The C<_SUBCLASS> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a string that is a subclass of a specified class.
  
  This function checks that the format is valid and calls the -E<gt>isa
  method on the class name. It does not check that the class is actually
  loaded.
  
  It also assumes "normalised" form, and does
  not accept class names such as C<::Foo> or C<D'Oh>.
  
  Returns the string as a convenience if it is a valid class name, or
  C<undef> if not.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SUBCLASS;
  sub _SUBCLASS ($$) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _NUMBER $scalar
  
  The C<_NUMBER> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a number. That is, it is defined and perl thinks it's a number.
  
  This function is basically a Params::Util-style wrapper around the
  L<Scalar::Util> C<looks_like_number> function.
  
  Returns the value as a convience, or C<undef> if the value is not a
  number.
  
  =cut
  
  eval <<'END_PERL' unless defined &_NUMBER;
  sub _NUMBER ($) {
  	( defined $_[0] and ! ref $_[0] and Scalar::Util::looks_like_number($_[0]) )
  	? $_[0]
  	: undef;
  }
  END_PERL
  
  =pod
  
  =head2 _POSINT $integer
  
  The C<_POSINT> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a positive integer (of any length).
  
  Returns the value as a convience, or C<undef> if the value is not a
  positive integer.
  
  The name itself is derived from the XML schema constraint of the same
  name.
  
  =cut
  
  eval <<'END_PERL' unless defined &_POSINT;
  sub _POSINT ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _NONNEGINT $integer
  
  The C<_NONNEGINT> function is intended to be imported into your
  package, and provides a convenient way to test to see if a value is
  a non-negative integer (of any length). That is, a positive integer,
  or zero.
  
  Returns the value as a convience, or C<undef> if the value is not a
  non-negative integer.
  
  As with other tests that may return false values, care should be taken
  to test via "defined" in boolean validy contexts.
  
    unless ( defined _NONNEGINT($value) ) {
       die "Invalid value";
    }
  
  The name itself is derived from the XML schema constraint of the same
  name.
  
  =cut
  
  eval <<'END_PERL' unless defined &_NONNEGINT;
  sub _NONNEGINT ($) {
  	(defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SCALAR \$scalar
  
  The C<_SCALAR> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<SCALAR> reference, with content of non-zero length.
  
  For a version that allows zero length C<SCALAR> references, see
  the C<_SCALAR0> function.
  
  Returns the C<SCALAR> reference itself as a convenience, or C<undef>
  if the value provided is not a C<SCALAR> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SCALAR;
  sub _SCALAR ($) {
  	(ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SCALAR0 \$scalar
  
  The C<_SCALAR0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<SCALAR0> reference, allowing content of zero-length.
  
  For a simpler "give me some content" version that requires non-zero
  length, C<_SCALAR> function.
  
  Returns the C<SCALAR> reference itself as a convenience, or C<undef>
  if the value provided is not a C<SCALAR> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SCALAR0;
  sub _SCALAR0 ($) {
  	ref $_[0] eq 'SCALAR' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAY $value
  
  The C<_ARRAY> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<ARRAY> reference containing B<at least> one element of any kind.
  
  For a more basic form that allows zero length ARRAY references, see
  the C<_ARRAY0> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef>
  if the value provided is not an C<ARRAY> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAY;
  sub _ARRAY ($) {
  	(ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAY0 $value
  
  The C<_ARRAY0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<ARRAY> reference, allowing C<ARRAY> references that contain no
  elements.
  
  For a more basic "An array of something" form that also requires at
  least one element, see the C<_ARRAY> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef>
  if the value provided is not an C<ARRAY> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAY0;
  sub _ARRAY0 ($) {
  	ref $_[0] eq 'ARRAY' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _ARRAYLIKE $value
  
  The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
  array dereferencing.  If it can, the value is returned.  If it cannot,
  C<_ARRAYLIKE> returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_ARRAYLIKE;
  sub _ARRAYLIKE {
  	(defined $_[0] and ref $_[0] and (
  		(Scalar::Util::reftype($_[0]) eq 'ARRAY')
  		or
  		overload::Method($_[0], '@{}')
  	)) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASH $value
  
  The C<_HASH> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<HASH> reference with at least one entry.
  
  For a version of this function that allows the C<HASH> to be empty,
  see the C<_HASH0> function.
  
  Returns the C<HASH> reference itself as a convenience, or C<undef>
  if the value provided is not an C<HASH> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASH;
  sub _HASH ($) {
  	(ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASH0 $value
  
  The C<_HASH0> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<HASH> reference, regardless of the C<HASH> content.
  
  For a simpler "A hash of something" version that requires at least one
  element, see the C<_HASH> function.
  
  Returns the C<HASH> reference itself as a convenience, or C<undef>
  if the value provided is not an C<HASH> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASH0;
  sub _HASH0 ($) {
  	ref $_[0] eq 'HASH' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _HASHLIKE $value
  
  The C<_HASHLIKE> function tests whether a given scalar value can respond to
  hash dereferencing.  If it can, the value is returned.  If it cannot,
  C<_HASHLIKE> returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_HASHLIKE;
  sub _HASHLIKE {
  	(defined $_[0] and ref $_[0] and (
  		(Scalar::Util::reftype($_[0]) eq 'HASH')
  		or
  		overload::Method($_[0], '%{}')
  	)) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CODE $value
  
  The C<_CODE> function is intended to be imported into your package,
  and provides a convenient way to test for a raw and unblessed
  C<CODE> reference.
  
  Returns the C<CODE> reference itself as a convenience, or C<undef>
  if the value provided is not an C<CODE> reference.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CODE;
  sub _CODE ($) {
  	ref $_[0] eq 'CODE' ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _CODELIKE $value
  
  The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
  which checks for an explicit C<CODE> reference, the C<_CODELIKE> function
  also includes things that act like them, such as blessed objects that
  overload C<'&{}'>.
  
  Please note that in the case of objects overloaded with '&{}', you will
  almost always end up also testing it in 'bool' context at some stage.
  
  For example:
  
    sub foo {
        my $code1 = _CODELIKE(shift) or die "No code param provided";
        my $code2 = _CODELIKE(shift);
        if ( $code2 ) {
             print "Got optional second code param";
        }
    }
  
  As such, you will most likely always want to make sure your class has
  at least the following to allow it to evaluate to true in boolean
  context.
  
    # Always evaluate to true in boolean context
    use overload 'bool' => sub () { 1 };
  
  Returns the callable value as a convenience, or C<undef> if the
  value provided is not callable.
  
  Note - This function was formerly known as _CALLABLE but has been renamed
  for greater symmetry with the other _XXXXLIKE functions.
  
  The use of _CALLABLE has been deprecated. It will continue to work, but
  with a warning, until end-2006, then will be removed.
  
  I apologise for any inconvenience caused.
  
  =cut
  
  eval <<'END_PERL' unless defined &_CODELIKE;
  sub _CODELIKE($) {
  	(
  		(Scalar::Util::reftype($_[0])||'') eq 'CODE'
  		or
  		Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
  	)
  	? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _INVOCANT $value
  
  This routine tests whether the given value is a valid method invocant.
  This can be either an instance of an object, or a class name.
  
  If so, the value itself is returned.  Otherwise, C<_INVOCANT>
  returns C<undef>.
  
  =cut
  
  eval <<'END_PERL' unless defined &_INVOCANT;
  sub _INVOCANT($) {
  	(defined $_[0] and
  		(defined Scalar::Util::blessed($_[0])
  		or      
  		# We used to check for stash definedness, but any class-like name is a
  		# valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
  		Params::Util::_CLASS($_[0]))
  	) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _INSTANCE $object, $class
  
  The C<_INSTANCE> function is intended to be imported into your package,
  and provides a convenient way to test for an object of a particular class
  in a strictly correct manner.
  
  Returns the object itself as a convenience, or C<undef> if the value
  provided is not an object of that type.
  
  =cut
  
  eval <<'END_PERL' unless defined &_INSTANCE;
  sub _INSTANCE ($$) {
  	(Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _REGEX $value
  
  The C<_REGEX> function is intended to be imported into your package,
  and provides a convenient way to test for a regular expression.
  
  Returns the value itself as a convenience, or C<undef> if the value
  provided is not a regular expression.
  
  =cut
  
  eval <<'END_PERL' unless defined &_REGEX;
  sub _REGEX ($) {
  	(defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
  }
  END_PERL
  
  =pod
  
  =head2 _SET \@array, $class
  
  The C<_SET> function is intended to be imported into your package,
  and provides a convenient way to test for set of at least one object of
  a particular class in a strictly correct manner.
  
  The set is provided as a reference to an C<ARRAY> of objects of the
  class provided.
  
  For an alternative function that allows zero-length sets, see the
  C<_SET0> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
  the value provided is not a set of that class.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SET;
  sub _SET ($$) {
  	my $set = shift;
  	_ARRAY($set) or return undef;
  	foreach my $item ( @$set ) {
  		_INSTANCE($item,$_[0]) or return undef;
  	}
  	$set;
  }
  END_PERL
  
  =pod
  
  =head2 _SET0 \@array, $class
  
  The C<_SET0> function is intended to be imported into your package,
  and provides a convenient way to test for a set of objects of a
  particular class in a strictly correct manner, allowing for zero objects.
  
  The set is provided as a reference to an C<ARRAY> of objects of the
  class provided.
  
  For an alternative function that requires at least one object, see the
  C<_SET> function.
  
  Returns the C<ARRAY> reference itself as a convenience, or C<undef> if
  the value provided is not a set of that class.
  
  =cut
  
  eval <<'END_PERL' unless defined &_SET0;
  sub _SET0 ($$) {
  	my $set = shift;
  	_ARRAY0($set) or return undef;
  	foreach my $item ( @$set ) {
  		_INSTANCE($item,$_[0]) or return undef;
  	}
  	$set;
  }
  END_PERL
  
  =pod
  
  =head2 _HANDLE
  
  The C<_HANDLE> function is intended to be imported into your package,
  and provides a convenient way to test whether or not a single scalar
  value is a file handle.
  
  Unfortunately, in Perl the definition of a file handle can be a little
  bit fuzzy, so this function is likely to be somewhat imperfect (at first
  anyway).
  
  That said, it is implement as well or better than the other file handle
  detectors in existance (and we stole from the best of them).
  
  =cut
  
  # We're doing this longhand for now. Once everything is perfect,
  # we'll compress this into something that compiles more efficiently.
  # Further, testing file handles is not something that is generally
  # done millions of times, so doing it slowly is not a big speed hit.
  eval <<'END_PERL' unless defined &_HANDLE;
  sub _HANDLE {
  	my $it = shift;
  
  	# It has to be defined, of course
  	unless ( defined $it ) {
  		return undef;
  	}
  
  	# Normal globs are considered to be file handles
  	if ( ref $it eq 'GLOB' ) {
  		return $it;
  	}
  
  	# Check for a normal tied filehandle
  	# Side Note: 5.5.4's tied() and can() doesn't like getting undef
  	if ( tied($it) and tied($it)->can('TIEHANDLE') ) {
  		return $it;
  	}
  
  	# There are no other non-object handles that we support
  	unless ( Scalar::Util::blessed($it) ) {
  		return undef;
  	}
  
  	# Check for a common base classes for conventional IO::Handle object
  	if ( $it->isa('IO::Handle') ) {
  		return $it;
  	}
  
  
  	# Check for tied file handles using Tie::Handle
  	if ( $it->isa('Tie::Handle') ) {
  		return $it;
  	}
  
  	# IO::Scalar is not a proper seekable, but it is valid is a
  	# regular file handle
  	if ( $it->isa('IO::Scalar') ) {
  		return $it;
  	}
  
  	# Yet another special case for IO::String, which refuses (for now
  	# anyway) to become a subclass of IO::Handle.
  	if ( $it->isa('IO::String') ) {
  		return $it;
  	}
  
  	# This is not any sort of object we know about
  	return undef;
  }
  END_PERL
  
  =pod
  
  =head2 _DRIVER $string
  
    sub foo {
      my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
      ...
    }
  
  The C<_DRIVER> function is intended to be imported into your
  package, and provides a convenient way to load and validate
  a driver class.
  
  The most common pattern when taking a driver class as a parameter
  is to check that the name is a class (i.e. check against _CLASS)
  and then to load the class (if it exists) and then ensure that
  the class returns true for the isa method on some base driver name.
  
  Return the value as a convenience, or C<undef> if the value is not
  a class name, the module does not exist, the module does not load,
  or the class fails the isa test.
  
  =cut
  
  eval <<'END_PERL' unless defined &_DRIVER;
  sub _DRIVER ($$) {
  	(defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
  }
  END_PERL
  
  1;
  
  =pod
  
  =head1 TO DO
  
  - Add _CAN to help resolve the UNIVERSAL::can debacle
  
  - Would be even nicer if someone would demonstrate how the hell to
  build a Module::Install dist of the ::Util dual Perl/XS type. :/
  
  - Implement an assertion-like version of this module, that dies on
  error.
  
  - Implement a Test:: version of this module, for use in testing
  
  =head1 SUPPORT
  
  Bugs should be reported via the CPAN bug tracker at
  
  L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util>
  
  For other issues, contact the author.
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Params::Validate>
  
  =head1 COPYRIGHT
  
  Copyright 2005 - 2010 Adam Kennedy.
  
  This program is free software; you can redistribute
  it and/or modify it under the same terms as Perl itself.
  
  The full text of the license can be found in the
  LICENSE file included with this module.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_PARAMS_UTIL

$fatpacked{"darwin-thread-multi-2level/Scalar/Util.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_SCALAR_UTIL';
  # Scalar::Util.pm
  #
  # Copyright (c) 1997-2007 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 Scalar::Util;
  
  use strict;
  use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL);
  require Exporter;
  require List::Util; # List::Util loads the XS
  
  @ISA       = qw(Exporter);
  @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
  $VERSION    = "1.23";
  $VERSION   = eval $VERSION;
  
  unless (defined &dualvar) {
    # Load Pure Perl version if XS not loaded
    require Scalar::Util::PP;
    Scalar::Util::PP->import;
    push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
  }
  
  sub export_fail {
    if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded
      my $pat = join("|", @EXPORT_FAIL);
      if (my ($err) = grep { /^($pat)$/ } @_ ) {
        require Carp;
        Carp::croak("$err is only available with the XS version of Scalar::Util");
      }
    }
  
    if (grep { /^(weaken|isweak)$/ } @_ ) {
      require Carp;
      Carp::croak("Weak references are not implemented in the version of perl");
    }
  
    if (grep { /^(isvstring)$/ } @_ ) {
      require Carp;
      Carp::croak("Vstrings are not implemented in the version of perl");
    }
  
    @_;
  }
  
  sub openhandle ($) {
    my $fh = shift;
    my $rt = reftype($fh) || '';
  
    return defined(fileno($fh)) ? $fh : undef
      if $rt eq 'IO';
  
    if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
      $fh = \(my $tmp=$fh);
    }
    elsif ($rt ne 'GLOB') {
      return undef;
    }
  
    (tied(*$fh) or defined(fileno($fh)))
      ? $fh : undef;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Scalar::Util - A selection of general-utility scalar subroutines
  
  =head1 SYNOPSIS
  
      use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
                          weaken isvstring looks_like_number set_prototype);
                          # and other useful utils appearing below
  
  =head1 DESCRIPTION
  
  C<Scalar::Util> contains a selection of subroutines that people have
  expressed would be nice to have in the perl core, but the usage would
  not really be high enough to warrant the use of a keyword, and the size
  so small such that being individual extensions would be wasteful.
  
  By default C<Scalar::Util> does not export any subroutines. The
  subroutines defined are
  
  =over 4
  
  =item blessed EXPR
  
  If EXPR evaluates to a blessed reference the name of the package
  that it is blessed into is returned. Otherwise C<undef> is returned.
  
     $scalar = "foo";
     $class  = blessed $scalar;           # undef
  
     $ref    = [];
     $class  = blessed $ref;              # undef
  
     $obj    = bless [], "Foo";
     $class  = blessed $obj;              # "Foo"
  
  =item dualvar NUM, STRING
  
  Returns a scalar that has the value NUM in a numeric context and the
  value STRING in a string context.
  
      $foo = dualvar 10, "Hello";
      $num = $foo + 2;                    # 12
      $str = $foo . " world";             # Hello world
  
  =item isvstring EXPR
  
  If EXPR is a scalar which was coded as a vstring the result is true.
  
      $vs   = v49.46.48;
      $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
      printf($fmt,$vs);
  
  =item isweak EXPR
  
  If EXPR is a scalar which is a weak reference the result is true.
  
      $ref  = \$foo;
      $weak = isweak($ref);               # false
      weaken($ref);
      $weak = isweak($ref);               # true
  
  B<NOTE>: Copying a weak reference creates a normal, strong, reference.
  
      $copy = $ref;
      $weak = isweak($copy);              # false
  
  =item looks_like_number EXPR
  
  Returns true if perl thinks EXPR is a number. See
  L<perlapi/looks_like_number>.
  
  =item openhandle FH
  
  Returns FH if FH may be used as a filehandle and is open, or FH is a tied
  handle. Otherwise C<undef> is returned.
  
      $fh = openhandle(*STDIN);		# \*STDIN
      $fh = openhandle(\*STDIN);		# \*STDIN
      $fh = openhandle(*NOTOPEN);		# undef
      $fh = openhandle("scalar");		# undef
      
  =item readonly SCALAR
  
  Returns true if SCALAR is readonly.
  
      sub foo { readonly($_[0]) }
  
      $readonly = foo($bar);              # false
      $readonly = foo(0);                 # true
  
  =item refaddr EXPR
  
  If EXPR evaluates to a reference the internal memory address of
  the referenced value is returned. Otherwise C<undef> is returned.
  
      $addr = refaddr "string";           # undef
      $addr = refaddr \$var;              # eg 12345678
      $addr = refaddr [];                 # eg 23456784
  
      $obj  = bless {}, "Foo";
      $addr = refaddr $obj;               # eg 88123488
  
  =item reftype EXPR
  
  If EXPR evaluates to a reference the type of the variable referenced
  is returned. Otherwise C<undef> is returned.
  
      $type = reftype "string";           # undef
      $type = reftype \$var;              # SCALAR
      $type = reftype [];                 # ARRAY
  
      $obj  = bless {}, "Foo";
      $type = reftype $obj;               # HASH
  
  =item set_prototype CODEREF, PROTOTYPE
  
  Sets the prototype of the given function, or deletes it if PROTOTYPE is
  undef. Returns the CODEREF.
  
      set_prototype \&foo, '$$';
  
  =item tainted EXPR
  
  Return true if the result of EXPR is tainted
  
      $taint = tainted("constant");       # false
      $taint = tainted($ENV{PWD});        # true if running under -T
  
  =item weaken REF
  
  REF will be turned into a weak reference. This means that it will not
  hold a reference count on the object it references. Also when the reference
  count on that object reaches zero, REF will be set to undef.
  
  This is useful for keeping copies of references , but you don't want to
  prevent the object being DESTROY-ed at its usual time.
  
      {
        my $var;
        $ref = \$var;
        weaken($ref);                     # Make $ref a weak reference
      }
      # $ref is now undef
  
  Note that if you take a copy of a scalar with a weakened reference,
  the copy will be a strong reference.
  
      my $var;
      my $foo = \$var;
      weaken($foo);                       # Make $foo a weak reference
      my $bar = $foo;                     # $bar is now a strong reference
  
  This may be less obvious in other situations, such as C<grep()>, for instance
  when grepping through a list of weakened references to objects that may have
  been destroyed already:
  
      @object = grep { defined } @object;
  
  This will indeed remove all references to destroyed objects, but the remaining
  references to objects will be strong, causing the remaining objects to never
  be destroyed because there is now always a strong reference to them in the
  @object array.
  
  =back
  
  =head1 DIAGNOSTICS
  
  Module use may give one of the following errors during import.
  
  =over
  
  =item Weak references are not implemented in the version of perl
  
  The version of perl that you are using does not implement weak references, to use
  C<isweak> or C<weaken> you will need to use a newer release of perl.
  
  =item Vstrings are not implemented in the version of perl
  
  The version of perl that you are using does not implement Vstrings, to use
  C<isvstring> you will need to use a newer release of perl.
  
  =item C<NAME> is only available with the XS version of Scalar::Util
  
  C<Scalar::Util> contains both perl and C implementations of many of its functions
  so that those without access to a C compiler may still use it. However some of the functions
  are only available when a C compiler was available to compile the XS version of the extension.
  
  At present that list is: weaken, isweak, dualvar, isvstring, set_prototype
  
  =back
  
  =head1 KNOWN BUGS
  
  There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
  show up as tests 8 and 9 of dualvar.t failing
  
  =head1 SEE ALSO
  
  L<List::Util>
  
  =head1 COPYRIGHT
  
  Copyright (c) 1997-2007 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.
  
  Except weaken and isweak which are
  
  Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
  This program is free software; you can redistribute it and/or modify it
  under the same terms as perl itself.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_SCALAR_UTIL

$fatpacked{"darwin-thread-multi-2level/Scalar/Util/PP.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_SCALAR_UTIL_PP';
  # Scalar::Util::PP.pm
  #
  # Copyright (c) 1997-2009 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.
  #
  # This module is normally only loaded if the XS module is not available
  
  package Scalar::Util::PP;
  
  use strict;
  use warnings;
  use vars qw(@ISA @EXPORT $VERSION $recurse);
  require Exporter;
  use B qw(svref_2object);
  
  @ISA     = qw(Exporter);
  @EXPORT  = qw(blessed reftype tainted readonly refaddr looks_like_number);
  $VERSION = "1.23";
  $VERSION = eval $VERSION;
  
  sub blessed ($) {
    return undef unless length(ref($_[0]));
    my $b = svref_2object($_[0]);
    return undef unless $b->isa('B::PVMG');
    my $s = $b->SvSTASH;
    return $s->isa('B::HV') ? $s->NAME : undef;
  }
  
  sub refaddr($) {
    return undef unless length(ref($_[0]));
  
    my $addr;
    if(defined(my $pkg = blessed($_[0]))) {
      $addr .= bless $_[0], 'Scalar::Util::Fake';
      bless $_[0], $pkg;
    }
    else {
      $addr .= $_[0]
    }
  
    $addr =~ /0x(\w+)/;
    local $^W;
    no warnings 'portable';
    hex($1);
  }
  
  {
    my %tmap = qw(
      B::NULL   SCALAR
  
      B::HV     HASH
      B::AV     ARRAY
      B::CV     CODE
      B::IO     IO
      B::GV     GLOB
      B::REGEXP REGEXP
    );
  
    sub reftype ($) {
      my $r = shift;
  
      return undef unless length(ref($r));
  
      my $t = ref(svref_2object($r));
  
      return
          exists $tmap{$t} ? $tmap{$t}
        : length(ref($$r)) ? 'REF'
        :                    'SCALAR';
    }
  }
  
  sub tainted {
    local($@, $SIG{__DIE__}, $SIG{__WARN__});
    local $^W = 0;
    no warnings;
    eval { kill 0 * $_[0] };
    $@ =~ /^Insecure/;
  }
  
  sub readonly {
    return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
  
    local($@, $SIG{__DIE__}, $SIG{__WARN__});
    my $tmp = $_[0];
  
    !eval { $_[0] = $tmp; 1 };
  }
  
  sub looks_like_number {
    local $_ = shift;
  
    # checks from perlfaq4
    return 0 if !defined($_);
    if (ref($_)) {
      require overload;
      return overload::Overloaded($_) ? defined(0 + $_) : 0;
    }
    return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
    return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
    return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
  
    0;
  }
  
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_SCALAR_UTIL_PP

$fatpacked{"darwin-thread-multi-2level/Storable.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_STORABLE';
  #
  #  Copyright (c) 1995-2000, Raphael Manfredi
  #  
  #  You may redistribute only under the same terms as Perl 5, as specified
  #  in the README file that comes with the distribution.
  #
  
  require DynaLoader;
  require Exporter;
  package Storable; @ISA = qw(Exporter DynaLoader);
  
  @EXPORT = qw(store retrieve);
  @EXPORT_OK = qw(
  	nstore store_fd nstore_fd fd_retrieve
  	freeze nfreeze thaw
  	dclone
  	retrieve_fd
  	lock_store lock_nstore lock_retrieve
          file_magic read_magic
  );
  
  use AutoLoader;
  use FileHandle;
  use vars qw($canonical $forgive_me $VERSION);
  
  $VERSION = '2.23';
  *AUTOLOAD = \&AutoLoader::AUTOLOAD;		# Grrr...
  
  #
  # Use of Log::Agent is optional
  #
  
  {
      local $SIG{__DIE__};
      eval "use Log::Agent";
  }
  
  require Carp;
  
  #
  # They might miss :flock in Fcntl
  #
  
  BEGIN {
  	if (eval { require Fcntl; 1 } && exists $Fcntl::EXPORT_TAGS{'flock'}) {
  		Fcntl->import(':flock');
  	} else {
  		eval q{
  			sub LOCK_SH ()	{1}
  			sub LOCK_EX ()	{2}
  		};
  	}
  }
  
  sub CLONE {
      # clone context under threads
      Storable::init_perinterp();
  }
  
  # Can't Autoload cleanly as this clashes 8.3 with &retrieve
  sub retrieve_fd { &fd_retrieve }		# Backward compatibility
  
  # By default restricted hashes are downgraded on earlier perls.
  
  $Storable::downgrade_restricted = 1;
  $Storable::accept_future_minor = 1;
  bootstrap Storable;
  1;
  __END__
  #
  # Use of Log::Agent is optional. If it hasn't imported these subs then
  # Autoloader will kindly supply our fallback implementation.
  #
  
  sub logcroak {
      Carp::croak(@_);
  }
  
  sub logcarp {
    Carp::carp(@_);
  }
  
  #
  # Determine whether locking is possible, but only when needed.
  #
  
  sub CAN_FLOCK; my $CAN_FLOCK; sub CAN_FLOCK {
  	return $CAN_FLOCK if defined $CAN_FLOCK;
  	require Config; import Config;
  	return $CAN_FLOCK =
  		$Config{'d_flock'} ||
  		$Config{'d_fcntl_can_lock'} ||
  		$Config{'d_lockf'};
  }
  
  sub show_file_magic {
      print <<EOM;
  #
  # To recognize the data files of the Perl module Storable,
  # the following lines need to be added to the local magic(5) file,
  # usually either /usr/share/misc/magic or /etc/magic.
  #
  0	string	perl-store	perl Storable(v0.6) data
  >4	byte	>0	(net-order %d)
  >>4	byte	&01	(network-ordered)
  >>4	byte	=3	(major 1)
  >>4	byte	=2	(major 1)
  
  0	string	pst0	perl Storable(v0.7) data
  >4	byte	>0
  >>4	byte	&01	(network-ordered)
  >>4	byte	=5	(major 2)
  >>4	byte	=4	(major 2)
  >>5	byte	>0	(minor %d)
  EOM
  }
  
  sub file_magic {
      my $file = shift;
      my $fh = new FileHandle;
      open($fh, "<". $file) || die "Can't open '$file': $!";
      binmode($fh);
      defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
      close($fh);
  
      $file = "./$file" unless $file;  # ensure TRUE value
  
      return read_magic($buf, $file);
  }
  
  sub read_magic {
      my($buf, $file) = @_;
      my %info;
  
      my $buflen = length($buf);
      my $magic;
      if ($buf =~ s/^(pst0|perl-store)//) {
  	$magic = $1;
  	$info{file} = $file || 1;
      }
      else {
  	return undef if $file;
  	$magic = "";
      }
  
      return undef unless length($buf);
  
      my $net_order;
      if ($magic eq "perl-store" && ord(substr($buf, 0, 1)) > 1) {
  	$info{version} = -1;
  	$net_order = 0;
      }
      else {
  	$net_order = ord(substr($buf, 0, 1, ""));
  	my $major = $net_order >> 1;
  	return undef if $major > 4; # sanity (assuming we never go that high)
  	$info{major} = $major;
  	$net_order &= 0x01;
  	if ($major > 1) {
  	    return undef unless length($buf);
  	    my $minor = ord(substr($buf, 0, 1, ""));
  	    $info{minor} = $minor;
  	    $info{version} = "$major.$minor";
  	    $info{version_nv} = sprintf "%d.%03d", $major, $minor;
  	}
  	else {
  	    $info{version} = $major;
  	}
      }
      $info{version_nv} ||= $info{version};
      $info{netorder} = $net_order;
  
      unless ($net_order) {
  	return undef unless length($buf);
  	my $len = ord(substr($buf, 0, 1, ""));
  	return undef unless length($buf) >= $len;
  	return undef unless $len == 4 || $len == 8;  # sanity
  	$info{byteorder} = substr($buf, 0, $len, "");
  	$info{intsize} = ord(substr($buf, 0, 1, ""));
  	$info{longsize} = ord(substr($buf, 0, 1, ""));
  	$info{ptrsize} = ord(substr($buf, 0, 1, ""));
  	if ($info{version_nv} >= 2.002) {
  	    return undef unless length($buf);
  	    $info{nvsize} = ord(substr($buf, 0, 1, ""));
  	}
      }
      $info{hdrsize} = $buflen - length($buf);
  
      return \%info;
  }
  
  sub BIN_VERSION_NV {
      sprintf "%d.%03d", BIN_MAJOR(), BIN_MINOR();
  }
  
  sub BIN_WRITE_VERSION_NV {
      sprintf "%d.%03d", BIN_MAJOR(), BIN_WRITE_MINOR();
  }
  
  #
  # store
  #
  # Store target object hierarchy, identified by a reference to its root.
  # The stored object tree may later be retrieved to memory via retrieve.
  # Returns undef if an I/O error occurred, in which case the file is
  # removed.
  #
  sub store {
  	return _store(\&pstore, @_, 0);
  }
  
  #
  # nstore
  #
  # Same as store, but in network order.
  #
  sub nstore {
  	return _store(\&net_pstore, @_, 0);
  }
  
  #
  # lock_store
  #
  # Same as store, but flock the file first (advisory locking).
  #
  sub lock_store {
  	return _store(\&pstore, @_, 1);
  }
  
  #
  # lock_nstore
  #
  # Same as nstore, but flock the file first (advisory locking).
  #
  sub lock_nstore {
  	return _store(\&net_pstore, @_, 1);
  }
  
  # Internal store to file routine
  sub _store {
  	my $xsptr = shift;
  	my $self = shift;
  	my ($file, $use_locking) = @_;
  	logcroak "not a reference" unless ref($self);
  	logcroak "wrong argument number" unless @_ == 2;	# No @foo in arglist
  	local *FILE;
  	if ($use_locking) {
  		open(FILE, ">>$file") || logcroak "can't write into $file: $!";
  		unless (&CAN_FLOCK) {
  			logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
  			return undef;
  		}
  		flock(FILE, LOCK_EX) ||
  			logcroak "can't get exclusive lock on $file: $!";
  		truncate FILE, 0;
  		# Unlocking will happen when FILE is closed
  	} else {
  		open(FILE, ">$file") || logcroak "can't create $file: $!";
  	}
  	binmode FILE;				# Archaic systems...
  	my $da = $@;				# Don't mess if called from exception handler
  	my $ret;
  	# Call C routine nstore or pstore, depending on network order
  	eval { $ret = &$xsptr(*FILE, $self) };
  	# close will return true on success, so the or short-circuits, the ()
  	# expression is true, and for that case the block will only be entered
  	# if $@ is true (ie eval failed)
  	# if close fails, it returns false, $ret is altered, *that* is (also)
  	# false, so the () expression is false, !() is true, and the block is
  	# entered.
  	if (!(close(FILE) or undef $ret) || $@) {
  		unlink($file) or warn "Can't unlink $file: $!\n";
  	}
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	$@ = $da;
  	return $ret;
  }
  
  #
  # store_fd
  #
  # Same as store, but perform on an already opened file descriptor instead.
  # Returns undef if an I/O error occurred.
  #
  sub store_fd {
  	return _store_fd(\&pstore, @_);
  }
  
  #
  # nstore_fd
  #
  # Same as store_fd, but in network order.
  #
  sub nstore_fd {
  	my ($self, $file) = @_;
  	return _store_fd(\&net_pstore, @_);
  }
  
  # Internal store routine on opened file descriptor
  sub _store_fd {
  	my $xsptr = shift;
  	my $self = shift;
  	my ($file) = @_;
  	logcroak "not a reference" unless ref($self);
  	logcroak "too many arguments" unless @_ == 1;	# No @foo in arglist
  	my $fd = fileno($file);
  	logcroak "not a valid file descriptor" unless defined $fd;
  	my $da = $@;				# Don't mess if called from exception handler
  	my $ret;
  	# Call C routine nstore or pstore, depending on network order
  	eval { $ret = &$xsptr($file, $self) };
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	local $\; print $file '';	# Autoflush the file if wanted
  	$@ = $da;
  	return $ret;
  }
  
  #
  # freeze
  #
  # Store oject and its hierarchy in memory and return a scalar
  # containing the result.
  #
  sub freeze {
  	_freeze(\&mstore, @_);
  }
  
  #
  # nfreeze
  #
  # Same as freeze but in network order.
  #
  sub nfreeze {
  	_freeze(\&net_mstore, @_);
  }
  
  # Internal freeze routine
  sub _freeze {
  	my $xsptr = shift;
  	my $self = shift;
  	logcroak "not a reference" unless ref($self);
  	logcroak "too many arguments" unless @_ == 0;	# No @foo in arglist
  	my $da = $@;				# Don't mess if called from exception handler
  	my $ret;
  	# Call C routine mstore or net_mstore, depending on network order
  	eval { $ret = &$xsptr($self) };
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	$@ = $da;
  	return $ret ? $ret : undef;
  }
  
  #
  # retrieve
  #
  # Retrieve object hierarchy from disk, returning a reference to the root
  # object of that tree.
  #
  sub retrieve {
  	_retrieve($_[0], 0);
  }
  
  #
  # lock_retrieve
  #
  # Same as retrieve, but with advisory locking.
  #
  sub lock_retrieve {
  	_retrieve($_[0], 1);
  }
  
  # Internal retrieve routine
  sub _retrieve {
  	my ($file, $use_locking) = @_;
  	local *FILE;
  	open(FILE, $file) || logcroak "can't open $file: $!";
  	binmode FILE;							# Archaic systems...
  	my $self;
  	my $da = $@;							# Could be from exception handler
  	if ($use_locking) {
  		unless (&CAN_FLOCK) {
  			logcarp "Storable::lock_store: fcntl/flock emulation broken on $^O";
  			return undef;
  		}
  		flock(FILE, LOCK_SH) || logcroak "can't get shared lock on $file: $!";
  		# Unlocking will happen when FILE is closed
  	}
  	eval { $self = pretrieve(*FILE) };		# Call C routine
  	close(FILE);
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	$@ = $da;
  	return $self;
  }
  
  #
  # fd_retrieve
  #
  # Same as retrieve, but perform from an already opened file descriptor instead.
  #
  sub fd_retrieve {
  	my ($file) = @_;
  	my $fd = fileno($file);
  	logcroak "not a valid file descriptor" unless defined $fd;
  	my $self;
  	my $da = $@;							# Could be from exception handler
  	eval { $self = pretrieve($file) };		# Call C routine
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	$@ = $da;
  	return $self;
  }
  
  #
  # thaw
  #
  # Recreate objects in memory from an existing frozen image created
  # by freeze.  If the frozen image passed is undef, return undef.
  #
  sub thaw {
  	my ($frozen) = @_;
  	return undef unless defined $frozen;
  	my $self;
  	my $da = $@;							# Could be from exception handler
  	eval { $self = mretrieve($frozen) };	# Call C routine
  	logcroak $@ if $@ =~ s/\.?\n$/,/;
  	$@ = $da;
  	return $self;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Storable - persistence for Perl data structures
  
  =head1 SYNOPSIS
  
   use Storable;
   store \%table, 'file';
   $hashref = retrieve('file');
  
   use Storable qw(nstore store_fd nstore_fd freeze thaw dclone);
  
   # Network order
   nstore \%table, 'file';
   $hashref = retrieve('file');	# There is NO nretrieve()
  
   # Storing to and retrieving from an already opened file
   store_fd \@array, \*STDOUT;
   nstore_fd \%table, \*STDOUT;
   $aryref = fd_retrieve(\*SOCKET);
   $hashref = fd_retrieve(\*SOCKET);
  
   # Serializing to memory
   $serialized = freeze \%table;
   %table_clone = %{ thaw($serialized) };
  
   # Deep (recursive) cloning
   $cloneref = dclone($ref);
  
   # Advisory locking
   use Storable qw(lock_store lock_nstore lock_retrieve)
   lock_store \%table, 'file';
   lock_nstore \%table, 'file';
   $hashref = lock_retrieve('file');
  
  =head1 DESCRIPTION
  
  The Storable package brings persistence to your Perl data structures
  containing SCALAR, ARRAY, HASH or REF objects, i.e. anything that can be
  conveniently stored to disk and retrieved at a later time.
  
  It can be used in the regular procedural way by calling C<store> with
  a reference to the object to be stored, along with the file name where
  the image should be written.
  
  The routine returns C<undef> for I/O problems or other internal error,
  a true value otherwise. Serious errors are propagated as a C<die> exception.
  
  To retrieve data stored to disk, use C<retrieve> with a file name.
  The objects stored into that file are recreated into memory for you,
  and a I<reference> to the root object is returned. In case an I/O error
  occurs while reading, C<undef> is returned instead. Other serious
  errors are propagated via C<die>.
  
  Since storage is performed recursively, you might want to stuff references
  to objects that share a lot of common data into a single array or hash
  table, and then store that object. That way, when you retrieve back the
  whole thing, the objects will continue to share what they originally shared.
  
  At the cost of a slight header overhead, you may store to an already
  opened file descriptor using the C<store_fd> routine, and retrieve
  from a file via C<fd_retrieve>. Those names aren't imported by default,
  so you will have to do that explicitly if you need those routines.
  The file descriptor you supply must be already opened, for read
  if you're going to retrieve and for write if you wish to store.
  
  	store_fd(\%table, *STDOUT) || die "can't store to stdout\n";
  	$hashref = fd_retrieve(*STDIN);
  
  You can also store data in network order to allow easy sharing across
  multiple platforms, or when storing on a socket known to be remotely
  connected. The routines to call have an initial C<n> prefix for I<network>,
  as in C<nstore> and C<nstore_fd>. At retrieval time, your data will be
  correctly restored so you don't have to know whether you're restoring
  from native or network ordered data.  Double values are stored stringified
  to ensure portability as well, at the slight risk of loosing some precision
  in the last decimals.
  
  When using C<fd_retrieve>, objects are retrieved in sequence, one
  object (i.e. one recursive tree) per associated C<store_fd>.
  
  If you're more from the object-oriented camp, you can inherit from
  Storable and directly store your objects by invoking C<store> as
  a method. The fact that the root of the to-be-stored tree is a
  blessed reference (i.e. an object) is special-cased so that the
  retrieve does not provide a reference to that object but rather the
  blessed object reference itself. (Otherwise, you'd get a reference
  to that blessed object).
  
  =head1 MEMORY STORE
  
  The Storable engine can also store data into a Perl scalar instead, to
  later retrieve them. This is mainly used to freeze a complex structure in
  some safe compact memory place (where it can possibly be sent to another
  process via some IPC, since freezing the structure also serializes it in
  effect). Later on, and maybe somewhere else, you can thaw the Perl scalar
  out and recreate the original complex structure in memory.
  
  Surprisingly, the routines to be called are named C<freeze> and C<thaw>.
  If you wish to send out the frozen scalar to another machine, use
  C<nfreeze> instead to get a portable image.
  
  Note that freezing an object structure and immediately thawing it
  actually achieves a deep cloning of that structure:
  
      dclone(.) = thaw(freeze(.))
  
  Storable provides you with a C<dclone> interface which does not create
  that intermediary scalar but instead freezes the structure in some
  internal memory space and then immediately thaws it out.
  
  =head1 ADVISORY LOCKING
  
  The C<lock_store> and C<lock_nstore> routine are equivalent to
  C<store> and C<nstore>, except that they get an exclusive lock on
  the file before writing.  Likewise, C<lock_retrieve> does the same
  as C<retrieve>, but also gets a shared lock on the file before reading.
  
  As with any advisory locking scheme, the protection only works if you
  systematically use C<lock_store> and C<lock_retrieve>.  If one side of
  your application uses C<store> whilst the other uses C<lock_retrieve>,
  you will get no protection at all.
  
  The internal advisory locking is implemented using Perl's flock()
  routine.  If your system does not support any form of flock(), or if
  you share your files across NFS, you might wish to use other forms
  of locking by using modules such as LockFile::Simple which lock a
  file using a filesystem entry, instead of locking the file descriptor.
  
  =head1 SPEED
  
  The heart of Storable is written in C for decent speed. Extra low-level
  optimizations have been made when manipulating perl internals, to
  sacrifice encapsulation for the benefit of greater speed.
  
  =head1 CANONICAL REPRESENTATION
  
  Normally, Storable stores elements of hashes in the order they are
  stored internally by Perl, i.e. pseudo-randomly.  If you set
  C<$Storable::canonical> to some C<TRUE> value, Storable will store
  hashes with the elements sorted by their key.  This allows you to
  compare data structures by comparing their frozen representations (or
  even the compressed frozen representations), which can be useful for
  creating lookup tables for complicated queries.
  
  Canonical order does not imply network order; those are two orthogonal
  settings.
  
  =head1 CODE REFERENCES
  
  Since Storable version 2.05, CODE references may be serialized with
  the help of L<B::Deparse>. To enable this feature, set
  C<$Storable::Deparse> to a true value. To enable deserialization,
  C<$Storable::Eval> should be set to a true value. Be aware that
  deserialization is done through C<eval>, which is dangerous if the
  Storable file contains malicious data. You can set C<$Storable::Eval>
  to a subroutine reference which would be used instead of C<eval>. See
  below for an example using a L<Safe> compartment for deserialization
  of CODE references.
  
  If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false
  values, then the value of C<$Storable::forgive_me> (see below) is
  respected while serializing and deserializing.
  
  =head1 FORWARD COMPATIBILITY
  
  This release of Storable can be used on a newer version of Perl to
  serialize data which is not supported by earlier Perls.  By default,
  Storable will attempt to do the right thing, by C<croak()>ing if it
  encounters data that it cannot deserialize.  However, the defaults
  can be changed as follows:
  
  =over 4
  
  =item utf8 data
  
  Perl 5.6 added support for Unicode characters with code points > 255,
  and Perl 5.8 has full support for Unicode characters in hash keys.
  Perl internally encodes strings with these characters using utf8, and
  Storable serializes them as utf8.  By default, if an older version of
  Perl encounters a utf8 value it cannot represent, it will C<croak()>.
  To change this behaviour so that Storable deserializes utf8 encoded
  values as the string of bytes (effectively dropping the I<is_utf8> flag)
  set C<$Storable::drop_utf8> to some C<TRUE> value.  This is a form of
  data loss, because with C<$drop_utf8> true, it becomes impossible to tell
  whether the original data was the Unicode string, or a series of bytes
  that happen to be valid utf8.
  
  =item restricted hashes
  
  Perl 5.8 adds support for restricted hashes, which have keys
  restricted to a given set, and can have values locked to be read only.
  By default, when Storable encounters a restricted hash on a perl
  that doesn't support them, it will deserialize it as a normal hash,
  silently discarding any placeholder keys and leaving the keys and
  all values unlocked.  To make Storable C<croak()> instead, set
  C<$Storable::downgrade_restricted> to a C<FALSE> value.  To restore
  the default set it back to some C<TRUE> value.
  
  =item files from future versions of Storable
  
  Earlier versions of Storable would immediately croak if they encountered
  a file with a higher internal version number than the reading Storable
  knew about.  Internal version numbers are increased each time new data
  types (such as restricted hashes) are added to the vocabulary of the file
  format.  This meant that a newer Storable module had no way of writing a
  file readable by an older Storable, even if the writer didn't store newer
  data types.
  
  This version of Storable will defer croaking until it encounters a data
  type in the file that it does not recognize.  This means that it will
  continue to read files generated by newer Storable modules which are careful
  in what they write out, making it easier to upgrade Storable modules in a
  mixed environment.
  
  The old behaviour of immediate croaking can be re-instated by setting
  C<$Storable::accept_future_minor> to some C<FALSE> value.
  
  =back
  
  All these variables have no effect on a newer Perl which supports the
  relevant feature.
  
  =head1 ERROR REPORTING
  
  Storable uses the "exception" paradigm, in that it does not try to workaround
  failures: if something bad happens, an exception is generated from the
  caller's perspective (see L<Carp> and C<croak()>).  Use eval {} to trap
  those exceptions.
  
  When Storable croaks, it tries to report the error via the C<logcroak()>
  routine from the C<Log::Agent> package, if it is available.
  
  Normal errors are reported by having store() or retrieve() return C<undef>.
  Such errors are usually I/O errors (or truncated stream errors at retrieval).
  
  =head1 WIZARDS ONLY
  
  =head2 Hooks
  
  Any class may define hooks that will be called during the serialization
  and deserialization process on objects that are instances of that class.
  Those hooks can redefine the way serialization is performed (and therefore,
  how the symmetrical deserialization should be conducted).
  
  Since we said earlier:
  
      dclone(.) = thaw(freeze(.))
  
  everything we say about hooks should also hold for deep cloning. However,
  hooks get to know whether the operation is a mere serialization, or a cloning.
  
  Therefore, when serializing hooks are involved,
  
      dclone(.) <> thaw(freeze(.))
  
  Well, you could keep them in sync, but there's no guarantee it will always
  hold on classes somebody else wrote.  Besides, there is little to gain in
  doing so: a serializing hook could keep only one attribute of an object,
  which is probably not what should happen during a deep cloning of that
  same object.
  
  Here is the hooking interface:
  
  =over 4
  
  =item C<STORABLE_freeze> I<obj>, I<cloning>
  
  The serializing hook, called on the object during serialization.  It can be
  inherited, or defined in the class itself, like any other method.
  
  Arguments: I<obj> is the object to serialize, I<cloning> is a flag indicating
  whether we're in a dclone() or a regular serialization via store() or freeze().
  
  Returned value: A LIST C<($serialized, $ref1, $ref2, ...)> where $serialized
  is the serialized form to be used, and the optional $ref1, $ref2, etc... are
  extra references that you wish to let the Storable engine serialize.
  
  At deserialization time, you will be given back the same LIST, but all the
  extra references will be pointing into the deserialized structure.
  
  The B<first time> the hook is hit in a serialization flow, you may have it
  return an empty list.  That will signal the Storable engine to further
  discard that hook for this class and to therefore revert to the default
  serialization of the underlying Perl data.  The hook will again be normally
  processed in the next serialization.
  
  Unless you know better, serializing hook should always say:
  
      sub STORABLE_freeze {
          my ($self, $cloning) = @_;
          return if $cloning;         # Regular default serialization
          ....
      }
  
  in order to keep reasonable dclone() semantics.
  
  =item C<STORABLE_thaw> I<obj>, I<cloning>, I<serialized>, ...
  
  The deserializing hook called on the object during deserialization.
  But wait: if we're deserializing, there's no object yet... right?
  
  Wrong: the Storable engine creates an empty one for you.  If you know Eiffel,
  you can view C<STORABLE_thaw> as an alternate creation routine.
  
  This means the hook can be inherited like any other method, and that
  I<obj> is your blessed reference for this particular instance.
  
  The other arguments should look familiar if you know C<STORABLE_freeze>:
  I<cloning> is true when we're part of a deep clone operation, I<serialized>
  is the serialized string you returned to the engine in C<STORABLE_freeze>,
  and there may be an optional list of references, in the same order you gave
  them at serialization time, pointing to the deserialized objects (which
  have been processed courtesy of the Storable engine).
  
  When the Storable engine does not find any C<STORABLE_thaw> hook routine,
  it tries to load the class by requiring the package dynamically (using
  the blessed package name), and then re-attempts the lookup.  If at that
  time the hook cannot be located, the engine croaks.  Note that this mechanism
  will fail if you define several classes in the same file, but L<perlmod>
  warned you.
  
  It is up to you to use this information to populate I<obj> the way you want.
  
  Returned value: none.
  
  =item C<STORABLE_attach> I<class>, I<cloning>, I<serialized>
  
  While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where
  each instance is independent, this mechanism has difficulty (or is
  incompatible) with objects that exist as common process-level or
  system-level resources, such as singleton objects, database pools, caches
  or memoized objects.
  
  The alternative C<STORABLE_attach> method provides a solution for these
  shared objects. Instead of C<STORABLE_freeze> --E<gt> C<STORABLE_thaw>,
  you implement C<STORABLE_freeze> --E<gt> C<STORABLE_attach> instead.
  
  Arguments: I<class> is the class we are attaching to, I<cloning> is a flag
  indicating whether we're in a dclone() or a regular de-serialization via
  thaw(), and I<serialized> is the stored string for the resource object.
  
  Because these resource objects are considered to be owned by the entire
  process/system, and not the "property" of whatever is being serialized,
  no references underneath the object should be included in the serialized
  string. Thus, in any class that implements C<STORABLE_attach>, the
  C<STORABLE_freeze> method cannot return any references, and C<Storable>
  will throw an error if C<STORABLE_freeze> tries to return references.
  
  All information required to "attach" back to the shared resource object
  B<must> be contained B<only> in the C<STORABLE_freeze> return string.
  Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach>
  classes.
  
  Because C<STORABLE_attach> is passed the class (rather than an object),
  it also returns the object directly, rather than modifying the passed
  object.
  
  Returned value: object of type C<class>
  
  =back
  
  =head2 Predicates
  
  Predicates are not exportable.  They must be called by explicitly prefixing
  them with the Storable package name.
  
  =over 4
  
  =item C<Storable::last_op_in_netorder>
  
  The C<Storable::last_op_in_netorder()> predicate will tell you whether
  network order was used in the last store or retrieve operation.  If you
  don't know how to use this, just forget about it.
  
  =item C<Storable::is_storing>
  
  Returns true if within a store operation (via STORABLE_freeze hook).
  
  =item C<Storable::is_retrieving>
  
  Returns true if within a retrieve operation (via STORABLE_thaw hook).
  
  =back
  
  =head2 Recursion
  
  With hooks comes the ability to recurse back to the Storable engine.
  Indeed, hooks are regular Perl code, and Storable is convenient when
  it comes to serializing and deserializing things, so why not use it
  to handle the serialization string?
  
  There are a few things you need to know, however:
  
  =over 4
  
  =item *
  
  You can create endless loops if the things you serialize via freeze()
  (for instance) point back to the object we're trying to serialize in
  the hook.
  
  =item *
  
  Shared references among objects will not stay shared: if we're serializing
  the list of object [A, C] where both object A and C refer to the SAME object
  B, and if there is a serializing hook in A that says freeze(B), then when
  deserializing, we'll get [A', C'] where A' refers to B', but C' refers to D,
  a deep clone of B'.  The topology was not preserved.
  
  =back
  
  That's why C<STORABLE_freeze> lets you provide a list of references
  to serialize.  The engine guarantees that those will be serialized in the
  same context as the other objects, and therefore that shared objects will
  stay shared.
  
  In the above [A, C] example, the C<STORABLE_freeze> hook could return:
  
  	("something", $self->{B})
  
  and the B part would be serialized by the engine.  In C<STORABLE_thaw>, you
  would get back the reference to the B' object, deserialized for you.
  
  Therefore, recursion should normally be avoided, but is nonetheless supported.
  
  =head2 Deep Cloning
  
  There is a Clone module available on CPAN which implements deep cloning
  natively, i.e. without freezing to memory and thawing the result.  It is
  aimed to replace Storable's dclone() some day.  However, it does not currently
  support Storable hooks to redefine the way deep cloning is performed.
  
  =head1 Storable magic
  
  Yes, there's a lot of that :-) But more precisely, in UNIX systems
  there's a utility called C<file>, which recognizes data files based on
  their contents (usually their first few bytes).  For this to work,
  a certain file called F<magic> needs to taught about the I<signature>
  of the data.  Where that configuration file lives depends on the UNIX
  flavour; often it's something like F</usr/share/misc/magic> or
  F</etc/magic>.  Your system administrator needs to do the updating of
  the F<magic> file.  The necessary signature information is output to
  STDOUT by invoking Storable::show_file_magic().  Note that the GNU
  implementation of the C<file> utility, version 3.38 or later,
  is expected to contain support for recognising Storable files
  out-of-the-box, in addition to other kinds of Perl files.
  
  You can also use the following functions to extract the file header
  information from Storable images:
  
  =over
  
  =item $info = Storable::file_magic( $filename )
  
  If the given file is a Storable image return a hash describing it.  If
  the file is readable, but not a Storable image return C<undef>.  If
  the file does not exist or is unreadable then croak.
  
  The hash returned has the following elements:
  
  =over
  
  =item C<version>
  
  This returns the file format version.  It is a string like "2.7".
  
  Note that this version number is not the same as the version number of
  the Storable module itself.  For instance Storable v0.7 create files
  in format v2.0 and Storable v2.15 create files in format v2.7.  The
  file format version number only increment when additional features
  that would confuse older versions of the module are added.
  
  Files older than v2.0 will have the one of the version numbers "-1",
  "0" or "1".  No minor number was used at that time.
  
  =item C<version_nv>
  
  This returns the file format version as number.  It is a string like
  "2.007".  This value is suitable for numeric comparisons.
  
  The constant function C<Storable::BIN_VERSION_NV> returns a comparable
  number that represent the highest file version number that this
  version of Storable fully support (but see discussion of
  C<$Storable::accept_future_minor> above).  The constant
  C<Storable::BIN_WRITE_VERSION_NV> function returns what file version
  is written and might be less than C<Storable::BIN_VERSION_NV> in some
  configuations.
  
  =item C<major>, C<minor>
  
  This also returns the file format version.  If the version is "2.7"
  then major would be 2 and minor would be 7.  The minor element is
  missing for when major is less than 2.
  
  =item C<hdrsize>
  
  The is the number of bytes that the Storable header occupies.
  
  =item C<netorder>
  
  This is TRUE if the image store data in network order.  This means
  that it was created with nstore() or similar.
  
  =item C<byteorder>
  
  This is only present when C<netorder> is FALSE.  It is the
  $Config{byteorder} string of the perl that created this image.  It is
  a string like "1234" (32 bit little endian) or "87654321" (64 bit big
  endian).  This must match the current perl for the image to be
  readable by Storable.
  
  =item C<intsize>, C<longsize>, C<ptrsize>, C<nvsize>
  
  These are only present when C<netorder> is FALSE. These are the sizes of
  various C datatypes of the perl that created this image.  These must
  match the current perl for the image to be readable by Storable.
  
  The C<nvsize> element is only present for file format v2.2 and
  higher.
  
  =item C<file>
  
  The name of the file.
  
  =back
  
  =item $info = Storable::read_magic( $buffer )
  
  =item $info = Storable::read_magic( $buffer, $must_be_file )
  
  The $buffer should be a Storable image or the first few bytes of it.
  If $buffer starts with a Storable header, then a hash describing the
  image is returned, otherwise C<undef> is returned.
  
  The hash has the same structure as the one returned by
  Storable::file_magic().  The C<file> element is true if the image is a
  file image.
  
  If the $must_be_file argument is provided and is TRUE, then return
  C<undef> unless the image looks like it belongs to a file dump.
  
  The maximum size of a Storable header is currently 21 bytes.  If the
  provided $buffer is only the first part of a Storable image it should
  at least be this long to ensure that read_magic() will recognize it as
  such.
  
  =back
  
  =head1 EXAMPLES
  
  Here are some code samples showing a possible usage of Storable:
  
  	use Storable qw(store retrieve freeze thaw dclone);
  
  	%color = ('Blue' => 0.1, 'Red' => 0.8, 'Black' => 0, 'White' => 1);
  
  	store(\%color, 'mycolors') or die "Can't store %a in mycolors!\n";
  
  	$colref = retrieve('mycolors');
  	die "Unable to retrieve from mycolors!\n" unless defined $colref;
  	printf "Blue is still %lf\n", $colref->{'Blue'};
  
  	$colref2 = dclone(\%color);
  
  	$str = freeze(\%color);
  	printf "Serialization of %%color is %d bytes long.\n", length($str);
  	$colref3 = thaw($str);
  
  which prints (on my machine):
  
  	Blue is still 0.100000
  	Serialization of %color is 102 bytes long.
  
  Serialization of CODE references and deserialization in a safe
  compartment:
  
  =for example begin
  
  	use Storable qw(freeze thaw);
  	use Safe;
  	use strict;
  	my $safe = new Safe;
          # because of opcodes used in "use strict":
  	$safe->permit(qw(:default require));
  	local $Storable::Deparse = 1;
  	local $Storable::Eval = sub { $safe->reval($_[0]) };
  	my $serialized = freeze(sub { 42 });
  	my $code = thaw($serialized);
  	$code->() == 42;
  
  =for example end
  
  =for example_testing
          is( $code->(), 42 );
  
  =head1 WARNING
  
  If you're using references as keys within your hash tables, you're bound
  to be disappointed when retrieving your data. Indeed, Perl stringifies
  references used as hash table keys. If you later wish to access the
  items via another reference stringification (i.e. using the same
  reference that was used for the key originally to record the value into
  the hash table), it will work because both references stringify to the
  same string.
  
  It won't work across a sequence of C<store> and C<retrieve> operations,
  however, because the addresses in the retrieved objects, which are
  part of the stringified references, will probably differ from the
  original addresses. The topology of your structure is preserved,
  but not hidden semantics like those.
  
  On platforms where it matters, be sure to call C<binmode()> on the
  descriptors that you pass to Storable functions.
  
  Storing data canonically that contains large hashes can be
  significantly slower than storing the same data normally, as
  temporary arrays to hold the keys for each hash have to be allocated,
  populated, sorted and freed.  Some tests have shown a halving of the
  speed of storing -- the exact penalty will depend on the complexity of
  your data.  There is no slowdown on retrieval.
  
  =head1 BUGS
  
  You can't store GLOB, FORMLINE, REGEXP, etc.... If you can define semantics
  for those operations, feel free to enhance Storable so that it can
  deal with them.
  
  The store functions will C<croak> if they run into such references
  unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
  case, the fatal message is turned in a warning and some
  meaningless string is stored instead.
  
  Setting C<$Storable::canonical> may not yield frozen strings that
  compare equal due to possible stringification of numbers. When the
  string version of a scalar exists, it is the form stored; therefore,
  if you happen to use your numbers as strings between two freezing
  operations on the same data structures, you will get different
  results.
  
  When storing doubles in network order, their value is stored as text.
  However, you should also not expect non-numeric floating-point values
  such as infinity and "not a number" to pass successfully through a
  nstore()/retrieve() pair.
  
  As Storable neither knows nor cares about character sets (although it
  does know that characters may be more than eight bits wide), any difference
  in the interpretation of character codes between a host and a target
  system is your problem.  In particular, if host and target use different
  code points to represent the characters used in the text representation
  of floating-point numbers, you will not be able be able to exchange
  floating-point data, even with nstore().
  
  C<Storable::drop_utf8> is a blunt tool.  There is no facility either to
  return B<all> strings as utf8 sequences, or to attempt to convert utf8
  data back to 8 bit and C<croak()> if the conversion fails.
  
  Prior to Storable 2.01, no distinction was made between signed and
  unsigned integers on storing.  By default Storable prefers to store a
  scalars string representation (if it has one) so this would only cause
  problems when storing large unsigned integers that had never been converted
  to string or floating point.  In other words values that had been generated
  by integer operations such as logic ops and then not used in any string or
  arithmetic context before storing.
  
  =head2 64 bit data in perl 5.6.0 and 5.6.1
  
  This section only applies to you if you have existing data written out
  by Storable 2.02 or earlier on perl 5.6.0 or 5.6.1 on Unix or Linux which
  has been configured with 64 bit integer support (not the default)
  If you got a precompiled perl, rather than running Configure to build
  your own perl from source, then it almost certainly does not affect you,
  and you can stop reading now (unless you're curious). If you're using perl
  on Windows it does not affect you.
  
  Storable writes a file header which contains the sizes of various C
  language types for the C compiler that built Storable (when not writing in
  network order), and will refuse to load files written by a Storable not
  on the same (or compatible) architecture.  This check and a check on
  machine byteorder is needed because the size of various fields in the file
  are given by the sizes of the C language types, and so files written on
  different architectures are incompatible.  This is done for increased speed.
  (When writing in network order, all fields are written out as standard
  lengths, which allows full interworking, but takes longer to read and write)
  
  Perl 5.6.x introduced the ability to optional configure the perl interpreter
  to use C's C<long long> type to allow scalars to store 64 bit integers on 32
  bit systems.  However, due to the way the Perl configuration system
  generated the C configuration files on non-Windows platforms, and the way
  Storable generates its header, nothing in the Storable file header reflected
  whether the perl writing was using 32 or 64 bit integers, despite the fact
  that Storable was storing some data differently in the file.  Hence Storable
  running on perl with 64 bit integers will read the header from a file
  written by a 32 bit perl, not realise that the data is actually in a subtly
  incompatible format, and then go horribly wrong (possibly crashing) if it
  encountered a stored integer.  This is a design failure.
  
  Storable has now been changed to write out and read in a file header with
  information about the size of integers.  It's impossible to detect whether
  an old file being read in was written with 32 or 64 bit integers (they have
  the same header) so it's impossible to automatically switch to a correct
  backwards compatibility mode.  Hence this Storable defaults to the new,
  correct behaviour.
  
  What this means is that if you have data written by Storable 1.x running
  on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux
  then by default this Storable will refuse to read it, giving the error
  I<Byte order is not compatible>.  If you have such data then you you
  should set C<$Storable::interwork_56_64bit> to a true value to make this
  Storable read and write files with the old header.  You should also
  migrate your data, or any older perl you are communicating with, to this
  current version of Storable.
  
  If you don't have data written with specific configuration of perl described
  above, then you do not and should not do anything.  Don't set the flag -
  not only will Storable on an identically configured perl refuse to load them,
  but Storable a differently configured perl will load them believing them
  to be correct for it, and then may well fail or crash part way through
  reading them.
  
  =head1 CREDITS
  
  Thank you to (in chronological order):
  
  	Jarkko Hietaniemi <jhi@iki.fi>
  	Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
  	Benjamin A. Holzman <bah@ecnvantage.com>
  	Andrew Ford <A.Ford@ford-mason.co.uk>
  	Gisle Aas <gisle@aas.no>
  	Jeff Gresham <gresham_jeffrey@jpmorgan.com>
  	Murray Nesbitt <murray@activestate.com>
  	Marc Lehmann <pcg@opengroup.org>
  	Justin Banks <justinb@wamnet.com>
  	Jarkko Hietaniemi <jhi@iki.fi> (AGAIN, as perl 5.7.0 Pumpkin!)
  	Salvador Ortiz Garcia <sog@msg.com.mx>
  	Dominic Dunlop <domo@computer.org>
  	Erik Haugan <erik@solbors.no>
  
  for their bug reports, suggestions and contributions.
  
  Benjamin Holzman contributed the tied variable support, Andrew Ford
  contributed the canonical order for hashes, and Gisle Aas fixed
  a few misunderstandings of mine regarding the perl internals,
  and optimized the emission of "tags" in the output streams by
  simply counting the objects instead of tagging them (leading to
  a binary incompatibility for the Storable image starting at version
  0.6--older images are, of course, still properly understood).
  Murray Nesbitt made Storable thread-safe.  Marc Lehmann added overloading
  and references to tied items support.
  
  =head1 AUTHOR
  
  Storable was written by Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>>
  Maintenance is now done by the perl5-porters F<E<lt>perl5-porters@perl.orgE<gt>>
  
  Please e-mail us with problems, bug fixes, comments and complaints,
  although if you have compliments you should send them to Raphael.
  Please don't e-mail Raphael with problems, as he no longer works on
  Storable, and your message will be delayed while he forwards it to us.
  
  =head1 SEE ALSO
  
  L<Clone>.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_STORABLE

$fatpacked{"darwin-thread-multi-2level/Sub/Name.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_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;
DARWIN-THREAD-MULTI-2LEVEL_SUB_NAME

$fatpacked{"darwin-thread-multi-2level/Test/Moose.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_TEST_MOOSE';
  package Test::Moose;
  BEGIN {
    $Test::Moose::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $Test::Moose::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Sub::Exporter;
  use Test::Builder;
  
  use List::MoreUtils 'all';
  use Moose::Util 'does_role', 'find_meta';
  
  my @exports = qw[
      meta_ok
      does_ok
      has_attribute_ok
      with_immutable
  ];
  
  Sub::Exporter::setup_exporter({
      exports => \@exports,
      groups  => { default => \@exports }
  });
  
  ## the test builder instance ...
  
  my $Test = Test::Builder->new;
  
  ## exported functions
  
  sub meta_ok ($;$) {
      my ($class_or_obj, $message) = @_;
  
      $message ||= "The object has a meta";
  
      if (find_meta($class_or_obj)) {
          return $Test->ok(1, $message)
      }
      else {
          return $Test->ok(0, $message);
      }
  }
  
  sub does_ok ($$;$) {
      my ($class_or_obj, $does, $message) = @_;
  
      $message ||= "The object does $does";
  
      if (does_role($class_or_obj, $does)) {
          return $Test->ok(1, $message)
      }
      else {
          return $Test->ok(0, $message);
      }
  }
  
  sub has_attribute_ok ($$;$) {
      my ($class_or_obj, $attr_name, $message) = @_;
  
      $message ||= "The object does has an attribute named $attr_name";
  
      my $meta = find_meta($class_or_obj);
  
      if ($meta->find_attribute_by_name($attr_name)) {
          return $Test->ok(1, $message)
      }
      else {
          return $Test->ok(0, $message);
      }
  }
  
  sub with_immutable (&@) {
      my $block = shift;
      my $before = $Test->current_test;
      $block->();
      Class::MOP::class_of($_)->make_immutable for @_;
      $block->();
      my $num_tests = $Test->current_test - $before;
      return all { $_ } ($Test->summary)[-$num_tests..-1];
  }
  
  1;
  
  # ABSTRACT: Test functions for Moose specific features
  
  
  
  =pod
  
  =head1 NAME
  
  Test::Moose - Test functions for Moose specific features
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    use Test::More plan => 1;
    use Test::Moose;
  
    meta_ok($class_or_obj, "... Foo has a ->meta");
    does_ok($class_or_obj, $role, "... Foo does the Baz role");
    has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");
  
  =head1 DESCRIPTION
  
  This module provides some useful test functions for Moose based classes. It
  is an experimental first release, so comments and suggestions are very welcome.
  
  =head1 EXPORTED FUNCTIONS
  
  =over 4
  
  =item B<meta_ok ($class_or_object)>
  
  Tests if a class or object has a metaclass.
  
  =item B<does_ok ($class_or_object, $role, ?$message)>
  
  Tests if a class or object does a certain role, similar to what C<isa_ok>
  does for the C<isa> method.
  
  =item B<has_attribute_ok($class_or_object, $attr_name, ?$message)>
  
  Tests if a class or object has a certain attribute, similar to what C<can_ok>
  does for the methods.
  
  =item B<with_immutable { CODE } @class_names>
  
  Runs B<CODE> (which should contain normal tests) twice, and make each
  class in C<@class_names> immutable in between the two runs.
  
  =back
  
  =head1 TODO
  
  =over 4
  
  =item Convert the Moose test suite to use this module.
  
  =item Here is a list of possible functions to write
  
  =over 4
  
  =item immutability predicates
  
  =item anon-class predicates
  
  =item discovering original method from modified method
  
  =item attribute metaclass predicates (attribute_isa?)
  
  =back
  
  =back
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<Test::More>
  
  =back
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
  
DARWIN-THREAD-MULTI-2LEVEL_TEST_MOOSE

$fatpacked{"darwin-thread-multi-2level/Time/HiRes.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_TIME_HIRES';
  package Time::HiRes;
  
  use strict;
  use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
  
  require Exporter;
  require DynaLoader;
  
  @ISA = qw(Exporter DynaLoader);
  
  @EXPORT = qw( );
  @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
  		 getitimer setitimer nanosleep clock_gettime clock_getres
  		 clock clock_nanosleep
  		 CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
  		 CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
  		 CLOCK_TIMEOFDAY CLOCKS_PER_SEC
  		 ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
  		 TIMER_ABSTIME
  		 d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
  		 d_nanosleep d_clock_gettime d_clock_getres
  		 d_clock d_clock_nanosleep
  		 stat
  		);
  
  $VERSION = '1.9721';
  $XS_VERSION = $VERSION;
  $VERSION = eval $VERSION;
  
  sub AUTOLOAD {
      my $constname;
      ($constname = $AUTOLOAD) =~ s/.*:://;
      # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
      die "&Time::HiRes::constant not defined" if $constname eq 'constant';
      my ($error, $val) = constant($constname);
      # print "AUTOLOAD: error = $error, val = $val\n";
      if ($error) {
          my (undef,$file,$line) = caller;
          die "$error at $file line $line.\n";
      }
      {
  	no strict 'refs';
  	*$AUTOLOAD = sub { $val };
      }
      goto &$AUTOLOAD;
  }
  
  sub import {
      my $this = shift;
      for my $i (@_) {
  	if (($i eq 'clock_getres'    && !&d_clock_getres)    ||
  	    ($i eq 'clock_gettime'   && !&d_clock_gettime)   ||
  	    ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
  	    ($i eq 'clock'           && !&d_clock)           ||
  	    ($i eq 'nanosleep'       && !&d_nanosleep)       ||
  	    ($i eq 'usleep'          && !&d_usleep)          ||
  	    ($i eq 'ualarm'          && !&d_ualarm)) {
  	    require Carp;
  	    Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
  	}
      }
      Time::HiRes->export_to_level(1, $this, @_);
  }
  
  bootstrap Time::HiRes;
  
  # Preloaded methods go here.
  
  sub tv_interval {
      # probably could have been done in C
      my ($a, $b) = @_;
      $b = [gettimeofday()] unless defined($b);
      (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
  }
  
  # Autoload methods go after =cut, and are processed by the autosplit program.
  
  1;
  __END__
  
  =head1 NAME
  
  Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
  
  =head1 SYNOPSIS
  
    use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
  		      clock_gettime clock_getres clock_nanosleep clock
                        stat );
  
    usleep ($microseconds);
    nanosleep ($nanoseconds);
  
    ualarm ($microseconds);
    ualarm ($microseconds, $interval_microseconds);
  
    $t0 = [gettimeofday];
    ($seconds, $microseconds) = gettimeofday;
  
    $elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
    $elapsed = tv_interval ( $t0, [gettimeofday]);
    $elapsed = tv_interval ( $t0 );
  
    use Time::HiRes qw ( time alarm sleep );
  
    $now_fractions = time;
    sleep ($floating_seconds);
    alarm ($floating_seconds);
    alarm ($floating_seconds, $floating_interval);
  
    use Time::HiRes qw( setitimer getitimer );
  
    setitimer ($which, $floating_seconds, $floating_interval );
    getitimer ($which);
  
    use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
  		      ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
  
    $realtime   = clock_gettime(CLOCK_REALTIME);
    $resolution = clock_getres(CLOCK_REALTIME);
  
    clock_nanosleep(CLOCK_REALTIME, 1.5e9);
    clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME);
  
    my $ticktock = clock();
  
    use Time::HiRes qw( stat );
  
    my @stat = stat("file");
    my @stat = stat(FH);
  
  =head1 DESCRIPTION
  
  The C<Time::HiRes> module implements a Perl interface to the
  C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
  C<setitimer>/C<getitimer> system calls, in other words, high
  resolution time and timers. See the L</EXAMPLES> section below and the
  test scripts for usage; see your system documentation for the
  description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
  C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
  
  If your system lacks C<gettimeofday()> or an emulation of it you don't
  get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
  If your system lacks all of C<nanosleep()>, C<usleep()>,
  C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
  C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
  If your system lacks both C<ualarm()> and C<setitimer()> you don't get
  C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
  
  If you try to import an unimplemented function in the C<use> statement
  it will fail at compile time.
  
  If your subsecond sleeping is implemented with C<nanosleep()> instead
  of C<usleep()>, you can mix subsecond sleeping with signals since
  C<nanosleep()> does not use signals.  This, however, is not portable,
  and you should first check for the truth value of
  C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
  then carefully read your C<nanosleep()> C API documentation for any
  peculiarities.
  
  If you are using C<nanosleep> for something else than mixing sleeping
  with signals, give some thought to whether Perl is the tool you should
  be using for work requiring nanosecond accuracies.
  
  Remember that unless you are working on a I<hard realtime> system,
  any clocks and timers will be imprecise, especially so if you are working
  in a pre-emptive multiuser system.  Understand the difference between
  I<wallclock time> and process time (in UNIX-like systems the sum of
  I<user> and I<system> times).  Any attempt to sleep for X seconds will
  most probably end up sleeping B<more> than that, but don't be surpised
  if you end up sleeping slightly B<less>.
  
  The following functions can be imported from this module.
  No functions are exported by default.
  
  =over 4
  
  =item gettimeofday ()
  
  In array context returns a two-element array with the seconds and
  microseconds since the epoch.  In scalar context returns floating
  seconds like C<Time::HiRes::time()> (see below).
  
  =item usleep ( $useconds )
  
  Sleeps for the number of microseconds (millionths of a second)
  specified.  Returns the number of microseconds actually slept.
  Can sleep for more than one second, unlike the C<usleep> system call.
  Can also sleep for zero seconds, which often works like a I<thread yield>.
  See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
  C<Time::HiRes::clock_nanosleep()>.
  
  Do not expect usleep() to be exact down to one microsecond.
  
  =item nanosleep ( $nanoseconds )
  
  Sleeps for the number of nanoseconds (1e9ths of a second) specified.
  Returns the number of nanoseconds actually slept (accurate only to
  microseconds, the nearest thousand of them).  Can sleep for more than
  one second.  Can also sleep for zero seconds, which often works like
  a I<thread yield>.  See also C<Time::HiRes::sleep()>,
  C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
  
  Do not expect nanosleep() to be exact down to one nanosecond.
  Getting even accuracy of one thousand nanoseconds is good.
  
  =item ualarm ( $useconds [, $interval_useconds ] )
  
  Issues a C<ualarm> call; the C<$interval_useconds> is optional and
  will be zero if unspecified, resulting in C<alarm>-like behaviour.
  
  Returns the remaining time in the alarm in microseconds, or C<undef>
  if an error occurred.
  
  ualarm(0) will cancel an outstanding ualarm().
  
  Note that the interaction between alarms and sleeps is unspecified.
  
  =item tv_interval 
  
  tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
  
  Returns the floating seconds between the two times, which should have
  been returned by C<gettimeofday()>. If the second argument is omitted,
  then the current time is used.
  
  =item time ()
  
  Returns a floating seconds since the epoch. This function can be
  imported, resulting in a nice drop-in replacement for the C<time>
  provided with core Perl; see the L</EXAMPLES> below.
  
  B<NOTE 1>: This higher resolution timer can return values either less
  or more than the core C<time()>, depending on whether your platform
  rounds the higher resolution timer values up, down, or to the nearest second
  to get the core C<time()>, but naturally the difference should be never
  more than half a second.  See also L</clock_getres>, if available
  in your system.
  
  B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
  the C<time()> seconds since epoch rolled over to 1_000_000_000, the
  default floating point format of Perl and the seconds since epoch have
  conspired to produce an apparent bug: if you print the value of
  C<Time::HiRes::time()> you seem to be getting only five decimals, not
  six as promised (microseconds).  Not to worry, the microseconds are
  there (assuming your platform supports such granularity in the first
  place).  What is going on is that the default floating point format of
  Perl only outputs 15 digits.  In this case that means ten digits
  before the decimal separator and five after.  To see the microseconds
  you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
  C<gettimeofday()> function in list context, which will give you the
  seconds and microseconds as two separate values.
  
  =item sleep ( $floating_seconds )
  
  Sleeps for the specified amount of seconds.  Returns the number of
  seconds actually slept (a floating point value).  This function can
  be imported, resulting in a nice drop-in replacement for the C<sleep>
  provided with perl, see the L</EXAMPLES> below.
  
  Note that the interaction between alarms and sleeps is unspecified.
  
  =item alarm ( $floating_seconds [, $interval_floating_seconds ] )
  
  The C<SIGALRM> signal is sent after the specified number of seconds.
  Implemented using C<setitimer()> if available, C<ualarm()> if not.
  The C<$interval_floating_seconds> argument is optional and will be
  zero if unspecified, resulting in C<alarm()>-like behaviour.  This
  function can be imported, resulting in a nice drop-in replacement for
  the C<alarm> provided with perl, see the L</EXAMPLES> below.
  
  Returns the remaining time in the alarm in seconds, or C<undef>
  if an error occurred.
  
  B<NOTE 1>: With some combinations of operating systems and Perl
  releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
  This means that an C<alarm()> followed by a C<select()> may together
  take the sum of the times specified for the the C<alarm()> and the
  C<select()>, not just the time of the C<alarm()>.
  
  Note that the interaction between alarms and sleeps is unspecified.
  
  =item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
  
  Start up an interval timer: after a certain time, a signal ($which) arrives,
  and more signals may keep arriving at certain intervals.  To disable
  an "itimer", use C<$floating_seconds> of zero.  If the
  C<$interval_floating_seconds> is set to zero (or unspecified), the
  timer is disabled B<after> the next delivered signal.
  
  Use of interval timers may interfere with C<alarm()>, C<sleep()>,
  and C<usleep()>.  In standard-speak the "interaction is unspecified",
  which means that I<anything> may happen: it may work, it may not.
  
  In scalar context, the remaining time in the timer is returned.
  
  In list context, both the remaining time and the interval are returned.
  
  There are usually three or four interval timers (signals) available: the
  C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
  C<ITIMER_REALPROF>.  Note that which ones are available depends: true
  UNIX platforms usually have the first three, but only Solaris seems to
  have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
  Win32 unfortunately does not haveinterval timers.
  
  C<ITIMER_REAL> results in C<alarm()>-like behaviour.  Time is counted in
  I<real time>; that is, wallclock time.  C<SIGALRM> is delivered when
  the timer expires.
  
  C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
  only when the process is running.  In multiprocessor/user/CPU systems
  this may be more or less than real or wallclock time.  (This time is
  also known as the I<user time>.)  C<SIGVTALRM> is delivered when the
  timer expires.
  
  C<ITIMER_PROF> counts time when either the process virtual time or when
  the operating system is running on behalf of the process (such as I/O).
  (This time is also known as the I<system time>.)  (The sum of user
  time and system time is known as the I<CPU time>.)  C<SIGPROF> is
  delivered when the timer expires.  C<SIGPROF> can interrupt system calls.
  
  The semantics of interval timers for multithreaded programs are
  system-specific, and some systems may support additional interval
  timers.  For example, it is unspecified which thread gets the signals.
  See your C<setitimer()> documentation.
  
  =item getitimer ( $which )
  
  Return the remaining time in the interval timer specified by C<$which>.
  
  In scalar context, the remaining time is returned.
  
  In list context, both the remaining time and the interval are returned.
  The interval is always what you put in using C<setitimer()>.
  
  =item clock_gettime ( $which )
  
  Return as seconds the current value of the POSIX high resolution timer
  specified by C<$which>.  All implementations that support POSIX high
  resolution timers are supposed to support at least the C<$which> value
  of C<CLOCK_REALTIME>, which is supposed to return results close to the
  results of C<gettimeofday>, or the number of seconds since 00:00:00:00
  January 1, 1970 Greenwich Mean Time (GMT).  Do not assume that
  CLOCK_REALTIME is zero, it might be one, or something else.
  Another potentially useful (but not available everywhere) value is
  C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
  value (unlike time() or gettimeofday(), which can be adjusted).
  See your system documentation for other possibly supported values.
  
  =item clock_getres ( $which )
  
  Return as seconds the resolution of the POSIX high resolution timer
  specified by C<$which>.  All implementations that support POSIX high
  resolution timers are supposed to support at least the C<$which> value
  of C<CLOCK_REALTIME>, see L</clock_gettime>.
  
  =item clock_nanosleep ( $which, $nanoseconds, $flags = 0)
  
  Sleeps for the number of nanoseconds (1e9ths of a second) specified.
  Returns the number of nanoseconds actually slept.  The $which is the
  "clock id", as with clock_gettime() and clock_getres().  The flags
  default to zero but C<TIMER_ABSTIME> can specified (must be exported
  explicitly) which means that C<$nanoseconds> is not a time interval
  (as is the default) but instead an absolute time.  Can sleep for more
  than one second.  Can also sleep for zero seconds, which often works
  like a I<thread yield>.  See also C<Time::HiRes::sleep()>,
  C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
  
  Do not expect clock_nanosleep() to be exact down to one nanosecond.
  Getting even accuracy of one thousand nanoseconds is good.
  
  =item clock()
  
  Return as seconds the I<process time> (user + system time) spent by
  the process since the first call to clock() (the definition is B<not>
  "since the start of the process", though if you are lucky these times
  may be quite close to each other, depending on the system).  What this
  means is that you probably need to store the result of your first call
  to clock(), and subtract that value from the following results of clock().
  
  The time returned also includes the process times of the terminated
  child processes for which wait() has been executed.  This value is
  somewhat like the second value returned by the times() of core Perl,
  but not necessarily identical.  Note that due to backward
  compatibility limitations the returned value may wrap around at about
  2147 seconds or at about 36 minutes.
  
  =item stat
  
  =item stat FH
  
  =item stat EXPR
  
  As L<perlfunc/stat> but with the access/modify/change file timestamps
  in subsecond resolution, if the operating system and the filesystem
  both support such timestamps.  To override the standard stat():
  
      use Time::HiRes qw(stat);
  
  Test for the value of &Time::HiRes::d_hires_stat to find out whether
  the operating system supports subsecond file timestamps: a value
  larger than zero means yes. There are unfortunately no easy
  ways to find out whether the filesystem supports such timestamps.
  UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp
  granularity is B<two> seconds).
  
  A zero return value of &Time::HiRes::d_hires_stat means that
  Time::HiRes::stat is a no-op passthrough for CORE::stat(),
  and therefore the timestamps will stay integers.  The same
  thing will happen if the filesystem does not do subsecond timestamps,
  even if the &Time::HiRes::d_hires_stat is non-zero.
  
  In any case do not expect nanosecond resolution, or even a microsecond
  resolution.  Also note that the modify/access timestamps might have
  different resolutions, and that they need not be synchronized, e.g.
  if the operations are
  
      write
      stat # t1
      read
      stat # t2
  
  the access time stamp from t2 need not be greater-than the modify
  time stamp from t1: it may be equal or I<less>.
  
  =back
  
  =head1 EXAMPLES
  
    use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
  
    $microseconds = 750_000;
    usleep($microseconds);
  
    # signal alarm in 2.5s & every .1s thereafter
    ualarm(2_500_000, 100_000);
    # cancel that ualarm
    ualarm(0);
  
    # get seconds and microseconds since the epoch
    ($s, $usec) = gettimeofday();
  
    # measure elapsed time 
    # (could also do by subtracting 2 gettimeofday return values)
    $t0 = [gettimeofday];
    # do bunch of stuff here
    $t1 = [gettimeofday];
    # do more stuff here
    $t0_t1 = tv_interval $t0, $t1;
  
    $elapsed = tv_interval ($t0, [gettimeofday]);
    $elapsed = tv_interval ($t0);	# equivalent code
  
    #
    # replacements for time, alarm and sleep that know about
    # floating seconds
    #
    use Time::HiRes;
    $now_fractions = Time::HiRes::time;
    Time::HiRes::sleep (2.5);
    Time::HiRes::alarm (10.6666666);
  
    use Time::HiRes qw ( time alarm sleep );
    $now_fractions = time;
    sleep (2.5);
    alarm (10.6666666);
  
    # Arm an interval timer to go off first at 10 seconds and
    # after that every 2.5 seconds, in process virtual time
  
    use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
  
    $SIG{VTALRM} = sub { print time, "\n" };
    setitimer(ITIMER_VIRTUAL, 10, 2.5);
  
    use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
    # Read the POSIX high resolution timer.
    my $high = clock_getres(CLOCK_REALTIME);
    # But how accurate we can be, really?
    my $reso = clock_getres(CLOCK_REALTIME);
  
    use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
    clock_nanosleep(CLOCK_REALTIME, 1e6);
    clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
  
    use Time::HiRes qw( clock );
    my $clock0 = clock();
    ... # Do something.
    my $clock1 = clock();
    my $clockd = $clock1 - $clock0;
  
    use Time::HiRes qw( stat );
    my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10];
  
  =head1 C API
  
  In addition to the perl API described above, a C API is available for
  extension writers.  The following C functions are available in the
  modglobal hash:
  
    name             C prototype
    ---------------  ----------------------
    Time::NVtime     double (*)()
    Time::U2time     void (*)(pTHX_ UV ret[2])
  
  Both functions return equivalent information (like C<gettimeofday>)
  but with different representations.  The names C<NVtime> and C<U2time>
  were selected mainly because they are operating system independent.
  (C<gettimeofday> is Unix-centric, though some platforms like Win32 and
  VMS have emulations for it.)
  
  Here is an example of using C<NVtime> from C:
  
    double (*myNVtime)(); /* Returns -1 on failure. */
    SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
    if (!svp)         croak("Time::HiRes is required");
    if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
    myNVtime = INT2PTR(double(*)(), SvIV(*svp));
    printf("The current time is: %f\n", (*myNVtime)());
  
  =head1 DIAGNOSTICS
  
  =head2 useconds or interval more than ...
  
  In ualarm() you tried to use number of microseconds or interval (also
  in microseconds) more than 1_000_000 and setitimer() is not available
  in your system to emulate that case.
  
  =head2 negative time not invented yet
  
  You tried to use a negative time argument.
  
  =head2 internal error: useconds < 0 (unsigned ... signed ...)
  
  Something went horribly wrong-- the number of microseconds that cannot
  become negative just became negative.  Maybe your compiler is broken?
  
  =head2 useconds or uinterval equal to or more than 1000000
  
  In some platforms it is not possible to get an alarm with subsecond
  resolution and later than one second.
  
  =head2 unimplemented in this platform
  
  Some calls simply aren't available, real or emulated, on every platform.
  
  =head1 CAVEATS
  
  Notice that the core C<time()> maybe rounding rather than truncating.
  What this means is that the core C<time()> may be reporting the time
  as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
  
  Adjusting the system clock (either manually or by services like ntp)
  may cause problems, especially for long running programs that assume
  a monotonously increasing time (note that all platforms do not adjust
  time as gracefully as UNIX ntp does).  For example in Win32 (and derived
  platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
  drift off from the system clock (and the original time())  by up to 0.5
  seconds. Time::HiRes will notice this eventually and recalibrate.
  Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
  might help in this (in case your system supports CLOCK_MONOTONIC).
  
  Some systems have APIs but not implementations: for example QNX and Haiku
  have the interval timer APIs but not the functionality.
  
  =head1 SEE ALSO
  
  Perl modules L<BSD::Resource>, L<Time::TAI64>.
  
  Your system documentation for C<clock>, C<clock_gettime>,
  C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>,
  C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>.
  
  =head1 AUTHORS
  
  D. Wegscheid <wegscd@whirlpool.com>
  R. Schertler <roderick@argon.org>
  J. Hietaniemi <jhi@iki.fi>
  G. Aas <gisle@aas.no>
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (c) 1996-2002 Douglas E. Wegscheid.  All rights reserved.
  
  Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
  All rights reserved.
  
  This program is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_TIME_HIRES

$fatpacked{"darwin-thread-multi-2level/Win32/DBIODBC.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_WIN32_DBIODBC';
  package			# hide this package from CPAN indexer
  	Win32::ODBC;
  
  #use strict;
  
  use DBI;
  
  # once we've been loaded we don't want perl to load the real Win32::ODBC
  $INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1;
  
  #my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};");
  
  #EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;");
  sub new
  {
  	shift;
  	my $connect_line= shift;
  
  # [R] self-hack to allow empty UID and PWD
  	my $temp_connect_line;
  	$connect_line=~/DSN=\w+/;
  	$temp_connect_line="$&;";
  	if ($connect_line=~/UID=\w?/)
  		{$temp_connect_line.="$&;";}
  	else	{$temp_connect_line.="UID=;";};
  	if ($connect_line=~/PWD=\w?/)
  		{$temp_connect_line.="$&;";}
  	else	{$temp_connect_line.="PWD=;";};
  	$connect_line=$temp_connect_line;
  # -[R]-
  	
  	my $self= {};
  		
  	
  	$_=$connect_line;
   	/^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/;
  
   	#---- DBI CONNECTION VARIABLES
  
   	$self->{ODBC_DSN}=$2;
   	$self->{ODBC_UID}=$4;
   	$self->{ODBC_PWD}=$6;
  	
  	
  	#---- DBI CONNECTION VARIABLES	
  	$self->{DBI_DBNAME}=$self->{ODBC_DSN};
  	$self->{DBI_USER}=$self->{ODBC_UID};
  	$self->{DBI_PASSWORD}=$self->{ODBC_PWD};
  	$self->{DBI_DBD}='ODBC';
          	
  	#---- DBI CONNECTION
  	$self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'},
  			$self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'});
  
  	warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'}; 
  
          
  	#---- RETURN 
  	
  	bless $self;
  }
  
  
  #EMU --- $db->Sql('SELECT * FROM DUAL');
  sub Sql
  {
   	my $self= shift;
   	my $SQL_statment=shift;
  
   #	print " SQL : $SQL_statment \n";
  	
  	$self->{'DBI_SQL_STATMENT'}=$SQL_statment;
  	
  	my $dbh=$self->{'DBI_DBH'};
  
   #	print " DBH : $dbh \n";
  	
  	my $sth=$dbh->prepare("$SQL_statment");
  	
   #	print " STH : $sth \n";
  	
  	$self->{'DBI_STH'}=$sth;
  	
  	if ($sth)
  	{
  		$sth->execute();
  	}
  	
  	#--- GET ERROR MESSAGES
  	$self->{DBI_ERR}=$DBI::err;
  	$self->{DBI_ERRSTR}=$DBI::errstr;
  
  	if ($sth)
  	{
  		#--- GET COLUMNS NAMES
  		$self->{'DBI_NAME'} = $sth->{NAME};
  	}
  
  # [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements
   	return ($self->{'DBI_ERR'})?1:undef;
  # -[R]-
  }
   
  
  #EMU --- $db->FetchRow())
  sub FetchRow
  { 
   	my $self= shift;
   	
   	my $sth=$self->{'DBI_STH'};
   	if ($sth)
  	{
  	 	my @row=$sth->fetchrow_array;
  	 	$self->{'DBI_ROW'}=\@row;
  
  	 	if (scalar(@row)>0)
  	 	{
  			#-- the row of result is not nul
  			#-- return somthing nothing will be return else
  			return 1;
  	 	} 	
  	}
  	return undef;
  } 
  
  # [R] provide compatibility with Win32::ODBC's Data() method.
  sub Data
  {
  	my $self=shift;
  	my @array=@{$self->{'DBI_ROW'}};
  	foreach my $element (@array)
  	{
  		# remove padding of spaces by DBI
  		$element=~s/(\s*$)//;
  	};
  	return (wantarray())?@array:join('', @array);
  };
  # -[R]-
   
  #EMU --- %record = $db->DataHash;
  sub DataHash
  { 
   	my $self= shift;
   	 	
   	my $p_name=$self->{'DBI_NAME'};
   	my $p_row=$self->{'DBI_ROW'};
  
   	my @name=@$p_name;
   	my @row=@$p_row;
  
   	my %DataHash;
  #print @name; print "\n"; print @row;
  # [R] new code that seems to work consistent with Win32::ODBC
  	while (@name)
  	{
  		my $name=shift(@name);
  		my $value=shift(@row);
  
  		# remove padding of spaces by DBI
  		$name=~s/(\s*$)//;
  		$value=~s/(\s*$)//;
  
  		$DataHash{$name}=$value;
  	};
  # -[R]-
  
  # [R] old code that didn't appear to work
  #	foreach my $name (@name)
  #	{
  #		$name=~s/(^\s*)|(\s*$)//;
  #		my @arr=@$name;
  #		foreach (@arr)
  #		{
  #			print "lot $name  name  col $_   or ROW= 0 $row[0]  1 $row[1] 2 $row[2] \n ";
  #			$DataHash{$name}=shift(@row);
  #		}
  #	}
  # -[R]-
  
   	#--- Return Hash
   	return %DataHash; 	
  } 
  
  
  #EMU --- $db->Error()
  sub Error
  { 
   	my $self= shift;
   	 	
   	if ($self->{'DBI_ERR'} ne '')
   	{
  		#--- Return error message
  		$self->{'DBI_ERRSTR'};
   	}
  
   	#-- else good no error message 	
   	
  }
  
  # [R] provide compatibility with Win32::ODBC's Close() method.
  sub Close
  {
  	my $self=shift;
  
  	my $dbh=$self->{'DBI_DBH'};
  	$dbh->disconnect;
  }
  # -[R]-
  
  1;
  
  __END__
  
  # [R] to -[R]- indicate sections edited by me, Roy Lee
  
  =head1 NAME
  
  Win32::DBIODBC - Win32::ODBC emulation layer for the DBI
  
  =head1 SYNOPSIS
  
    use Win32::DBIODBC;     # instead of use Win32::ODBC
  
  =head1 DESCRIPTION
  
  This is a I<very> basic I<very> alpha quality Win32::ODBC emulation
  for the DBI. To use it just replace
  
  	use Win32::ODBC;
  
  in your scripts with
  
  	use Win32::DBIODBC;
  
  or, while experimenting, you can pre-load this module without changing your
  scripts by doing
  
  	perl -MWin32::DBIODBC your_script_name
  
  =head1 TO DO
  
  Error handling is virtually non-existant.
  
  =head1 AUTHOR
  
  Tom Horen <tho@melexis.com>
  
  =cut
DARWIN-THREAD-MULTI-2LEVEL_WIN32_DBIODBC

$fatpacked{"darwin-thread-multi-2level/metaclass.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_METACLASS';
  
  package metaclass;
  BEGIN {
    $metaclass::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $metaclass::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Carp         'confess';
  use Class::Load  'load_class';
  use Scalar::Util 'blessed';
  use Try::Tiny;
  
  use Class::MOP;
  
  sub import {
      my ( $class, @args ) = @_;
  
      unshift @args, "metaclass" if @args % 2 == 1;
      my %options = @args;
  
      my $meta_name = exists $options{meta_name} ? $options{meta_name} : 'meta';
      my $metaclass = delete $options{metaclass};
  
      unless ( defined $metaclass ) {
          $metaclass = "Class::MOP::Class";
      } else {
          load_class($metaclass);
      }
  
      ($metaclass->isa('Class::MOP::Class'))
          || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
  
      # make sure the custom metaclasses get loaded
      foreach my $key (grep { /_(?:meta)?class$/ } keys %options) {
          unless ( ref( my $class = $options{$key} ) ) {
              load_class($class)
          }
      }
  
      my $package = caller();
  
      # create a meta object so we can install &meta
      my $meta = $metaclass->initialize($package => %options);
      $meta->_add_meta_method($meta_name)
          if defined $meta_name;
  }
  
  1;
  
  # ABSTRACT: a pragma for installing and using Class::MOP metaclasses
  
  
  
  =pod
  
  =head1 NAME
  
  metaclass - a pragma for installing and using Class::MOP metaclasses
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    package MyClass;
  
    # use Class::MOP::Class
    use metaclass;
  
    # ... or use a custom metaclass
    use metaclass 'MyMetaClass';
  
    # ... or use a custom metaclass
    # and custom attribute and method
    # metaclasses
    use metaclass 'MyMetaClass' => (
        'attribute_metaclass' => 'MyAttributeMetaClass',
        'method_metaclass'    => 'MyMethodMetaClass',
    );
  
    # ... or just specify custom attribute
    # and method classes, and Class::MOP::Class
    # is the assumed metaclass
    use metaclass (
        'attribute_metaclass' => 'MyAttributeMetaClass',
        'method_metaclass'    => 'MyMethodMetaClass',
    );
  
    # if we'd rather not install a 'meta' method, we can do this
    use metaclass meta_name => undef;
    # or if we'd like it to have a different name,
    use metaclass meta_name => 'my_meta';
  
  =head1 DESCRIPTION
  
  This is a pragma to make it easier to use a specific metaclass
  and a set of custom attribute and method metaclasses. It also
  installs a C<meta> method to your class as well, unless C<undef>
  is passed to the C<meta_name> option.
  
  Note that if you are using Moose, you most likely do B<not> want
  to be using this - look into L<Moose::Util::MetaRole> instead.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_METACLASS

$fatpacked{"darwin-thread-multi-2level/oose.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_OOSE';
  package oose;
  BEGIN {
    $oose::AUTHORITY = 'cpan:STEVAN';
  }
  {
    $oose::VERSION = '2.0401';
  }
  
  use strict;
  use warnings;
  
  use Class::Load qw(load_class);
  
  BEGIN {
      my $package;
      sub import {
          $package = $_[1] || 'Class';
          if ($package =~ /^\+/) {
              $package =~ s/^\+//;
              load_class($package);
          }
      }
      use Filter::Simple sub { s/^/package $package;\nuse Moose;use Moose::Util::TypeConstraints;\n/; }
  }
  
  1;
  
  # ABSTRACT: syntactic sugar to make Moose one-liners easier
  
  
  
  =pod
  
  =head1 NAME
  
  oose - syntactic sugar to make Moose one-liners easier
  
  =head1 VERSION
  
  version 2.0401
  
  =head1 SYNOPSIS
  
    # create a Moose class on the fly ...
    perl -Moose=Foo -e 'has bar => ( is=>q[ro], default => q[baz] ); print Foo->new->bar' # prints baz
  
    # loads an existing class (Moose or non-Moose)
    # and re-"opens" the package definition to make
    # debugging/introspection easier
    perl -Moose=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list'
  
    # also loads Moose::Util::TypeConstraints to allow subtypes etc
    perl -Moose=Person -e'subtype q[ValidAge] => as q[Int] => where { $_ > 0 && $_ < 78 }; has => age ( isa => q[ValidAge], is => q[ro]); Person->new(age => 90)'
  
  =head1 DESCRIPTION
  
  oose.pm is a simple source filter that adds
  C<package $name; use Moose; use Moose::Util::TypeConstraints;>
  to the beginning of your script and was entirely created because typing
  C<perl -e'package Foo; use Moose; ...'> was annoying me.
  
  =head1 INTERFACE
  
  oose provides exactly one method and it's automatically called by perl:
  
  =over 4
  
  =item B<import($package)>
  
  Pass a package name to import to be used by the source filter. The
  package defaults to C<Class> if none is given.
  
  =back
  
  =head1 DEPENDENCIES
  
  You will need L<Filter::Simple> and eventually L<Moose>
  
  =head1 INCOMPATIBILITIES
  
  None reported. But it is a source filter and might have issues there.
  
  =head1 BUGS
  
  See L<Moose/BUGS> for details on reporting bugs.
  
  =head1 AUTHOR
  
  Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2011 by Infinity Interactive, Inc..
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as the Perl 5 programming language system itself.
  
  =cut
  
  
  __END__
  
DARWIN-THREAD-MULTI-2LEVEL_OOSE

$fatpacked{"darwin-thread-multi-2level/version.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_VERSION';
  #!perl -w
  package version;
  
  use 5.005_04;
  use strict;
  
  use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
  
  $VERSION = 0.95;
  
  $CLASS = 'version';
  
  #--------------------------------------------------------------------------#
  # Version regexp components
  #--------------------------------------------------------------------------#
  
  # Fraction part of a decimal version number.  This is a common part of
  # both strict and lax decimal versions
  
  my $FRACTION_PART = qr/\.[0-9]+/;
  
  # First part of either decimal or dotted-decimal strict version number.
  # Unsigned integer with no leading zeroes (except for zero itself) to
  # avoid confusion with octal.
  
  my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
  
  # First part of either decimal or dotted-decimal lax version number.
  # Unsigned integer, but allowing leading zeros.  Always interpreted
  # as decimal.  However, some forms of the resulting syntax give odd
  # results if used as ordinary Perl expressions, due to how perl treats
  # octals.  E.g.
  #   version->new("010" ) == 10
  #   version->new( 010  ) == 8
  #   version->new( 010.2) == 82  # "8" . "2"
  
  my $LAX_INTEGER_PART = qr/[0-9]+/;
  
  # Second and subsequent part of a strict dotted-decimal version number.
  # Leading zeroes are permitted, and the number is always decimal.
  # Limited to three digits to avoid overflow when converting to decimal
  # form and also avoid problematic style with excessive leading zeroes.
  
  my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
  
  # Second and subsequent part of a lax dotted-decimal version number.
  # Leading zeroes are permitted, and the number is always decimal.  No
  # limit on the numerical value or number of digits, so there is the
  # possibility of overflow when converting to decimal form.
  
  my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
  
  # Alpha suffix part of lax version number syntax.  Acts like a
  # dotted-decimal part.
  
  my $LAX_ALPHA_PART = qr/_[0-9]+/;
  
  #--------------------------------------------------------------------------#
  # Strict version regexp definitions
  #--------------------------------------------------------------------------#
  
  # Strict decimal version number.
  
  my $STRICT_DECIMAL_VERSION =
      qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
  
  # Strict dotted-decimal version number.  Must have both leading "v" and
  # at least three parts, to avoid confusion with decimal syntax.
  
  my $STRICT_DOTTED_DECIMAL_VERSION =
      qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
  
  # Complete strict version number syntax -- should generally be used
  # anchored: qr/ \A $STRICT \z /x
  
  $STRICT =
      qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
  
  #--------------------------------------------------------------------------#
  # Lax version regexp definitions
  #--------------------------------------------------------------------------#
  
  # Lax decimal version number.  Just like the strict one except for
  # allowing an alpha suffix or allowing a leading or trailing
  # decimal-point
  
  my $LAX_DECIMAL_VERSION =
      qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
  	|
  	$FRACTION_PART $LAX_ALPHA_PART?
      /x;
  
  # Lax dotted-decimal version number.  Distinguished by having either
  # leading "v" or at least three non-alpha parts.  Alpha part is only
  # permitted if there are at least two non-alpha parts. Strangely
  # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
  # so when there is no "v", the leading part is optional
  
  my $LAX_DOTTED_DECIMAL_VERSION =
      qr/
  	v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
  	|
  	$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
      /x;
  
  # Complete lax version number syntax -- should generally be used
  # anchored: qr/ \A $LAX \z /x
  #
  # The string 'undef' is a special case to make for easier handling
  # of return values from ExtUtils::MM->parse_version
  
  $LAX =
      qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
  
  #--------------------------------------------------------------------------#
  
  {
      local $SIG{'__DIE__'};
      eval "use version::vxs $VERSION";
      if ( $@ ) { # don't have the XS version installed
  	eval "use version::vpp $VERSION"; # don't tempt fate
  	die "$@" if ( $@ );
  	push @ISA, "version::vpp";
  	local $^W;
  	*version::qv = \&version::vpp::qv;
  	*version::declare = \&version::vpp::declare;
  	*version::_VERSION = \&version::vpp::_VERSION;
  	if ($] >= 5.009000) {
  	    no strict 'refs';
  	    *version::stringify = \&version::vpp::stringify;
  	    *{'version::(""'} = \&version::vpp::stringify;
  	    *version::new = \&version::vpp::new;
  	    *version::parse = \&version::vpp::parse;
  	}
      }
      else { # use XS module
  	push @ISA, "version::vxs";
  	local $^W;
  	*version::declare = \&version::vxs::declare;
  	*version::qv = \&version::vxs::qv;
  	*version::_VERSION = \&version::vxs::_VERSION;
  	*version::vcmp = \&version::vxs::VCMP;
  	if ($] >= 5.009000) {
  	    no strict 'refs';
  	    *version::stringify = \&version::vxs::stringify;
  	    *{'version::(""'} = \&version::vxs::stringify;
  	    *version::new = \&version::vxs::new;
  	    *version::parse = \&version::vxs::parse;
  	}
  
      }
  }
  
  # Preloaded methods go here.
  sub import {
      no strict 'refs';
      my ($class) = shift;
  
      # Set up any derived class
      unless ($class eq 'version') {
  	local $^W;
  	*{$class.'::declare'} =  \&version::declare;
  	*{$class.'::qv'} = \&version::qv;
      }
  
      my %args;
      if (@_) { # any remaining terms are arguments
  	map { $args{$_} = 1 } @_
      }
      else { # no parameters at all on use line
      	%args = 
  	(
  	    qv => 1,
  	    'UNIVERSAL::VERSION' => 1,
  	);
      }
  
      my $callpkg = caller();
      
      if (exists($args{declare})) {
  	*{$callpkg.'::declare'} = 
  	    sub {return $class->declare(shift) }
  	  unless defined(&{$callpkg.'::declare'});
      }
  
      if (exists($args{qv})) {
  	*{$callpkg.'::qv'} =
  	    sub {return $class->qv(shift) }
  	  unless defined(&{$callpkg.'::qv'});
      }
  
      if (exists($args{'UNIVERSAL::VERSION'})) {
  	local $^W;
  	*UNIVERSAL::VERSION 
  		= \&version::_VERSION;
      }
  
      if (exists($args{'VERSION'})) {
  	*{$callpkg.'::VERSION'} = \&version::_VERSION;
      }
  
      if (exists($args{'is_strict'})) {
  	*{$callpkg.'::is_strict'} = \&version::is_strict
  	  unless defined(&{$callpkg.'::is_strict'});
      }
  
      if (exists($args{'is_lax'})) {
  	*{$callpkg.'::is_lax'} = \&version::is_lax
  	  unless defined(&{$callpkg.'::is_lax'});
      }
  }
  
  sub is_strict	{ defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
  sub is_lax	{ defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_VERSION

$fatpacked{"darwin-thread-multi-2level/version/vxs.pm"} = <<'DARWIN-THREAD-MULTI-2LEVEL_VERSION_VXS';
  #!perl -w
  package version::vxs;
  
  use 5.005_03;
  use strict;
  
  use vars qw(@ISA $VERSION $CLASS );
  
  $VERSION = 0.95;
  
  $CLASS = 'version::vxs';
  
  eval {
      require XSLoader;
      local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
      XSLoader::load('version::vxs', $VERSION);
      1;
  } or do {
      require DynaLoader;
      push @ISA, 'DynaLoader'; 
      local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
      bootstrap version::vxs $VERSION;
  };
  
  # Preloaded methods go here.
  
  1;
DARWIN-THREAD-MULTI-2LEVEL_VERSION_VXS

s/^  //mg for values %fatpacked;

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

} # END OF FATPACK CODE
#!/usr/bin/env perl

=head1 NAME

dist_surveyor - determine exactly what dist versions are installed

=head1 VERSION

version 0.002

=head1 SYNOPSIS

  dist_surveyor [options] /some/perl/lib/dir

Typically a perl library directory will have an architecture specific library
as a subdirectory. The dist_surveyor script will detect and add it automatically
if the perl being used has the same 'archname' the same as the one in the library.
If not, then specify the "archlib" directory explicitly I<first>:

  dist_surveyor [options] /some/perl/lib/dir/archname /some/perl/lib/dir

=head1 DESCRIPTION

This utility examines all the modules installed within the specified perl
library directory and uses the metacpan API to work out what versions of what
distributions could have provided those modules. It then works out which of
those candidate distributions is the most likely one.

It is fairly robust and copes well with edge cases like installation of
non-released versions from git repos and local modifications.

Distributions are written to stdout. Progress and issues are reported to stderr.

It can take a long time to run for the first time on a directory with a
large number of modules and candidate distributions.  The data fetched from
metacpan is cached so future runs are much faster.  (The system this code was
tested on took about 60 minutes to process around 500 distributions with no
cached data, and under 10 minutes for later runs that could reuse the cached
data. The cache file ended up about 40MB in size.)

=head1 OPTIONS

    --verbose    Show more detailed progress

    --debug      Show much more information

    --match R    Ignore modules that don't match regex R (unanchored)

    --perlver V  Ignore modules that are shipped with perl version V

    --remnants   Include old distribution versions that have left old modules behind

    --uncached   Don't use or update the persistent cache

    --makecpan D Create a CPAN repository in directory D

    --output S   List of field names to output, separate by spaces.
                 
    --format S   Printf format string with a %s for each field in --output

=head2 --makecpan

Creates a CPAN repository in the specified directory by fetching the selected
distributions into authors/id/... and writing the index files into modules/...

If the directory already exists then selected distributions that already exist
are not refetched, any distributions that already exist but aren't selected by
this run are left in place.

New package distribution information is merged into the modules/02packages index file.

Some additional files are written into a dist_surveyor subdirectory:

=head3 dist_surveyor/token_packages.txt

This file lists one unique 'token package' per distribution. It's very useful
to speed up re-running a full install after some distributions have failed.

=head1 SURVEY USAGE

Run a survey and create a mini-CPAN repository containing the distributions:

    dist_surveyor --makecpan my_cpan /some/perl/lib/dir > installed_dists.txt

It's important to give the correct perl lib directory path.

It's important to check the results related to any modules that generated
warnings during the run.

=head1 INSTALLATION USAGE

Then, to install those distributions into a new library:

    cpanm --mirror file:$PWD/my_cpan --mirror-only [-l new_lib] < installed_dists.txt

It's very likely that some distributions will fail tests and not install,
which will, in turn, cause others to fail. Once the initial run is complete
study the cpam build log file carefully and resolve the test failures.

Running cpanm with a list of distributions, as above, will always reinstall
I<all> the listed distributions. Even those already sucessfully installed.

It's much (I<much>) faster to give cpanm a list of package names as that allows
it to skip those that it knows are already installed. The L</--makecpan> option
writes a list of 'token packages', one per distribution, so you can use that
with cpanm:

    cpanm --mirror file:$PWD/my_cpan --mirror-only [-l new_lib] < my_cpan/dist_surveyor/token_packages.txt

When a distro fails tests I use the cpanm C<--look> option to investigate:

    cpanm --mirror file:$PWD/my_cpan --mirror-only --look Some::Package

I'll often end up building, testing and installing the distro from within that
cpanm look shell. Once installed I'll rerun cpanm using the full C<token_packages.txt>
file again. If there are more failures I'll repeat that sequence till they're all resolved.

=head1 BUGS

Probably.

=head1 TODO

    * Polish up, refactor, add tests etc. Including making Dist::Surveyor a proper
        module that exports functions (or uses methods) and changing dist_surveyor
        to use that interface.

    * Auto-detect when directory given isn't the root of a perl library dir tree.
        E.g. by matching file names to module names

    * Add support for matching Foo.pm.PL files (e.g. FCGI and common::sense)

    * For installed modules get the file modification time (last commit time)
        and use it to eliminate candidate dists that were released after that time.

    * Consider factoring in release status ('authorized') so rogue releases
        that ship copies of many other modules (like Net-Braintree-0.1.1)
        are given a lower priority.

    * Sort out ExtUtils::Perllocal::Parser situation
        Avoid hard-coded %distro_key_mod_names related to perllocal.pod where the
        dist name doesn't match the key module name.
        Or maybe just remove use of distro_key_mod_names and perllocal entirely?

    * Optimise use of metacpan. Check caching. Use ElasticSearch.pm.

    * Fully handle merging of pre-existing --makecpan directory data files.

    * Consider factoring install date in the output ordering. May help with edge cases
        where a package P is installed via distros A then B. If A is reinstalled after B
        then the reinstalled P will be from A but should be from B. (I don't know of any
        cases, but it's certainly a possibility. The LWP breakup and Class::MOP spring to
        mind as possible candidates.)

=cut

use strict;
use warnings;

$| = 1;

use Dist::Surveyor;

# XXX nasty quick hack conversion from script to module
# TODO refactor to give Dist::Surveyor a reasonable simple API
# and use that here
Dist::Surveyor::main(@ARGV);

exit 0;
