#!/usr/bin/env perl

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

$fatpacked{"Apache/LogFormat/Compiler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APACHE_LOGFORMAT_COMPILER';
  package Apache::LogFormat::Compiler;
  
  use strict;
  use warnings;
  use 5.008001;
  use Carp;
  use POSIX::strftime::Compiler qw//;
  use constant {
      ENVS => 0,
      RES => 1,
      LENGTH => 2,
      REQTIME => 3,
      TIME => 4,
  };
  
  our $VERSION = '0.32';
  
  # copy from Plack::Middleware::AccessLog
  our %formats = (
      common => '%h %l %u %t "%r" %>s %b',
      combined => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"',
  );
  
  sub _safe {
      my $string = shift;
      return unless defined $string;
      $string =~ s/([^[:print:]])/"\\x" . unpack("H*", $1)/eg;
      return $string;
  }
  
  sub _string {
      my $string = shift;
      return '-' if ! defined $string;
      return '-' if ! length $string;
      $string =~ s/([^[:print:]])/"\\x" . unpack("H*", $1)/eg;
      return $string;
  }
  
  sub header_get {
      my ($headers, $key) = @_;
      $key = lc $key;
      my @headers = @$headers; # copy
      my $value;
      while (my($hdr, $val) = splice @headers, 0, 2) {
          if ( lc $hdr eq $key ) {
              $value = $val;
              last;
          }
      }
      return $value;
  }
  
  my $psgi_reserved = { CONTENT_LENGTH => 1, CONTENT_TYPE => 1 };
  
  my $block_handler = sub {
      my($block, $type, $extra) = @_;
      my $cb;
      if ($type eq 'i') {
          $block =~ s/-/_/g;
          $block = uc($block);
          $block = "HTTP_${block}" unless $psgi_reserved->{$block};
          $cb =  q!_string($_[ENVS]->{'!.$block.q!'})!;
      } elsif ($type eq 'o') {
          $cb =  q!_string(header_get($_[RES]->[1],'!.$block.q!'))!;
      } elsif ($type eq 't') {
          $cb =  q!"[" . POSIX::strftime::Compiler::strftime('!.$block.q!', @lt) . "]"!;
      } elsif (exists $extra->{$type}) {
          $cb =  q!_string($extra_block_handlers->{'!.$type.q!'}->('!.$block.q!',$_[ENVS],$_[RES],$_[LENGTH],$_[REQTIME]))!;
      } else {
          Carp::croak("{$block}$type not supported");
          $cb = "-";
      }
      return q|! . | . $cb . q|
        . q!|;
  };
  
  our %char_handler = (
      '%' => q!'%'!,
      h => q!($_[ENVS]->{REMOTE_ADDR} || '-')!,
      l => q!'-'!,
      u => q!($_[ENVS]->{REMOTE_USER} || '-')!,
      t => q!'[' . $t . ']'!,
      r => q!_safe($_[ENVS]->{REQUEST_METHOD}) . " " . _safe($_[ENVS]->{REQUEST_URI}) .
                         " " . $_[ENVS]->{SERVER_PROTOCOL}!,
      s => q!$_[RES]->[0]!,
      b => q!(defined $_[LENGTH] ? $_[LENGTH] : '-')!,
      T => q!(defined $_[REQTIME] ? int($_[REQTIME]*1_000_000) : '-')!,
      D => q!(defined $_[REQTIME] ? $_[REQTIME] : '-')!,
      v => q!($_[ENVS]->{SERVER_NAME} || '-')!,
      V => q!($_[ENVS]->{HTTP_HOST} || $_[ENVS]->{SERVER_NAME} || '-')!,
      p => q!$_[ENVS]->{SERVER_PORT}!,
      P => q!$$!,
      m => q!_safe($_[ENVS]->{REQUEST_METHOD})!,
      U => q!_safe($_[ENVS]->{PATH_INFO})!,
      q => q!(($_[ENVS]->{QUERY_STRING} ne '') ? '?' . _safe($_[ENVS]->{QUERY_STRING}) : '' )!,
      H => q!$_[ENVS]->{SERVER_PROTOCOL}!,
  
  );
  
  my $char_handler = sub {
      my ($char, $extra) = @_;
      my $cb = $char_handler{$char};
      if (!$cb && exists $extra->{$char}) {
          $cb = q!_string($extra_char_handlers->{'!.$char.q!'}->($_[ENVS],$_[RES],$_[LENGTH],$_[REQTIME]))!;
      }
      unless ($cb) {
          Carp::croak "\%$char not supported.";
          return "-";
      }
      q|! . | . $cb . q|
        . q!|;
  };
  
  sub new {
      my $class = shift;
  
      my $fmt = shift || "combined";
      $fmt = $formats{$fmt} if exists $formats{$fmt};
  
      my %opts = @_;
  
      my ($code_ref, $code) = compile($fmt, $opts{block_handlers} || {}, $opts{char_handlers} || {});
      bless [$code_ref, $code], $class;
  }
  
  sub compile {
      my $fmt = shift;
      my $extra_block_handlers = shift;
      my $extra_char_handlers = shift;
      $fmt =~ s/!/\\!/g;
      $fmt =~ s!
          (?:
               \%\{(.+?)\}([a-zA-Z]) |
               \%(?:[<>])?([a-zA-Z\%])
          )
      ! $1 ? $block_handler->($1, $2, $extra_block_handlers) : $char_handler->($3, $extra_char_handlers) !egx;
      
      my @abbr = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
      my $c = {};
      $fmt = q~sub {
          $_[TIME] = time() if ! defined $_[TIME];
          my @lt = localtime($_[TIME]);
          if ( ! exists $c->{tz_cache} || ! exists $c->{isdst_cache} || $lt[8] != $c->{isdst_cache} ) {
              $c->{tz_cache} = POSIX::strftime::Compiler::strftime('%z',@lt);
              $c->{isdst_cache} = $lt[8];
          }    
          my $t = sprintf '%02d/%s/%04d:%02d:%02d:%02d %s', $lt[3], $abbr[$lt[4]], $lt[5]+1900,
            $lt[2], $lt[1], $lt[0], $c->{tz_cache};
          q!~ . $fmt . q~!
      }~;
      my $code_ref = eval $fmt; ## no critic
      die $@ . "\n===\n" . $fmt if $@;
      wantarray ? ($code_ref, $fmt) : $code_ref;
  }
  
  sub log_line {
      my $self = shift;
      $self->[0]->(@_) . "\n";
  }
  
  sub code {
      my $self = shift;
      $self->[1];
  }
  
  sub code_ref {
      my $self = shift;
      $self->[0];
  }
  
  1;
  __END__
  
  =encoding utf8
  
  =head1 NAME
  
  Apache::LogFormat::Compiler - Compile a log format string to perl-code 
  
  =head1 SYNOPSIS
  
    use Apache::LogFormat::Compiler;
  
    my $log_handler = Apache::LogFormat::Compiler->new("combined");
    my $log = $log_handler->log_line(
        $env,
        $res,
        $length,
        $reqtime,
        $time
    );
  
  =head1 DESCRIPTION
  
  Compile a log format string to perl-code. For faster generation of access_log lines.
  
  =head1 METHOD
  
  =over 4
  
  =item new($fmt:String)
  
  Takes a format string (or a preset template C<combined> or C<custom>)
  to specify the log format. This module implements a subset of
  L<Apache's LogFormat templates|http://httpd.apache.org/docs/2.0/mod/mod_log_config.html>:
  
     %%    a percent sign
     %h    REMOTE_ADDR from the PSGI environment, or -
     %l    remote logname not implemented (currently always -)
     %u    REMOTE_USER from the PSGI environment, or -
     %t    [local timestamp, in default format]
     %r    REQUEST_METHOD, REQUEST_URI and SERVER_PROTOCOL from the PSGI environment
     %s    the HTTP status code of the response
     %b    content length of the response
     %T    custom field for handling times in subclasses
     %D    custom field for handling sub-second times in subclasses
     %v    SERVER_NAME from the PSGI environment, or -
     %V    HTTP_HOST or SERVER_NAME from the PSGI environment, or -
     %p    SERVER_PORT from the PSGI environment
     %P    the worker's process id
     %m    REQUEST_METHOD from the PSGI environment
     %U    PATH_INFO from the PSGI environment
     %q    QUERY_STRING from the PSGI environment
     %H    SERVER_PROTOCOL from the PSGI environment
  
  In addition, custom values can be referenced, using C<%{name}>,
  with one of the mandatory modifier flags C<i>, C<o> or C<t>:
  
     %{variable-name}i    HTTP_VARIABLE_NAME value from the PSGI environment
     %{header-name}o      header-name header in the response
     %{time-format]t      localtime in the specified strftime format
  
  =item log_line($env:HashRef, $res:ArrayRef, $length:Integer, $reqtime:Integer, $time:Integer): $log:String
  
  Generates log line.
  
    $env      PSGI env request HashRef
    $res      PSGI response ArrayRef
    $length   Content-Length
    $reqtime  The time taken to serve request in microseconds. optional
    $time     Time the request was received. optional. If $time is undefined. current timestamp is used.
  
  Sample psgi 
  
    use Plack::Builder;
    use Time::HiRes;
    use Apache::LogFormat::Compiler;
  
    my $log_handler = Apache::LogFormat::Compiler->new(
        '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i" %D'
    );
    my $compile_log_app = builder {
        enable sub {
            my $app = shift;
            sub {
                my $env = shift;
                my $t0 = [gettimeofday];
                my $res = $app->();
                my $reqtime = int(Time::HiRes::tv_interval($t0) * 1_000_000);
                $env->{psgi.error}->print($log_handler->log_line(
                    $env,$res,6,$reqtime, $t0->[0]));
            }
        };
        $app
    };
  
  =back
  
  =head1 ABOUT POSIX::strftime::Compiler
  
  This module uses L<POSIX::strftime::Compiler> for generate datetime string. POSIX::strftime::Compiler provides GNU C library compatible strftime(3). But this module will not affected by the system locale. This feature is useful when you want to write loggers, servers and portable applications.
  
  =head1 ADD CUSTOM FORMAT STRING
  
  Apache::LogFormat::Compiler allows one to add a custom format string
  
    my $log_handler = Apache::LogFormat::Compiler->new(
        '%z %{HTTP_X_FORWARDED_FOR|REMOTE_ADDR}Z',
        char_handlers => +{
            'z' => sub {
                my ($env,$req) = @_;
                return $env->{HTTP_X_FORWARDED_FOR};
            }
        },
        block_handlers => +{
            'Z' => sub {
                my ($block,$env,$req) = @_;
                # block eq 'HTTP_X_FORWARDED_FOR|REMOTE_ADDR'
                my ($main, $alt) = split('\|', $args);
                return exists $env->{$main} ? $env->{$main} : $env->{$alt};
            }
        },
    );
  
  Any single letter can be used, other than those already defined by Apache::LogFormat::Compiler.
  Your sub is called with two or three arguments: the content inside the C<{}>
  from the format (block_handlers only), the PSGI environment (C<$env>),
  and the ArrayRef of the response. It should return the string to be logged.
  
  =head1 AUTHOR
  
  Masahiro Nagano E<lt>kazeburo@gmail.comE<gt>
  
  =head1 SEE ALSO
  
  L<Plack::Middleware::AccessLog>, L<http://httpd.apache.org/docs/2.2/mod/mod_log_config.html>
  
  =head1 LICENSE
  
  Copyright (C) Masahiro Nagano
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
APACHE_LOGFORMAT_COMPILER

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

$fatpacked{"HTTP/Body.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY';
  package HTTP::Body;
  $HTTP::Body::VERSION = '1.22';
  use strict;
  
  use Carp       qw[ ];
  
  our $TYPES = {
      'application/octet-stream'          => 'HTTP::Body::OctetStream',
      'application/x-www-form-urlencoded' => 'HTTP::Body::UrlEncoded',
      'multipart/form-data'               => 'HTTP::Body::MultiPart',
      'multipart/related'                 => 'HTTP::Body::XFormsMultipart',
      'application/xml'                   => 'HTTP::Body::XForms',
      'application/json'                  => 'HTTP::Body::OctetStream',
  };
  
  require HTTP::Body::OctetStream;
  require HTTP::Body::UrlEncoded;
  require HTTP::Body::MultiPart;
  require HTTP::Body::XFormsMultipart;
  require HTTP::Body::XForms;
  
  use HTTP::Headers;
  use HTTP::Message;
  
  =head1 NAME
  
  HTTP::Body - HTTP Body Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body;
      
      sub handler : method {
          my ( $class, $r ) = @_;
  
          my $content_type   = $r->headers_in->get('Content-Type');
          my $content_length = $r->headers_in->get('Content-Length');
          
          my $body   = HTTP::Body->new( $content_type, $content_length );
          my $length = $content_length;
  
          while ( $length ) {
  
              $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 );
  
              $length -= length($buffer);
              
              $body->add($buffer);
          }
          
          my $uploads     = $body->upload;     # hashref
          my $params      = $body->param;      # hashref
          my $param_order = $body->param_order # arrayref
          my $body        = $body->body;       # IO::Handle
      }
  
  =head1 DESCRIPTION
  
  HTTP::Body parses chunks of HTTP POST data and supports
  application/octet-stream, application/json, application/x-www-form-urlencoded,
  and multipart/form-data.
  
  Chunked bodies are supported by not passing a length value to new().
  
  It is currently used by L<Catalyst> to parse POST bodies.
  
  =head1 NOTES
  
  When parsing multipart bodies, temporary files are created to store any
  uploaded files.  You must delete these temporary files yourself after
  processing them, or set $body->cleanup(1) to automatically delete them
  at DESTROY-time.
  
  =head1 METHODS
  
  =over 4 
  
  =item new 
  
  Constructor. Takes content type and content length as parameters,
  returns a L<HTTP::Body> object.
  
  =cut
  
  sub new {
      my ( $class, $content_type, $content_length ) = @_;
  
      unless ( @_ >= 2 ) {
          Carp::croak( $class, '->new( $content_type, [ $content_length ] )' );
      }
  
      my $type;
      my $earliest_index;
      foreach my $supported ( keys %{$TYPES} ) {
          my $index = index( lc($content_type), $supported );
          if ($index >= 0 && (!defined $earliest_index || $index < $earliest_index)) {
              $type           = $supported;
              $earliest_index = $index;
          }
      }
  
      my $body = $TYPES->{ $type || 'application/octet-stream' };
  
      my $self = {
          cleanup        => 0,
          buffer         => '',
          chunk_buffer   => '',
          body           => undef,
          chunked        => !defined $content_length,
          content_length => defined $content_length ? $content_length : -1,
          content_type   => $content_type,
          length         => 0,
          param          => {},
          param_order    => [],
          state          => 'buffering',
          upload         => {},
          part_data      => {},
          tmpdir         => File::Spec->tmpdir(),
      };
  
      bless( $self, $body );
  
      return $self->init;
  }
  
  sub DESTROY {
      my $self = shift;
      
      if ( $self->{cleanup} ) {
          my @temps = ();
          for my $upload ( values %{ $self->{upload} } ) {
              push @temps, map { $_->{tempname} || () }
                  ( ref $upload eq 'ARRAY' ? @{$upload} : $upload );
          }
          
          unlink map { $_ } grep { -e $_ } @temps;
      }
  }
  
  =item add
  
  Add string to internal buffer. Will call spin unless done. returns
  length before adding self.
  
  =cut
  
  sub add {
      my $self = shift;
      
      if ( $self->{chunked} ) {
          $self->{chunk_buffer} .= $_[0];
          
          while ( $self->{chunk_buffer} =~ m/^([\da-fA-F]+).*\x0D\x0A/ ) {
              my $chunk_len = hex($1);
              
              if ( $chunk_len == 0 ) {
                  # Strip chunk len
                  $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
                  
                  # End of data, there may be trailing headers
                  if (  my ($headers) = $self->{chunk_buffer} =~ m/(.*)\x0D\x0A/s ) {
                      if ( my $message = HTTP::Message->parse( $headers ) ) {
                          $self->{trailing_headers} = $message->headers;
                      }
                  }
                  
                  $self->{chunk_buffer} = '';
                  
                  # Set content_length equal to the amount of data we read,
                  # so the spin methods can finish up.
                  $self->{content_length} = $self->{length};
              }
              else {
                  # Make sure we have the whole chunk in the buffer (+CRLF)
                  if ( length( $self->{chunk_buffer} ) >= $chunk_len ) {
                      # Strip chunk len
                      $self->{chunk_buffer} =~ s/^([\da-fA-F]+).*\x0D\x0A//;
                      
                      # Pull chunk data out of chunk buffer into real buffer
                      $self->{buffer} .= substr $self->{chunk_buffer}, 0, $chunk_len, '';
                  
                      # Strip remaining CRLF
                      $self->{chunk_buffer} =~ s/^\x0D\x0A//;
                  
                      $self->{length} += $chunk_len;
                  }
                  else {
                      # Not enough data for this chunk, wait for more calls to add()
                      return;
                  }
              }
              
              unless ( $self->{state} eq 'done' ) {
                  $self->spin;
              }
          }
          
          return;
      }
      
      my $cl = $self->content_length;
  
      if ( defined $_[0] ) {
          $self->{length} += length( $_[0] );
          
          # Don't allow buffer data to exceed content-length
          if ( $self->{length} > $cl ) {
              $_[0] = substr $_[0], 0, $cl - $self->{length};
              $self->{length} = $cl;
          }
          
          $self->{buffer} .= $_[0];
      }
  
      unless ( $self->state eq 'done' ) {
          $self->spin;
      }
  
      return ( $self->length - $cl );
  }
  
  =item body
  
  accessor for the body.
  
  =cut
  
  sub body {
      my $self = shift;
      $self->{body} = shift if @_;
      return $self->{body};
  }
  
  =item chunked
  
  Returns 1 if the request is chunked.
  
  =cut
  
  sub chunked {
      return shift->{chunked};
  }
  
  =item cleanup
  
  Set to 1 to enable automatic deletion of temporary files at DESTROY-time.
  
  =cut
  
  sub cleanup {
      my $self = shift;
      $self->{cleanup} = shift if @_;
      return $self->{cleanup};
  }
  
  =item content_length
  
  Returns the content-length for the body data if known.
  Returns -1 if the request is chunked.
  
  =cut
  
  sub content_length {
      return shift->{content_length};
  }
  
  =item content_type
  
  Returns the content-type of the body data.
  
  =cut
  
  sub content_type {
      return shift->{content_type};
  }
  
  =item init
  
  return self.
  
  =cut
  
  sub init {
      return $_[0];
  }
  
  =item length
  
  Returns the total length of data we expect to read if known.
  In the case of a chunked request, returns the amount of data
  read so far.
  
  =cut
  
  sub length {
      return shift->{length};
  }
  
  =item trailing_headers
  
  If a chunked request body had trailing headers, trailing_headers will
  return an HTTP::Headers object populated with those headers.
  
  =cut
  
  sub trailing_headers {
      return shift->{trailing_headers};
  }
  
  =item spin
  
  Abstract method to spin the io handle.
  
  =cut
  
  sub spin {
      Carp::croak('Define abstract method spin() in implementation');
  }
  
  =item state
  
  Returns the current state of the parser.
  
  =cut
  
  sub state {
      my $self = shift;
      $self->{state} = shift if @_;
      return $self->{state};
  }
  
  =item param
  
  Get/set body parameters.
  
  =cut
  
  sub param {
      my $self = shift;
  
      if ( @_ == 2 ) {
  
          my ( $name, $value ) = @_;
  
          if ( exists $self->{param}->{$name} ) {
              for ( $self->{param}->{$name} ) {
                  $_ = [$_] unless ref($_) eq "ARRAY";
                  push( @$_, $value );
              }
          }
          else {
              $self->{param}->{$name} = $value;
          }
  
          push @{$self->{param_order}}, $name;
      }
  
      return $self->{param};
  }
  
  =item upload
  
  Get/set file uploads.
  
  =cut
  
  sub upload {
      my $self = shift;
  
      if ( @_ == 2 ) {
  
          my ( $name, $upload ) = @_;
  
          if ( exists $self->{upload}->{$name} ) {
              for ( $self->{upload}->{$name} ) {
                  $_ = [$_] unless ref($_) eq "ARRAY";
                  push( @$_, $upload );
              }
          }
          else {
              $self->{upload}->{$name} = $upload;
          }
      }
  
      return $self->{upload};
  }
  
  =item part_data
  
  Just like 'param' but gives you a hash of the full data associated with the
  part in a multipart type POST/PUT.  Example:
  
      {
        data => "test",
        done => 1,
        headers => {
          "Content-Disposition" => "form-data; name=\"arg2\"",
          "Content-Type" => "text/plain"
        },
        name => "arg2",
        size => 4
      }
  
  =cut
  
  sub part_data {
      my $self = shift;
  
      if ( @_ == 2 ) {
  
          my ( $name, $data ) = @_;
  
          if ( exists $self->{part_data}->{$name} ) {
              for ( $self->{part_data}->{$name} ) {
                  $_ = [$_] unless ref($_) eq "ARRAY";
                  push( @$_, $data );
              }
          }
          else {
              $self->{part_data}->{$name} = $data;
          }
      }
  
      return $self->{part_data};
  }
  
  =item tmpdir 
  
  Specify a different path for temporary files.  Defaults to the system temporary path.
  
  =cut
  
  sub tmpdir {
      my $self = shift;
      $self->{tmpdir} = shift if @_;
      return $self->{tmpdir};
  }
  
  =item param_order
  
  Returns the array ref of the param keys in the order how they appeared on the body
  
  =cut
  
  sub param_order {
      return shift->{param_order};
  }
  
  =back
  
  =head1 SUPPORT
  
  Since its original creation this module has been taken over by the Catalyst
  development team. If you want to contribute patches, these will be your
  primary contact points:
  
  IRC:
  
      Join #catalyst-dev on irc.perl.org.
  
  Mailing Lists:
  
      http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
  
  =head1 AUTHOR
  
  Christian Hansen, C<chansen@cpan.org>
  
  Sebastian Riedel, C<sri@cpan.org>
  
  Andy Grundman, C<andy@hybridized.org>
  
  =head1 CONTRIBUTORS
  
  Simon Elliott C<cpan@papercreatures.com>
  
  Kent Fredric <kentnl@cpan.org>
  
  Christian Walde
  
  Torsten Raudssus <torsten@raudssus.de>
  
  =head1 LICENSE
  
  This library is free software. You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY

$fatpacked{"HTTP/Body/MultiPart.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY_MULTIPART';
  package HTTP::Body::MultiPart;
  $HTTP::Body::MultiPart::VERSION = '1.22';
  use strict;
  use base 'HTTP::Body';
  use bytes;
  
  use IO::File;
  use File::Temp 0.14;
  use File::Spec;
  
  =head1 NAME
  
  HTTP::Body::MultiPart - HTTP Body Multipart Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body::Multipart;
  
  =head1 DESCRIPTION
  
  HTTP Body Multipart Parser.
  
  =head1 METHODS
  
  =over 4
  
  =item init
  
  =cut
  
  sub init {
      my $self = shift;
  
      unless ( $self->content_type =~ /boundary=\"?([^\";]+)\"?/ ) {
          my $content_type = $self->content_type;
          Carp::croak("Invalid boundary in content_type: '$content_type'");
      }
  
      $self->{boundary} = $1;
      $self->{state}    = 'preamble';
  
      return $self;
  }
  
  =item spin
  
  =cut
  
  sub spin {
      my $self = shift;
  
      while (1) {
  
          if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) {
              my $method = "parse_$1";
              return unless $self->$method;
          }
  
          else {
              Carp::croak('Unknown state');
          }
      }
  }
  
  =item boundary
  
  =cut
  
  sub boundary {
      return shift->{boundary};
  }
  
  =item boundary_begin
  
  =cut
  
  sub boundary_begin {
      return "--" . shift->boundary;
  }
  
  =item boundary_end
  
  =cut
  
  sub boundary_end {
      return shift->boundary_begin . "--";
  }
  
  =item crlf
  
  =cut
  
  sub crlf () {
      return "\x0d\x0a";
  }
  
  =item delimiter_begin
  
  =cut
  
  sub delimiter_begin {
      my $self = shift;
      return $self->crlf . $self->boundary_begin;
  }
  
  =item delimiter_end
  
  =cut
  
  sub delimiter_end {
      my $self = shift;
      return $self->crlf . $self->boundary_end;
  }
  
  =item parse_preamble
  
  =cut
  
  sub parse_preamble {
      my $self = shift;
  
      my $index = index( $self->{buffer}, $self->boundary_begin );
  
      unless ( $index >= 0 ) {
          return 0;
      }
  
      # replace preamble with CRLF so we can match dash-boundary as delimiter
      substr( $self->{buffer}, 0, $index, $self->crlf );
  
      $self->{state} = 'boundary';
  
      return 1;
  }
  
  =item parse_boundary
  
  =cut
  
  sub parse_boundary {
      my $self = shift;
  
      if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) {
  
          substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' );
          $self->{part}  = {};
          $self->{state} = 'header';
  
          return 1;
      }
  
      if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) {
  
          substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' );
          $self->{part}  = {};
          $self->{state} = 'done';
  
          return 0;
      }
  
      return 0;
  }
  
  =item parse_header
  
  =cut
  
  sub parse_header {
      my $self = shift;
  
      my $crlf  = $self->crlf;
      my $index = index( $self->{buffer}, $crlf . $crlf );
  
      unless ( $index >= 0 ) {
          return 0;
      }
  
      my $header = substr( $self->{buffer}, 0, $index );
  
      substr( $self->{buffer}, 0, $index + 4, '' );
  
      my @headers;
      for ( split /$crlf/, $header ) {
          if (s/^[ \t]+//) {
              $headers[-1] .= $_;
          }
          else {
              push @headers, $_;
          }
      }
  
      my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
  
      for my $header (@headers) {
  
          $header =~ s/^($token):[\t ]*//;
  
          ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg;
  
          if ( exists $self->{part}->{headers}->{$field} ) {
              for ( $self->{part}->{headers}->{$field} ) {
                  $_ = [$_] unless ref($_) eq "ARRAY";
                  push( @$_, $header );
              }
          }
          else {
              $self->{part}->{headers}->{$field} = $header;
          }
      }
  
      $self->{state} = 'body';
  
      return 1;
  }
  
  =item parse_body
  
  =cut
  
  sub parse_body {
      my $self = shift;
  
      my $index = index( $self->{buffer}, $self->delimiter_begin );
  
      if ( $index < 0 ) {
  
          # make sure we have enough buffer to detect end delimiter
          my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 );
  
          unless ( $length > 0 ) {
              return 0;
          }
  
          $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' );
          $self->{part}->{size} += $length;
          $self->{part}->{done} = 0;
  
          $self->handler( $self->{part} );
  
          return 0;
      }
  
      $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' );
      $self->{part}->{size} += $index;
      $self->{part}->{done} = 1;
  
      $self->handler( $self->{part} );
  
      $self->{state} = 'boundary';
  
      return 1;
  }
  
  =item handler
  
  =cut
  
  our $basename_regexp = qr/[^.]+(\.[^\\\/]+)$/;
  #our $basename_regexp = qr/(\.\w+(?:\.\w+)*)$/;
  
  sub handler {
      my ( $self, $part ) = @_;
  
      unless ( exists $part->{name} ) {
  
          my $disposition = $part->{headers}->{'Content-Disposition'};
          my ($name)      = $disposition =~ / name="?([^\";]+)"?/;
          my ($filename)  = $disposition =~ / filename="?([^\"]*)"?/;
          # Need to match empty filenames above, so this part is flagged as an upload type
  
          $part->{name} = $name;
  
          if ( defined $filename ) {
              $part->{filename} = $filename;
  
              if ( $filename ne "" ) {
                  my $basename = (File::Spec->splitpath($filename))[2];
                  my $suffix = $basename =~ $basename_regexp ? $1 : q{};
  
                  my $fh = File::Temp->new( UNLINK => 0, DIR => $self->tmpdir, SUFFIX => $suffix );
  
                  $part->{fh}       = $fh;
                  $part->{tempname} = $fh->filename;
              }
          }
      }
  
      if ( $part->{fh} && ( my $length = length( $part->{data} ) ) ) {
          $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length );
      }
  
      if ( $part->{done} ) {
  
          if ( exists $part->{filename} ) {
              if ( $part->{filename} ne "" ) {
                  $part->{fh}->close if defined $part->{fh};
  
                  delete @{$part}{qw[ data done fh ]};
  
                  $self->upload( $part->{name}, $part );
              }
          }
          # If we have more than the content-disposition, we need to create a
          # data key so that we don't waste the headers.
          else {
              $self->param( $part->{name}, $part->{data} );
              $self->part_data( $part->{name}, $part )
          }
      }
  }
  
  =back
  
  =head1 AUTHOR
  
  Christian Hansen, C<ch@ngmedia.com>
  
  =head1 LICENSE
  
  This library is free software . You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY_MULTIPART

$fatpacked{"HTTP/Body/OctetStream.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY_OCTETSTREAM';
  package HTTP::Body::OctetStream;
  $HTTP::Body::OctetStream::VERSION = '1.22';
  use strict;
  use base 'HTTP::Body';
  use bytes;
  
  use File::Temp 0.14;
  
  =head1 NAME
  
  HTTP::Body::OctetStream - HTTP Body OctetStream Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body::OctetStream;
  
  =head1 DESCRIPTION
  
  HTTP Body OctetStream Parser.
  
  =head1 METHODS
  
  =over 4
  
  =item spin
  
  =cut
  
  sub spin {
      my $self = shift;
  
      unless ( $self->body ) {
          $self->body( File::Temp->new( DIR => $self->tmpdir ) );
      }
  
      if ( my $length = length( $self->{buffer} ) ) {
          $self->body->write( substr( $self->{buffer}, 0, $length, '' ), $length );
      }
  
      if ( $self->length == $self->content_length ) {
          seek( $self->body, 0, 0 );
          $self->state('done');
      }
  }
  
  =back
  
  =head1 AUTHOR
  
  Christian Hansen, C<ch@ngmedia.com>
  
  =head1 LICENSE
  
  This library is free software . You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY_OCTETSTREAM

$fatpacked{"HTTP/Body/UrlEncoded.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY_URLENCODED';
  package HTTP::Body::UrlEncoded;
  $HTTP::Body::UrlEncoded::VERSION = '1.22';
  use strict;
  use base 'HTTP::Body';
  use bytes;
  
  our $DECODE = qr/%([0-9a-fA-F]{2})/;
  
  our %hex_chr;
  
  for my $num ( 0 .. 255 ) {
      my $h = sprintf "%02X", $num;
      $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num;
  }
  
  =head1 NAME
  
  HTTP::Body::UrlEncoded - HTTP Body UrlEncoded Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body::UrlEncoded;
  
  =head1 DESCRIPTION
  
  HTTP Body UrlEncoded Parser.
  
  =head1 METHODS
  
  =over 4
  
  =item spin
  
  =cut
  
  sub spin {
      my $self = shift;
  
      return unless $self->length == $self->content_length;
      
      # I tested parsing this using APR::Request, but perl is faster
      # Pure-Perl    2560/s
      # APR::Request 2305/s
      
      # Note: s/// appears faster than tr///
      $self->{buffer} =~ s/\+/ /g;
  
      for my $pair ( split( /[&;](?:\s+)?/, $self->{buffer} ) ) {
  
          my ( $name, $value ) = split( /=/, $pair , 2 );
  
          next unless defined $name;
          next unless defined $value;
          
          $name  =~ s/$DECODE/$hex_chr{$1}/gs;
          $value =~ s/$DECODE/$hex_chr{$1}/gs;
  
          $self->param( $name, $value );
      }
  
      $self->{buffer} = '';
      $self->{state}  = 'done';
  }
  
  =back
  
  =head1 AUTHORS
  
  Christian Hansen, C<ch@ngmedia.com>
  
  Andy Grundman, C<andy@hybridized.org>
  
  =head1 LICENSE
  
  This library is free software . You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY_URLENCODED

$fatpacked{"HTTP/Body/XForms.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY_XFORMS';
  package HTTP::Body::XForms;
  $HTTP::Body::XForms::VERSION = '1.22';
  use strict;
  use base 'HTTP::Body';
  use bytes;
  
  use File::Temp 0.14;
  
  =head1 NAME
  
  HTTP::Body::XForms - HTTP Body XForms Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body::XForms;
  
  =head1 DESCRIPTION
  
  HTTP Body XForms Parser. This module parses single part XForms
  submissions, which are identifiable by the content-type
  application/xml. The XML is stored unparsed on the parameter
  XForms:Model.
  
  =head1 METHODS
  
  =over 4
  
  =item spin
  
  This method is overwrited to set the param XForms:Model with
  the buffer content.
  
  =cut
  
  sub spin {
      my $self = shift;
  
      return unless $self->length == $self->content_length;
  
      $self->body($self->{buffer});
      $self->param( 'XForms:Model', $self->{buffer} );
      $self->{buffer} = '';
      $self->{state}  = 'done';
  
      return $self->SUPER::init();
  }
  
  =back
  
  =head1 AUTHOR
  
  Daniel Ruoso, C<daniel@ruoso.com>
  
  =head1 LICENSE
  
  This library is free software . You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY_XFORMS

$fatpacked{"HTTP/Body/XFormsMultipart.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_BODY_XFORMSMULTIPART';
  package HTTP::Body::XFormsMultipart;
  $HTTP::Body::XFormsMultipart::VERSION = '1.22';
  use strict;
  use base 'HTTP::Body::MultiPart';
  use bytes;
  
  use IO::File;
  use File::Temp 0.14;
  
  =head1 NAME
  
  HTTP::Body::XFormsMultipart - HTTP Body XForms multipart/related submission Parser
  
  =head1 SYNOPSIS
  
      use HTTP::Body::XForms;
  
  =head1 DESCRIPTION
  
  HTTP Body XForms submission Parser. Inherits HTTP::Body::MultiPart.
  
  This body type is used to parse XForms submission. In this case, the
  XML part that contains the model is indicated by the start attribute
  in the content-type. The XML content is stored unparsed on the
  parameter XForms:Model.
  
  =head1 METHODS
  
  =over 4
  
  =item init
  
  This function is overridden to detect the start part of the
  multipart/related post.
  
  =cut
  
  sub init {
      my $self = shift;
      $self->SUPER::init(@_);
      unless ( $self->content_type =~ /start=\"?\<?([^\"\>;,]+)\>?\"?/ ) {
          my $content_type = $self->content_type;
          Carp::croak( "Invalid boundary in content_type: '$content_type'" );
      }
      
      $self->{start} = $1;
  
      return $self;
  }
  
  =item start
  
  Defines the start part of the multipart/related body.
  
  =cut
  
  sub start {
      return shift->{start};
  }
  
  =item handler
  
  This function is overridden to differ the start part, which should be
  set as the XForms:Model param if its content type is application/xml.
  
  =cut
  
  sub handler {
      my ( $self, $part ) = @_;
  
      my $contentid = $part->{headers}{'Content-ID'};
      $contentid =~ s/^.*[\<\"]//;
      $contentid =~ s/[\>\"].*$//;
      
      if ( $contentid eq $self->start ) {
          $part->{name} = 'XForms:Model';
          if ($part->{done}) {
              $self->body($part->{data});
          }
      }
      elsif ( defined $contentid ) {
          $part->{name}     = $contentid;
          $part->{filename} = $contentid;
      }
  
      return $self->SUPER::handler($part);
  }
  
  =back
  
  =head1 AUTHOR
  
  Daniel Ruoso C<daniel@ruoso.com>
  
  =head1 LICENSE
  
  This library is free software . You can redistribute it and/or modify 
  it under the same terms as perl itself.
  
  =cut
  
  1;
HTTP_BODY_XFORMSMULTIPART

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

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

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

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

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

$fatpacked{"HTTP/Message/PSGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_MESSAGE_PSGI';
  package HTTP::Message::PSGI;
  use strict;
  use warnings;
  use parent qw(Exporter);
  our @EXPORT = qw( req_to_psgi res_from_psgi );
  
  use Carp ();
  use HTTP::Status qw(status_message);
  use URI::Escape ();
  use Plack::Util;
  use Try::Tiny;
  
  my $TRUE  = (1 == 1);
  my $FALSE = !$TRUE;
  
  sub req_to_psgi {
      my $req = shift;
  
      unless (try { $req->isa('HTTP::Request') }) {
          Carp::croak("Request is not HTTP::Request: $req");
      }
  
      # from HTTP::Request::AsCGI
      my $host = $req->header('Host');
      my $uri  = $req->uri->clone;
      $uri->scheme('http')    unless $uri->scheme;
      $uri->host('localhost') unless $uri->host;
      $uri->port(80)          unless $uri->port;
      $uri->host_port($host)  unless !$host || ( $host eq $uri->host_port );
  
      my $input;
      my $content = $req->content;
      if (ref $content eq 'CODE') {
          if (defined $req->content_length) {
              $input = HTTP::Message::PSGI::ChunkedInput->new($content);
          } else {
              $req->header("Transfer-Encoding" => "chunked");
              $input = HTTP::Message::PSGI::ChunkedInput->new($content, 1);
          }
      } else {
          open $input, "<", \$content;
          $req->content_length(length $content)
              unless defined $req->content_length;
      }
  
      my $env = {
          PATH_INFO         => URI::Escape::uri_unescape($uri->path || '/'),
          QUERY_STRING      => $uri->query || '',
          SCRIPT_NAME       => '',
          SERVER_NAME       => $uri->host,
          SERVER_PORT       => $uri->port,
          SERVER_PROTOCOL   => $req->protocol || 'HTTP/1.1',
          REMOTE_ADDR       => '127.0.0.1',
          REMOTE_HOST       => 'localhost',
          REMOTE_PORT       => int( rand(64000) + 1000 ),                   # not in RFC 3875
          REQUEST_URI       => $uri->path_query || '/',                     # not in RFC 3875
          REQUEST_METHOD    => $req->method,
          'psgi.version'      => [ 1, 1 ],
          'psgi.url_scheme'   => $uri->scheme eq 'https' ? 'https' : 'http',
          'psgi.input'        => $input,
          'psgi.errors'       => *STDERR,
          'psgi.multithread'  => $FALSE,
          'psgi.multiprocess' => $FALSE,
          'psgi.run_once'     => $TRUE,
          'psgi.streaming'    => $TRUE,
          'psgi.nonblocking'  => $FALSE,
          @_,
      };
  
      for my $field ( $req->headers->header_field_names ) {
          my $key = uc("HTTP_$field");
          $key =~ tr/-/_/;
          $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;
  
          unless ( exists $env->{$key} ) {
              $env->{$key} = $req->headers->header($field);
          }
      }
  
      if ($env->{SCRIPT_NAME}) {
          $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//;
          $env->{PATH_INFO} =~ s/^\/+/\//;
      }
  
      if (!defined($env->{HTTP_HOST}) && $req->uri->can('host')) {
          $env->{HTTP_HOST} = $req->uri->host;
          $env->{HTTP_HOST} .= ':' . $req->uri->port
              if $req->uri->port ne $req->uri->default_port;
      }
  
      return $env;
  }
  
  sub res_from_psgi {
      my ($psgi_res) = @_;
  
      require HTTP::Response;
  
      my $res;
      if (ref $psgi_res eq 'ARRAY') {
          _res_from_psgi($psgi_res, \$res);
      } elsif (ref $psgi_res eq 'CODE') {
          $psgi_res->(sub {
              _res_from_psgi($_[0], \$res);
          });
      } else {
          Carp::croak("Bad response: ", defined $psgi_res ? $psgi_res : 'undef');
      }
  
      return $res;
  }
  
  sub _res_from_psgi {
      my ($status, $headers, $body) = @{+shift};
      my $res_ref = shift;
  
      my $convert_resp = sub {
          my $res = HTTP::Response->new($status);
          $res->message(status_message($status));
          $res->headers->header(@$headers) if @$headers;
  
          if (ref $body eq 'ARRAY') {
              $res->content(join '', grep defined, @$body);
          } else {
              local $/ = \4096;
              my $content = '';
              while (defined(my $buf = $body->getline)) {
                  $content .= $buf;
              }
              $body->close;
              $res->content($content);
          }
  
          ${ $res_ref } = $res;
  
          return;
      };
  
      if (!defined $body) {
          my $o = Plack::Util::inline_object
              write => sub { push @{ $body ||= [] }, @_ },
              close => $convert_resp;
  
          return $o;
      }
  
      $convert_resp->();
  }
  
  sub HTTP::Request::to_psgi {
      req_to_psgi(@_);
  }
  
  sub HTTP::Response::from_psgi {
      my $class = shift;
      res_from_psgi(@_);
  }
  
  package
      HTTP::Message::PSGI::ChunkedInput;
  
  sub new {
      my($class, $content, $chunked) = @_;
  
      my $content_cb;
      if ($chunked) {
          my $done;
          $content_cb = sub {
              my $chunk = $content->();
              return if $done;
              unless (defined $chunk) {
                  $done = 1;
                  return "0\015\012\015\012";
              }
              return '' unless length $chunk;
              return sprintf('%x', length $chunk) . "\015\012$chunk\015\012";
          };
      } else {
          $content_cb = $content;
      }
  
      bless { content => $content_cb }, $class;
  }
  
  sub read {
      my $self = shift;
  
      my $chunk = $self->{content}->();
      return 0 unless defined $chunk;
  
      $_[0] = '';
      substr($_[0], $_[2] || 0, length $chunk) = $chunk;
  
      return length $chunk;
  }
  
  sub close { }
  
  package HTTP::Message::PSGI;
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Message::PSGI - Converts HTTP::Request and HTTP::Response from/to PSGI env and response
  
  =head1 SYNOPSIS
  
    use HTTP::Message::PSGI;
  
    # $req is HTTP::Request, $res is HTTP::Response
    my $env = req_to_psgi($req);
    my $res = res_from_psgi([ $status, $headers, $body ]);
  
    # Adds methods to HTTP::Request/Response class as well
    my $env = $req->to_psgi;
    my $res = HTTP::Response->from_psgi([ $status, $headers, $body ]);
  
  =head1 DESCRIPTION
  
  HTTP::Message::PSGI gives you convenient methods to convert an L<HTTP::Request>
  object to a PSGI env hash and convert a PSGI response arrayref to
  a L<HTTP::Response> object.
  
  If you want the other way around, see L<Plack::Request> and
  L<Plack::Response>.
  
  =head1 METHODS
  
  =over 4
  
  =item req_to_psgi
  
    my $env = req_to_psgi($req [, $key => $val ... ]);
  
  Converts a L<HTTP::Request> object into a PSGI env hash reference.
  
  =item HTTP::Request::to_psgi
  
    my $env = $req->to_psgi;
  
  Same as C<req_to_psgi> but an instance method in L<HTTP::Request>.
  
  =item res_from_psgi
  
    my $res = res_from_psgi([ $status, $headers, $body ]);
  
  Creates a L<HTTP::Response> object from a PSGI response array ref.
  
  =item HTTP::Response->from_psgi
  
    my $res = HTTP::Response->from_psgi([ $status, $headers, $body ]);
  
  Same as C<res_from_psgi>, but is a class method in L<HTTP::Response>.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<HTTP::Request::AsCGI> L<HTTP::Message> L<Plack::Test>
  
  =cut
  
HTTP_MESSAGE_PSGI

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

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

$fatpacked{"HTTP/Server/PSGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_SERVER_PSGI';
  package HTTP::Server::PSGI;
  use strict;
  use warnings;
  
  use Carp ();
  use Plack;
  use Plack::HTTPParser qw( parse_http_request );
  use IO::Socket::INET;
  use HTTP::Date;
  use HTTP::Status;
  use List::Util qw(max sum);
  use Plack::Util;
  use Stream::Buffered;
  use Plack::Middleware::ContentLength;
  use POSIX qw(EINTR);
  use Socket qw(IPPROTO_TCP TCP_NODELAY);
  
  use Try::Tiny;
  use Time::HiRes qw(time);
  
  my $alarm_interval;
  BEGIN {
      if ($^O eq 'MSWin32') {
          $alarm_interval = 1;
      } else {
          Time::HiRes->import('alarm');
          $alarm_interval = 0.1;
      }
  }
  
  use constant MAX_REQUEST_SIZE => 131072;
  use constant MSWin32          => $^O eq 'MSWin32';
  
  sub new {
      my($class, %args) = @_;
  
      my $self = bless {
          host               => $args{host} || 0,
          port               => $args{port} || 8080,
          timeout            => $args{timeout} || 300,
          server_software    => $args{server_software} || $class,
          server_ready       => $args{server_ready} || sub {},
          ssl                => $args{ssl},
          ipv6               => $args{ipv6},
          ssl_key_file       => $args{ssl_key_file},
          ssl_cert_file      => $args{ssl_cert_file},
      }, $class;
  
      $self;
  }
  
  sub run {
      my($self, $app) = @_;
      $self->setup_listener();
      $self->accept_loop($app);
  }
  
  sub prepare_socket_class {
      my($self, $args) = @_;
  
      if ($self->{ssl} && $self->{ipv6}) {
          Carp::croak("SSL and IPv6 are not supported at the same time (yet). Choose one.");
      }
  
      if ($self->{ssl}) {
          eval { require IO::Socket::SSL; 1 }
              or Carp::croak("SSL suport requires IO::Socket::SSL");
          $args->{SSL_key_file}  = $self->{ssl_key_file};
          $args->{SSL_cert_file} = $self->{ssl_cert_file};
          return "IO::Socket::SSL";
      } elsif ($self->{ipv6}) {
          eval { require IO::Socket::IP; 1 }
              or Carp::croak("IPv6 support requires IO::Socket::IP");
          $self->{host}      ||= '::';
          $args->{LocalAddr} ||= '::';
          return "IO::Socket::IP";
      }
  
      return "IO::Socket::INET";
  }
  
  sub setup_listener {
      my $self = shift;
  
      my %args = (
          Listen    => SOMAXCONN,
          LocalPort => $self->{port},
          LocalAddr => $self->{host},
          Proto     => 'tcp',
          ReuseAddr => 1,
      );
  
      my $class = $self->prepare_socket_class(\%args);
      $self->{listen_sock} ||= $class->new(%args)
          or die "failed to listen to port $self->{port}: $!";
  
      $self->{server_ready}->({ %$self, proto => $self->{ssl} ? 'https' : 'http' });
  }
  
  sub accept_loop {
      my($self, $app) = @_;
  
      $app = Plack::Middleware::ContentLength->wrap($app);
  
      while (1) {
          local $SIG{PIPE} = 'IGNORE';
          if (my $conn = $self->{listen_sock}->accept) {
              $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
                  or die "setsockopt(TCP_NODELAY) failed:$!";
              my $env = {
                  SERVER_PORT => $self->{port},
                  SERVER_NAME => $self->{host},
                  SCRIPT_NAME => '',
                  REMOTE_ADDR => $conn->peerhost,
                  REMOTE_PORT => $conn->peerport || 0,
                  'psgi.version' => [ 1, 1 ],
                  'psgi.errors'  => *STDERR,
                  'psgi.url_scheme' => $self->{ssl} ? 'https' : 'http',
                  'psgi.run_once'     => Plack::Util::FALSE,
                  'psgi.multithread'  => Plack::Util::FALSE,
                  'psgi.multiprocess' => Plack::Util::FALSE,
                  'psgi.streaming'    => Plack::Util::TRUE,
                  'psgi.nonblocking'  => Plack::Util::FALSE,
                  'psgix.harakiri'    => Plack::Util::TRUE,
                  'psgix.input.buffered' => Plack::Util::TRUE,
                  'psgix.io'          => $conn,
              };
  
              $self->handle_connection($env, $conn, $app);
              $conn->close;
              last if $env->{'psgix.harakiri.commit'};
          }
      }
  }
  
  sub handle_connection {
      my($self, $env, $conn, $app) = @_;
  
      my $buf = '';
      my $res = [ 400, [ 'Content-Type' => 'text/plain' ], [ 'Bad Request' ] ];
  
      while (1) {
          my $rlen = $self->read_timeout(
              $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
              $self->{timeout},
          ) or return;
          my $reqlen = parse_http_request($buf, $env);
          if ($reqlen >= 0) {
              $buf = substr $buf, $reqlen;
              if (my $cl = $env->{CONTENT_LENGTH}) {
                  my $buffer = Stream::Buffered->new($cl);
                  while ($cl > 0) {
                      my $chunk;
                      if (length $buf) {
                          $chunk = $buf;
                          $buf = '';
                      } else {
                          $self->read_timeout($conn, \$chunk, $cl, 0, $self->{timeout})
                              or return;
                      }
                      $buffer->print($chunk);
                      $cl -= length $chunk;
                  }
                  $env->{'psgi.input'} = $buffer->rewind;
              } else {
                  open my $input, "<", \$buf;
                  $env->{'psgi.input'} = $input;
              }
  
              $res = Plack::Util::run_app $app, $env;
              last;
          }
          if ($reqlen == -2) {
              # request is incomplete, do nothing
          } elsif ($reqlen == -1) {
              # error, close conn
              last;
          }
      }
  
      if (ref $res eq 'ARRAY') {
          $self->_handle_response($res, $conn);
      } elsif (ref $res eq 'CODE') {
          $res->(sub {
              $self->_handle_response($_[0], $conn);
          });
      } else {
          die "Bad response $res";
      }
  
      return;
  }
  
  sub _handle_response {
      my($self, $res, $conn) = @_;
  
      my @lines = (
          "Date: @{[HTTP::Date::time2str()]}\015\012",
          "Server: $self->{server_software}\015\012",
      );
  
      Plack::Util::header_iter($res->[1], sub {
          my ($k, $v) = @_;
          push @lines, "$k: $v\015\012";
      });
  
      unshift @lines, "HTTP/1.0 $res->[0] @{[ HTTP::Status::status_message($res->[0]) ]}\015\012";
      push @lines, "\015\012";
  
      $self->write_all($conn, join('', @lines), $self->{timeout})
          or return;
  
      if (defined $res->[2]) {
          my $err;
          my $done;
          {
              local $@;
              eval {
                  Plack::Util::foreach(
                      $res->[2],
                      sub {
                          $self->write_all($conn, $_[0], $self->{timeout})
                              or die "failed to send all data\n";
                      },
                  );
                  $done = 1;
              };
              $err = $@;
          };
          unless ($done) {
              if ($err =~ /^failed to send all data\n/) {
                  return;
              } else {
                  die $err;
              }
          }
      } else {
          return Plack::Util::inline_object
              write => sub { $self->write_all($conn, $_[0], $self->{timeout}) },
              close => sub { };
      }
  }
  
  # returns 1 if socket is ready, undef on timeout
  sub do_timeout {
      my ($self, $cb, $timeout) = @_;
      local $SIG{ALRM} = sub {};
      my $wait_until = time + $timeout;
      alarm($timeout);
      my $ret;
      while (1) {
          if ($ret = $cb->()) {
              last;
          } elsif (! (! defined($ret) && $! == EINTR)) {
              undef $ret;
              last;
          }
          # got EINTR
          my $left = $wait_until - time;
          last if $left <= 0;
          alarm($left + $alarm_interval);
      }
      alarm(0);
      $ret;
  }
  
  # returns (positive) number of bytes read, or undef if the socket is to be closed
  sub read_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_timeout(sub { $sock->sysread($$buf, $len, $off) }, $timeout);
  }
  
  # returns (positive) number of bytes written, or undef if the socket is to be closed
  sub write_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_timeout(sub { $sock->syswrite($buf, $len, $off) }, $timeout);
  }
  
  # writes all data in buf and returns number of bytes written or undef if failed
  sub write_all {
      my ($self, $sock, $buf, $timeout) = @_;
      return 0 unless defined $buf;
      _encode($buf);
      my $off = 0;
      while (my $len = length($buf) - $off) {
          my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout)
              or return;
          $off += $ret;
      }
      return length $buf;
  }
  
  # syswrite() will crash when given wide characters
  sub _encode {
      if ($_[0] =~ /[^\x00-\xff]/) {
          Carp::carp("Wide character outside byte range in response. Encoding data as UTF-8");
          utf8::encode($_[0]);
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  HTTP::Server::PSGI - Standalone PSGI compatible HTTP server
  
  =head1 SYNOPSIS
  
    use HTTP::Server::PSGI;
  
    my $server = HTTP::Server::PSGI->new(
        host => "127.0.0.1",
        port => 9091,
        timeout => 120,
    );
  
    $server->run($app);
  
  =head1 DESCRIPTION
  
  HTTP::Server::PSGI is a standalone, single-process and PSGI compatible
  HTTP server implementations.
  
  This server should be great for the development and testing, but might
  not be suitable for a production use.
  
  Some features in HTTP/1.1, notably chunked requests, responses and
  pipeline requests are B<NOT> supported, and it also does not support
  HTTP/0.9.
  
  See L<Starman> or uWSGI server if you want HTTP/1.1 and other features
  ready for a production use.
  
  =head1 PREFORKING
  
  L<HTTP::Server::PSGI> does B<NOT> support preforking. See L<Starman>
  or L<Starlet> if you want a multi-process prefork web servers.
  
  =head1 HARAKIRI SUPPORT
  
  This web server supports `psgix.harakiri` extension defined in the
  L<PSGI::Extensions>.
  
  This application is a non-forking single process web server
  (i.e. `psgi.multiprocess` is false), and if your application commits
  harakiri, the entire web server stops too. In case this behavior is
  not what you want, be sure to check `psgi.multiprocess` as well to
  enable harakiri only in the preforking servers such as L<Starman>.
  
  On the other hand, this behavior might be handy if you want to embed
  this module in your application and serve HTTP requests for only short
  period of time, then go back to your main program.
  
  =head1 AUTHOR
  
  Kazuho Oku
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Handler::Standalone> L<Starman> L<Starlet>
  
  =cut
HTTP_SERVER_PSGI

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

$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
  # vim: ts=4 sts=4 sw=4 et:
  package HTTP::Tiny;
  use strict;
  use warnings;
  # ABSTRACT: A small, simple, correct HTTP/1.1 client
  our $VERSION = '0.043'; # VERSION
  
  use Carp ();
  
  # =method new
  #
  #     $http = HTTP::Tiny->new( %attributes );
  #
  # This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  #
  # =for :list
  # * C<agent>
  # A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
  # * C<cookie_jar>
  # An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
  # * C<default_headers>
  # A hashref of default headers to apply to requests
  # * C<local_address>
  # The local IP address to bind to
  # * C<keep_alive>
  # Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
  # * C<max_redirect>
  # Maximum number of redirects allowed (defaults to 5)
  # * C<max_size>
  # Maximum response size (only when not using a data callback).  If defined, responses larger than this will return an exception.
  # * C<http_proxy>
  # URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
  # * C<https_proxy>
  # URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
  # * C<proxy>
  # URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
  # * C<no_proxy>
  # List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
  # * C<timeout>
  # Request timeout in seconds (default is 60)
  # * C<verify_SSL>
  # A boolean that indicates whether to validate the SSL certificate of an C<https>
  # connection (default is false)
  # * C<SSL_options>
  # A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
  #
  # Exceptions from C<max_size>, C<timeout> or other errors will result in a
  # pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  # content field in the response will contain the text of the exception.
  #
  # The C<keep_alive> parameter enables a persistent connection, but only to a
  # single destination scheme, host and port.  Also, if any connection-relevant
  # attributes are modified, a persistent connection will be dropped.  If you want
  # persistent connections across multiple destinations, use multiple HTTP::Tiny
  # objects.
  #
  # See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  #
  # =cut
  
  my @attributes;
  BEGIN {
      @attributes = qw(
          cookie_jar default_headers http_proxy https_proxy keep_alive
          local_address max_redirect max_size proxy no_proxy timeout
          SSL_options verify_SSL
      );
      my %persist_ok = map {; $_ => 1 } qw(
          cookie_jar default_headers max_redirect max_size
      );
      no strict 'refs';
      no warnings 'uninitialized';
      for my $accessor ( @attributes ) {
          *{$accessor} = sub {
              @_ > 1
                  ? do {
                      delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
                      $_[0]->{$accessor} = $_[1]
                  }
                  : $_[0]->{$accessor};
          };
      }
  }
  
  sub agent {
      my($self, $agent) = @_;
      if( @_ > 1 ){
          $self->{agent} =
              (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
      }
      return $self->{agent};
  }
  
  sub new {
      my($class, %args) = @_;
  
      my $self = {
          max_redirect => 5,
          timeout      => 60,
          keep_alive   => 1,
          verify_SSL   => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
          no_proxy     => $ENV{no_proxy},
      };
  
      bless $self, $class;
  
      $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
  
      for my $key ( @attributes ) {
          $self->{$key} = $args{$key} if exists $args{$key}
      }
  
      $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
  
      $self->_set_proxies;
  
      return $self;
  }
  
  sub _set_proxies {
      my ($self) = @_;
  
      if (! $self->{proxy} ) {
          $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
          if ( defined $self->{proxy} ) {
              $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
          }
          else {
              delete $self->{proxy};
          }
      }
  
      if (! $self->{http_proxy} ) {
          $self->{http_proxy} = $ENV{http_proxy} || $self->{proxy};
          if ( defined $self->{http_proxy} ) {
              $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
              $self->{_has_proxy}{http} = 1;
          }
          else {
              delete $self->{http_proxy};
          }
      }
  
      if (! $self->{https_proxy} ) {
          $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
          if ( $self->{https_proxy} ) {
              $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
              $self->{_has_proxy}{https} = 1;
          }
          else {
              delete $self->{https_proxy};
          }
      }
  
      # Split no_proxy to array reference if not provided as such
      unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
          $self->{no_proxy} =
              (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
      }
  
      return;
  }
  
  # =method get|head|put|post|delete
  #
  #     $response = $http->get($url);
  #     $response = $http->get($url, \%options);
  #     $response = $http->head($url);
  #
  # These methods are shorthand for calling C<request()> for the given method.  The
  # URL must have unsafe characters escaped and international domain names encoded.
  # See C<request()> for valid options and a description of the response.
  #
  # The C<success> field of the response will be true if the status code is 2XX.
  #
  # =cut
  
  for my $sub_name ( qw/get head put post delete/ ) {
      my $req_method = uc $sub_name;
      no strict 'refs';
      eval <<"HERE"; ## no critic
      sub $sub_name {
          my (\$self, \$url, \$args) = \@_;
          \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
          or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
          return \$self->request('$req_method', \$url, \$args || {});
      }
  HERE
  }
  
  # =method post_form
  #
  #     $response = $http->post_form($url, $form_data);
  #     $response = $http->post_form($url, $form_data, \%options);
  #
  # This method executes a C<POST> request and sends the key/value pairs from a
  # form data hash or array reference to the given URL with a C<content-type> of
  # C<application/x-www-form-urlencoded>.  If data is provided as an array
  # reference, the order is preserved; if provided as a hash reference, the terms
  # are sorted on key and value for consistency.  See documentation for the
  # C<www_form_urlencode> method for details on the encoding.
  #
  # The URL must have unsafe characters escaped and international domain names
  # encoded.  See C<request()> for valid options and a description of the response.
  # Any C<content-type> header or content in the options hashref will be ignored.
  #
  # The C<success> field of the response will be true if the status code is 2XX.
  #
  # =cut
  
  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'
              },
          }
      );
  }
  
  # =method mirror
  #
  #     $response = $http->mirror($url, $file, \%options)
  #     if ( $response->{success} ) {
  #         print "$file is up to date\n";
  #     }
  #
  # Executes a C<GET> request for the URL and saves the response body to the file
  # name provided.  The URL must have unsafe characters escaped and international
  # domain names encoded.  If the file already exists, the request will include an
  # C<If-Modified-Since> header with the modification timestamp of the file.  You
  # may specify a different C<If-Modified-Since> header yourself in the C<<
  # $options->{headers} >> hash.
  #
  # The C<success> field of the response will be true if the status code is 2XX
  # or if the status code is 304 (unmodified).
  #
  # If the file was modified and the server response includes a properly
  # formatted C<Last-Modified> header, the file modification time will
  # be updated accordingly.
  #
  # =cut
  
  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));
  
      require Fcntl;
      sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
         or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
      binmode $fh;
      $args->{data_callback} = sub { print {$fh} $_[0] };
      my $response = $self->request('GET', $url, $args);
      close $fh
          or Carp::croak(qq/Error: Caught error closing 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;
  }
  
  # =method request
  #
  #     $response = $http->request($method, $url);
  #     $response = $http->request($method, $url, \%options);
  #
  # Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  # 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  # international domain names encoded.
  #
  # If the URL includes a "user:password" stanza, they will be used for Basic-style
  # authorization headers.  (Authorization headers will not be included in a
  # redirected request.) For example:
  #
  #     $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  #
  # If the "user:password" stanza contains reserved characters, they must
  # be percent-escaped:
  #
  #     $http->request('GET', 'http://john%40example.com:password@example.com/');
  #
  # A hashref of options may be appended to modify the request.
  #
  # Valid options are:
  #
  # =for :list
  # * C<headers>
  # A hashref containing headers to include with the request.  If the value for
  # a header is an array reference, the header will be output multiple times with
  # each value in the array.  These headers over-write any default headers.
  # * C<content>
  # A scalar to include as the body of the request OR a code reference
  # that will be called iteratively to produce the body of the request
  # * C<trailer_callback>
  # A code reference that will be called if it exists to provide a hashref
  # of trailing headers (only used with chunked transfer-encoding)
  # * C<data_callback>
  # A code reference that will be called for each chunks of the response
  # body received.
  #
  # If the C<content> option is a code reference, it will be called iteratively
  # to provide the content body of the request.  It should return the empty
  # string or undef when the iterator is exhausted.
  #
  # If the C<content> option is the empty string, no C<content-type> or
  # C<content-length> headers will be generated.
  #
  # If the C<data_callback> option is provided, it will be called iteratively until
  # the entire response body is received.  The first argument will be a string
  # containing a chunk of the response body, the second argument will be the
  # in-progress response hash reference, as described below.  (This allows
  # customizing the action of the callback based on the C<status> or C<headers>
  # received prior to the content body.)
  #
  # The C<request> method returns a hashref containing the response.  The hashref
  # will have the following keys:
  #
  # =for :list
  # * C<success>
  # Boolean indicating whether the operation returned a 2XX status code
  # * C<url>
  # URL that provided the response. This is the URL of the request unless
  # there were redirections, in which case it is the last URL queried
  # in a redirection chain
  # * C<status>
  # The HTTP status code of the response
  # * C<reason>
  # The response phrase returned by the server
  # * C<content>
  # The body of the response.  If the response does not have any content
  # or if a data callback is provided to consume the response body,
  # this will be the empty string
  # * C<headers>
  # A hashref of header fields.  All header field names will be normalized
  # to be lower case. If a header is repeated, the value will be an arrayref;
  # it will otherwise be a scalar string containing the value
  #
  # 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.
  #
  # =cut
  
  my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
  
  sub request {
      my ($self, $method, $url, $args) = @_;
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or 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 = $@) {
          # maybe we got a response hash thrown from somewhere deep
          if ( ref $e eq 'HASH' && exists $e->{status} ) {
              return $e;
          }
  
          # otherwise, stringify it
          $e = "$e";
          $response = {
              url     => $url,
              success => q{},
              status  => 599,
              reason  => 'Internal Exception',
              content => $e,
              headers => {
                  'content-type'   => 'text/plain',
                  'content-length' => length $e,
              }
          };
      }
      return $response;
  }
  
  # =method www_form_urlencode
  #
  #     $params = $http->www_form_urlencode( $data );
  #     $response = $http->get("http://example.com/query?$params");
  #
  # This method converts the key/value pairs from a data hash or array reference
  # into a C<x-www-form-urlencoded> string.  The keys and values from the data
  # reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  # array reference, the key will be repeated with each of the values of the array
  # reference.  If data is provided as a hash reference, the key/value pairs in the
  # resulting string will be sorted by key and value for consistent ordering.
  #
  # =cut
  
  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\n");
  
      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("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
  }
  
  #--------------------------------------------------------------------------#
  # private methods
  #--------------------------------------------------------------------------#
  
  my %DefaultPort = (
      http => 80,
      https => 443,
  );
  
  sub _agent {
      my $class = ref($_[0]) || $_[0];
      (my $default_agent = $class) =~ s{::}{-}g;
      return $default_agent . "/" . ($class->VERSION || 0);
  }
  
  sub _request {
      my ($self, $method, $url, $args) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
  
      my $request = {
          method    => $method,
          scheme    => $scheme,
          host      => $host,
          host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
          uri       => $path_query,
          headers   => {},
      };
  
      # We remove the cached handle so it is not reused in the case of redirect.
      # If all is well, it will be recached at the end of _request.  We only
      # reuse for the same scheme, host and port
      my $handle = delete $self->{handle};
      if ( $handle ) {
          unless ( $handle->can_reuse( $scheme, $host, $port ) ) {
              $handle->close;
              undef $handle;
          }
      }
      $handle ||= $self->_open_handle( $request, $scheme, $host, $port );
  
      $self->_prepare_headers_and_cb($request, $args, $url, $auth);
      $handle->write_request($request);
  
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
  
      if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
          $handle->close;
          return $self->_request(@redir_args, $args);
      }
  
      my $known_message_length;
      if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
          # response has no message body
          $known_message_length = 1;
      }
      else {
          my $data_cb = $self->_prepare_data_cb($response, $args);
          $known_message_length = $handle->read_body($data_cb, $response);
      }
  
      if ( $self->{keep_alive}
          && $known_message_length
          && $response->{protocol} eq 'HTTP/1.1'
          && ($response->{headers}{connection} || '') ne 'close'
      ) {
          $self->{handle} = $handle;
      }
      else {
          $handle->close;
      }
  
      $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
      $response->{url} = $url;
      return $response;
  }
  
  sub _open_handle {
      my ($self, $request, $scheme, $host, $port) = @_;
  
      my $handle  = HTTP::Tiny::Handle->new(
          timeout         => $self->{timeout},
          SSL_options     => $self->{SSL_options},
          verify_SSL      => $self->{verify_SSL},
          local_address   => $self->{local_address},
          keep_alive      => $self->{keep_alive}
      );
  
      if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
          return $self->_proxy_connect( $request, $handle );
      }
      else {
          return $handle->connect($scheme, $host, $port);
      }
  }
  
  sub _proxy_connect {
      my ($self, $request, $handle) = @_;
  
      my @proxy_vars;
      if ( $request->{scheme} eq 'https' ) {
          Carp::croak(qq{No https_proxy defined}) unless $self->{https_proxy};
          @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
          if ( $proxy_vars[0] eq 'https' ) {
              Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
          }
      }
      else {
          Carp::croak(qq{No http_proxy defined}) unless $self->{http_proxy};
          @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
      }
  
      my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;
  
      if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
          $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
      }
  
      $handle->connect($p_scheme, $p_host, $p_port);
  
      if ($request->{scheme} eq 'https') {
          $self->_create_proxy_tunnel( $request, $handle );
      }
      else {
          # non-tunneled proxy requires absolute URI
          $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
      }
  
      return $handle;
  }
  
  sub _split_proxy {
      my ($self, $type, $proxy) = @_;
  
      my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };
  
      unless(
          defined($scheme) && length($scheme) && length($host) && length($port)
          && $path_query eq '/'
      ) {
          Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
      }
  
      return ($scheme, $host, $port, $auth);
  }
  
  sub _create_proxy_tunnel {
      my ($self, $request, $handle) = @_;
  
      $handle->_assert_ssl;
  
      my $agent = exists($request->{headers}{'user-agent'})
          ? $request->{headers}{'user-agent'} : $self->{agent};
  
      my $connect_request = {
          method    => 'CONNECT',
          uri       => $request->{host_port},
          headers   => {
              host => $request->{host_port},
              'user-agent' => $agent,
          }
      };
  
      if ( $request->{headers}{'proxy-authorization'} ) {
          $connect_request->{headers}{'proxy-authorization'} =
              delete $request->{headers}{'proxy-authorization'};
      }
  
      $handle->write_request($connect_request);
      my $response;
      do { $response = $handle->read_response_header }
          until (substr($response->{status},0,1) ne '1');
  
      # if CONNECT failed, throw the response so it will be
      # returned from the original request() method;
      unless (substr($response->{status},0,1) eq '2') {
          die $response;
      }
  
      # tunnel established, so start SSL handshake
      $handle->start_ssl( $request->{host} );
  
      return;
  }
  
  sub _prepare_headers_and_cb {
      my ($self, $request, $args, $url, $auth) = @_;
  
      for ($self->{default_headers}, $args->{headers}) {
          next unless defined;
          while (my ($k, $v) = each %$_) {
              $request->{headers}{lc $k} = $v;
          }
      }
      $request->{headers}{'host'}         = $request->{host_port};
      $request->{headers}{'user-agent'} ||= $self->{agent};
      $request->{headers}{'connection'}   = "close"
          unless $self->{keep_alive};
  
      if ( defined $args->{content} ) {
          if (ref $args->{content} eq 'CODE') {
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'transfer-encoding'} = 'chunked'
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = $args->{content};
          }
          elsif ( length $args->{content} ) {
              my $content = $args->{content};
              if ( $] ge '5.008' ) {
                  utf8::downgrade($content, 1)
                      or die(qq/Wide character in request message body\n/);
              }
              $request->{headers}{'content-type'} ||= "application/octet-stream";
              $request->{headers}{'content-length'} = length $content
                unless $request->{headers}{'content-length'}
                    || $request->{headers}{'transfer-encoding'};
              $request->{cb} = sub { substr $content, 0, length $content, '' };
          }
          $request->{trailer_cb} = $args->{trailer_callback}
              if ref $args->{trailer_callback} eq 'CODE';
      }
  
      ### If we have a cookie jar, then maybe add relevant cookies
      if ( $self->{cookie_jar} ) {
          my $cookies = $self->cookie_jar->cookie_header( $url );
          $request->{headers}{cookie} = $cookies if length $cookies;
      }
  
      # if we have Basic auth parameters, add them
      if ( length $auth && ! defined $request->{headers}{authorization} ) {
          $self->_add_basic_auth_header( $request, 'authorization' => $auth );
      }
  
      return;
  }
  
  sub _add_basic_auth_header {
      my ($self, $request, $header, $auth) = @_;
      require MIME::Base64;
      $request->{headers}{$header} =
          "Basic " . MIME::Base64::encode_base64($auth, "");
      return;
  }
  
  sub _prepare_data_cb {
      my ($self, $response, $args) = @_;
      my $data_cb = $args->{data_callback};
      $response->{content} = '';
  
      if (!$data_cb || $response->{status} !~ /^2/) {
          if (defined $self->{max_size}) {
              $data_cb = sub {
                  $_[1]->{content} .= $_[0];
                  die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
                    if length $_[1]->{content} > $self->{max_size};
              };
          }
          else {
              $data_cb = sub { $_[1]->{content} .= $_[0] };
          }
      }
      return $data_cb;
  }
  
  sub _update_cookie_jar {
      my ($self, $url, $response) = @_;
  
      my $cookies = $response->{headers}->{'set-cookie'};
      return unless defined $cookies;
  
      my @cookies = ref $cookies ? @$cookies : $cookies;
  
      $self->cookie_jar->add( $url, $_ ) for @cookies;
  
      return;
  }
  
  sub _validate_cookie_jar {
      my ($class, $jar) = @_;
  
      # duck typing
      for my $method ( qw/add cookie_header/ ) {
          Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
              unless ref($jar) && ref($jar)->can($method);
      }
  
      return;
  }
  
  sub _maybe_redirect {
      my ($self, $request, $response, $args) = @_;
      my $headers = $response->{headers};
      my ($status, $method) = ($response->{status}, $request->{method});
      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 ($auth,$host);
      $authority = (length($authority)) ? $authority : 'localhost';
      if ( $authority =~ /@/ ) {
          ($auth,$host) = $authority =~ m/\A([^@]*)@(.*)\z/;   # user:pass@host
          # userinfo might be percent escaped, so recover real auth info
          $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
      }
      else {
          $host = $authority;
          $auth = '';
      }
      $host = lc $host;
      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, $auth);
  }
  
  # Date conversions adapted from HTTP::Date
  my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
  my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
  sub _http_date {
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
      return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
          substr($DoW,$wday*4,3),
          $mday, substr($MoY,$mon*4,3), $year+1900,
          $hour, $min, $sec
      );
  }
  
  sub _parse_http_date {
      my ($self, $str) = @_;
      require Time::Local;
      my @tl_parts;
      if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
      }
      elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
          @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
      }
      return eval {
          my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
          $t < 0 ? undef : $t;
      };
  }
  
  # URI escaping adapted from URI::Escape
  # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
  # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
  my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  $escapes{' '}="+";
  my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
  
  sub _uri_escape {
      my ($self, $str) = @_;
      if ( $] ge '5.008' ) {
          utf8::encode($str);
      }
      else {
          $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
              if ( length $str == do { use bytes; length $str } );
          $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
      }
      $str =~ s/($unsafe_char)/$escapes{$1}/ge;
      return $str;
  }
  
  package
      HTTP::Tiny::Handle; # hide from PAUSE/indexers
  use strict;
  use warnings;
  
  use Errno      qw[EINTR EPIPE];
  use IO::Socket qw[SOCK_STREAM];
  
  # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
  # behavior if someone is unable to boostrap CPAN from a new perl install; it is
  # not intended for general, per-client use and may be removed in the future
  my $SOCKET_CLASS =
      $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
      eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' :
      'IO::Socket::INET';
  
  sub BUFSIZE () { 32768 } ## no critic
  
  my $Printable = sub {
      local $_ = shift;
      s/\r/\\r/g;
      s/\n/\\n/g;
      s/\t/\\t/g;
      s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
      $_;
  };
  
  my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
  
  sub new {
      my ($class, %args) = @_;
      return bless {
          rbuf             => '',
          timeout          => 60,
          max_line_size    => 16384,
          max_header_lines => 64,
          verify_SSL       => 0,
          SSL_options      => {},
          %args
      }, $class;
  }
  
  sub connect {
      @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
      my ($self, $scheme, $host, $port) = @_;
  
      if ( $scheme eq 'https' ) {
          $self->_assert_ssl;
      }
      elsif ( $scheme ne 'http' ) {
        die(qq/Unsupported URL scheme '$scheme'\n/);
      }
      $self->{fh} = $SOCKET_CLASS->new(
          PeerHost  => $host,
          PeerPort  => $port,
          $self->{local_address} ?
              ( LocalAddr => $self->{local_address} ) : (),
          Proto     => 'tcp',
          Type      => SOCK_STREAM,
          Timeout   => $self->{timeout},
          KeepAlive => !!$self->{keep_alive}
      ) or die(qq/Could not connect to '$host:$port': $@\n/);
  
      binmode($self->{fh})
        or die(qq/Could not binmode() socket: '$!'\n/);
  
      $self->start_ssl($host) if $scheme eq 'https';
  
      $self->{scheme} = $scheme;
      $self->{host} = $host;
      $self->{port} = $port;
  
      return $self;
  }
  
  sub start_ssl {
      my ($self, $host) = @_;
  
      # As this might be used via CONNECT after an SSL session
      # to a proxy, we shut down any existing SSL before attempting
      # the handshake
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          unless ( $self->{fh}->stop_SSL ) {
              my $ssl_err = IO::Socket::SSL->errstr;
              die(qq/Error halting prior SSL connection: $ssl_err/);
          }
      }
  
      my $ssl_args = $self->_ssl_args($host);
      IO::Socket::SSL->start_SSL(
          $self->{fh},
          %$ssl_args,
          SSL_create_ctx_callback => sub {
              my $ctx = shift;
              Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
          },
      );
  
      unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          my $ssl_err = IO::Socket::SSL->errstr;
          die(qq/SSL connection failed for $host: $ssl_err\n/);
      }
  }
  
  sub close {
      @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
      my ($self) = @_;
      CORE::close($self->{fh})
        or die(qq/Could not close socket: '$!'\n/);
  }
  
  sub write {
      @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
      my ($self, $buf) = @_;
  
      if ( $] ge '5.008' ) {
          utf8::downgrade($buf, 1)
              or die(qq/Wide character in write()\n/);
      }
  
      my $len = length $buf;
      my $off = 0;
  
      local $SIG{PIPE} = 'IGNORE';
  
      while () {
          $self->can_write
            or die(qq/Timed out while waiting for socket to become ready for writing\n/);
          my $r = syswrite($self->{fh}, $buf, $len, $off);
          if (defined $r) {
              $len -= $r;
              $off += $r;
              last unless $len > 0;
          }
          elsif ($! == EPIPE) {
              die(qq/Socket closed by remote server: $!\n/);
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not write to SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not write to socket: '$!'\n/);
              }
  
          }
      }
      return $off;
  }
  
  sub read {
      @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
      my ($self, $len, $allow_partial) = @_;
  
      my $buf  = '';
      my $got = length $self->{rbuf};
  
      if ($got) {
          my $take = ($got < $len) ? $got : $len;
          $buf  = substr($self->{rbuf}, 0, $take, '');
          $len -= $take;
      }
  
      while ($len > 0) {
          $self->can_read
            or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
          my $r = sysread($self->{fh}, $buf, $len, length $buf);
          if (defined $r) {
              last unless $r;
              $len -= $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      if ($len && !$allow_partial) {
          die(qq/Unexpected end of stream\n/);
      }
      return $buf;
  }
  
  sub readline {
      @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
      my ($self) = @_;
  
      while () {
          if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
              return $1;
          }
          if (length $self->{rbuf} >= $self->{max_line_size}) {
              die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
          }
          $self->can_read
            or die(qq/Timed out while waiting for socket to become ready for reading\n/);
          my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
          if (defined $r) {
              last unless $r;
          }
          elsif ($! != EINTR) {
              if ($self->{fh}->can('errstr')){
                  my $err = $self->{fh}->errstr();
                  die (qq/Could not read from SSL socket: '$err'\n /);
              }
              else {
                  die(qq/Could not read from socket: '$!'\n/);
              }
          }
      }
      die(qq/Unexpected end of stream while looking for line\n/);
  }
  
  sub read_header_lines {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
      my ($self, $headers) = @_;
      $headers ||= {};
      my $lines   = 0;
      my $val;
  
      while () {
           my $line = $self->readline;
  
           if (++$lines >= $self->{max_header_lines}) {
               die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
           }
           elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
               my ($field_name) = lc $1;
               if (exists $headers->{$field_name}) {
                   for ($headers->{$field_name}) {
                       $_ = [$_] unless ref $_ eq "ARRAY";
                       push @$_, $2;
                       $val = \$_->[-1];
                   }
               }
               else {
                   $val = \($headers->{$field_name} = $2);
               }
           }
           elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
               $val
                 or die(qq/Unexpected header continuation line\n/);
               next unless length $1;
               $$val .= ' ' if length $$val;
               $$val .= $1;
           }
           elsif ($line =~ /\A \x0D?\x0A \z/x) {
              last;
           }
           else {
              die(q/Malformed header line: / . $Printable->($line) . "\n");
           }
      }
      return $headers;
  }
  
  sub write_request {
      @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
      my($self, $request) = @_;
      $self->write_request_header(@{$request}{qw/method uri headers/});
      $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',
  );
  
  # to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
  # combine writes.
  sub write_header_lines {
      (@_ == 2 || @_ == 3 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers[,prefix])/ . "\n");
      my($self, $headers, $prefix_data) = @_;
  
      my $buf = (defined $prefix_data ? $prefix_data : '');
      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);
  }
  
  # return value indicates whether message length was defined; this is generally
  # true unless there was no content-length header and we just read until EOF.
  # Other message length errors are thrown as exceptions
  sub read_body {
      @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
      my ($self, $cb, $response) = @_;
      my $te = $response->{headers}{'transfer-encoding'} || '';
      my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
      return $chunked
          ? $self->read_chunked_body($cb, $response)
          : $self->read_content_body($cb, $response);
  }
  
  sub write_body {
      @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
      my ($self, $request) = @_;
      if ($request->{headers}{'content-length'}) {
          return $self->write_content_body($request);
      }
      else {
          return $self->write_chunked_body($request);
      }
  }
  
  sub read_content_body {
      @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
      my ($self, $cb, $response, $content_length) = @_;
      $content_length ||= $response->{headers}{'content-length'};
  
      if ( defined $content_length ) {
          my $len = $content_length;
          while ($len > 0) {
              my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
              $cb->($self->read($read, 0), $response);
              $len -= $read;
          }
          return length($self->{rbuf}) == 0;
      }
  
      my $chunk;
      $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
  
      return;
  }
  
  sub write_content_body {
      @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my ($len, $content_length) = (0, $request->{headers}{'content-length'});
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_content()\n/);
          }
  
          $len += $self->write($data);
      }
  
      $len == $content_length
        or die(qq/Content-Length 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 1;
  }
  
  sub write_chunked_body {
      @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
      my ($self, $request) = @_;
  
      my $len = 0;
      while () {
          my $data = $request->{cb}->();
  
          defined $data && length $data
            or last;
  
          if ( $] ge '5.008' ) {
              utf8::downgrade($data, 1)
                  or die(qq/Wide character in write_chunked_body()\n/);
          }
  
          $len += length $data;
  
          my $chunk  = sprintf '%X', length $data;
             $chunk .= "\x0D\x0A";
             $chunk .= $data;
             $chunk .= "\x0D\x0A";
  
          $self->write($chunk);
      }
      $self->write("0\x0D\x0A");
      $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_header_lines($headers, "$method $request_uri HTTP/1.1\x0D\x0A");
  }
  
  sub _do_timeout {
      my ($self, $type, $timeout) = @_;
      $timeout = $self->{timeout}
          unless defined $timeout && $timeout >= 0;
  
      my $fd = fileno $self->{fh};
      defined $fd && $fd >= 0
        or die(qq/select(2): 'Bad file descriptor'\n/);
  
      my $initial = time;
      my $pending = $timeout;
      my $nfound;
  
      vec(my $fdset = '', $fd, 1) = 1;
  
      while () {
          $nfound = ($type eq 'read')
              ? select($fdset, undef, undef, $pending)
              : select(undef, $fdset, undef, $pending) ;
          if ($nfound == -1) {
              $! == EINTR
                or die(qq/select(2): '$!'\n/);
              redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
              $nfound = 0;
          }
          last;
      }
      $! = 0;
      return $nfound;
  }
  
  sub can_read {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
      my $self = shift;
      if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
          return 1 if $self->{fh}->pending;
      }
      return $self->_do_timeout('read', @_)
  }
  
  sub can_write {
      @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
      my $self = shift;
      return $self->_do_timeout('write', @_)
  }
  
  sub _assert_ssl {
      # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
      die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/)
          unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)};
      # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
      die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
          unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
  }
  
  sub can_reuse {
      my ($self,$scheme,$host,$port) = @_;
      return 0 if
           length($self->{rbuf})
          || $scheme ne $self->{scheme}
          || $host ne $self->{host}
          || $port ne $self->{port}
          || eval { $self->can_read(0) }
          || $@ ;
          return 1;
  }
  
  # Try to find a CA bundle to validate the SSL cert,
  # prefer Mozilla::CA or fallback to a system file
  sub _find_CA_file {
      my $self = shift();
  
      return $self->{SSL_options}->{SSL_ca_file}
          if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
  
      return Mozilla::CA::SSL_ca_file()
          if eval { require Mozilla::CA };
  
      foreach my $ca_bundle (qw{
          /etc/ssl/certs/ca-certificates.crt
          /etc/pki/tls/certs/ca-bundle.crt
          /etc/ssl/ca-bundle.pem
          }
      ) {
          return $ca_bundle if -e $ca_bundle;
      }
  
      die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
        . qq/Try installing Mozilla::CA from CPAN\n/;
  }
  
  sub _ssl_args {
      my ($self, $host) = @_;
  
      my %ssl_args;
  
      # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
      # added until IO::Socket::SSL 1.84
      if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
          $ssl_args{SSL_hostname} = $host,          # Sane SNI support
      }
  
      if ($self->{verify_SSL}) {
          $ssl_args{SSL_verifycn_scheme}  = 'http'; # enable CN validation
          $ssl_args{SSL_verifycn_name}    = $host;  # set validation hostname
          $ssl_args{SSL_verify_mode}      = 0x01;   # enable cert validation
          $ssl_args{SSL_ca_file}          = $self->_find_CA_file;
      }
      else {
          $ssl_args{SSL_verifycn_scheme}  = 'none'; # disable CN validation
          $ssl_args{SSL_verify_mode}      = 0x00;   # disable cert validation
      }
  
      # user options override settings from verify_SSL
      for my $k ( keys %{$self->{SSL_options}} ) {
          $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
      }
  
      return \%ssl_args;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding UTF-8
  
  =head1 NAME
  
  HTTP::Tiny - A small, simple, correct HTTP/1.1 client
  
  =head1 VERSION
  
  version 0.043
  
  =head1 SYNOPSIS
  
      use HTTP::Tiny;
  
      my $response = HTTP::Tiny->new->get('http://example.com/');
  
      die "Failed!\n" unless $response->{success};
  
      print "$response->{status} $response->{reason}\n";
  
      while (my ($k, $v) = each %{$response->{headers}}) {
          for (ref $v eq 'ARRAY' ? @$v : $v) {
              print "$k: $_\n";
          }
      }
  
      print $response->{content} if length $response->{content};
  
  =head1 DESCRIPTION
  
  This is a very simple HTTP/1.1 client, designed for doing simple
  requests without the overhead of a large framework like L<LWP::UserAgent>.
  
  It is more correct and more complete than L<HTTP::Lite>.  It supports
  proxies and redirection.  It also correctly resumes after EINTR.
  
  If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
  of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
  
  Cookie support requires L<HTTP::CookieJar> or an equivalent class.
  
  =head1 METHODS
  
  =head2 new
  
      $http = HTTP::Tiny->new( %attributes );
  
  This constructor returns a new HTTP::Tiny object.  Valid attributes include:
  
  =over 4
  
  =item *
  
  C<agent>
  
  A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
  
  =item *
  
  C<cookie_jar>
  
  An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
  
  =item *
  
  C<default_headers>
  
  A hashref of default headers to apply to requests
  
  =item *
  
  C<local_address>
  
  The local IP address to bind to
  
  =item *
  
  C<keep_alive>
  
  Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
  
  =item *
  
  C<max_redirect>
  
  Maximum number of redirects allowed (defaults to 5)
  
  =item *
  
  C<max_size>
  
  Maximum response size (only when not using a data callback).  If defined, responses larger than this will return an exception.
  
  =item *
  
  C<http_proxy>
  
  URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
  
  =item *
  
  C<https_proxy>
  
  URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
  
  =item *
  
  C<proxy>
  
  URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
  
  =item *
  
  C<no_proxy>
  
  List of domain suffixes that should not be proxied.  Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
  
  =item *
  
  C<timeout>
  
  Request timeout in seconds (default is 60)
  
  =item *
  
  C<verify_SSL>
  
  A boolean that indicates whether to validate the SSL certificate of an C<https>
  connection (default is false)
  
  =item *
  
  C<SSL_options>
  
  A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
  
  =back
  
  Exceptions from C<max_size>, C<timeout> or other errors will result in a
  pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
  content field in the response will contain the text of the exception.
  
  The C<keep_alive> parameter enables a persistent connection, but only to a
  single destination scheme, host and port.  Also, if any connection-relevant
  attributes are modified, a persistent connection will be dropped.  If you want
  persistent connections across multiple destinations, use multiple HTTP::Tiny
  objects.
  
  See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
  
  =head2 get|head|put|post|delete
  
      $response = $http->get($url);
      $response = $http->get($url, \%options);
      $response = $http->head($url);
  
  These methods are shorthand for calling C<request()> for the given method.  The
  URL must have unsafe characters escaped and international domain names encoded.
  See C<request()> for valid options and a description of the response.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 post_form
  
      $response = $http->post_form($url, $form_data);
      $response = $http->post_form($url, $form_data, \%options);
  
  This method executes a C<POST> request and sends the key/value pairs from a
  form data hash or array reference to the given URL with a C<content-type> of
  C<application/x-www-form-urlencoded>.  If data is provided as an array
  reference, the order is preserved; if provided as a hash reference, the terms
  are sorted on key and value for consistency.  See documentation for the
  C<www_form_urlencode> method for details on the encoding.
  
  The URL must have unsafe characters escaped and international domain names
  encoded.  See C<request()> for valid options and a description of the response.
  Any C<content-type> header or content in the options hashref will be ignored.
  
  The C<success> field of the response will be true if the status code is 2XX.
  
  =head2 mirror
  
      $response = $http->mirror($url, $file, \%options)
      if ( $response->{success} ) {
          print "$file is up to date\n";
      }
  
  Executes a C<GET> request for the URL and saves the response body to the file
  name provided.  The URL must have unsafe characters escaped and international
  domain names encoded.  If the file already exists, the request will include an
  C<If-Modified-Since> header with the modification timestamp of the file.  You
  may specify a different C<If-Modified-Since> header yourself in the C<<
  $options->{headers} >> hash.
  
  The C<success> field of the response will be true if the status code is 2XX
  or if the status code is 304 (unmodified).
  
  If the file was modified and the server response includes a properly
  formatted C<Last-Modified> header, the file modification time will
  be updated accordingly.
  
  =head2 request
  
      $response = $http->request($method, $url);
      $response = $http->request($method, $url, \%options);
  
  Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
  'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
  international domain names encoded.
  
  If the URL includes a "user:password" stanza, they will be used for Basic-style
  authorization headers.  (Authorization headers will not be included in a
  redirected request.) For example:
  
      $http->request('GET', 'http://Aladdin:open sesame@example.com/');
  
  If the "user:password" stanza contains reserved characters, they must
  be percent-escaped:
  
      $http->request('GET', 'http://john%40example.com:password@example.com/');
  
  A hashref of options may be appended to modify the request.
  
  Valid options are:
  
  =over 4
  
  =item *
  
  C<headers>
  
  A hashref containing headers to include with the request.  If the value for
  a header is an array reference, the header will be output multiple times with
  each value in the array.  These headers over-write any default headers.
  
  =item *
  
  C<content>
  
  A scalar to include as the body of the request OR a code reference
  that will be called iteratively to produce the body of the request
  
  =item *
  
  C<trailer_callback>
  
  A code reference that will be called if it exists to provide a hashref
  of trailing headers (only used with chunked transfer-encoding)
  
  =item *
  
  C<data_callback>
  
  A code reference that will be called for each chunks of the response
  body received.
  
  =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<content> option is the empty string, no C<content-type> or
  C<content-length> headers will be generated.
  
  If the C<data_callback> option is provided, it will be called iteratively until
  the entire response body is received.  The first argument will be a string
  containing a chunk of the response body, the second argument will be the
  in-progress response hash reference, as described below.  (This allows
  customizing the action of the callback based on the C<status> or C<headers>
  received prior to the content body.)
  
  The C<request> method returns a hashref containing the response.  The hashref
  will have the following keys:
  
  =over 4
  
  =item *
  
  C<success>
  
  Boolean indicating whether the operation returned a 2XX status code
  
  =item *
  
  C<url>
  
  URL that provided the response. This is the URL of the request unless
  there were redirections, in which case it is the last URL queried
  in a redirection chain
  
  =item *
  
  C<status>
  
  The HTTP status code of the response
  
  =item *
  
  C<reason>
  
  The response phrase returned by the server
  
  =item *
  
  C<content>
  
  The body of the response.  If the response does not have any content
  or if a data callback is provided to consume the response body,
  this will be the empty string
  
  =item *
  
  C<headers>
  
  A hashref of header fields.  All header field names will be normalized
  to be lower case. If a header is repeated, the value will be an arrayref;
  it will otherwise be a scalar string containing the value
  
  =back
  
  On an exception during the execution of the request, the C<status> field will
  contain 599, and the C<content> field will contain the text of the exception.
  
  =head2 www_form_urlencode
  
      $params = $http->www_form_urlencode( $data );
      $response = $http->get("http://example.com/query?$params");
  
  This method converts the key/value pairs from a data hash or array reference
  into a C<x-www-form-urlencoded> string.  The keys and values from the data
  reference will be UTF-8 encoded and escaped per RFC 3986.  If a value is an
  array reference, the key will be repeated with each of the values of the array
  reference.  If data is provided as a hash reference, the key/value pairs in the
  resulting string will be sorted by key and value for consistent ordering.
  
  =for Pod::Coverage SSL_options
  agent
  cookie_jar
  default_headers
  http_proxy
  https_proxy
  keep_alive
  local_address
  max_redirect
  max_size
  no_proxy
  proxy
  timeout
  verify_SSL
  
  =head1 SSL SUPPORT
  
  Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
  greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
  thrown if a new enough versions of these modules not installed or if the SSL
  encryption fails. An C<https> connection may be made via an C<http> proxy that
  supports the CONNECT command (i.e. RFC 2817).  You may not proxy C<https> via
  a proxy that itself requires C<https> to communicate.
  
  SSL provides two distinct capabilities:
  
  =over 4
  
  =item *
  
  Encrypted communication channel
  
  =item *
  
  Verification of server identity
  
  =back
  
  B<By default, HTTP::Tiny does not verify server identity>.
  
  Server identity verification is controversial and potentially tricky because it
  depends on a (usually paid) third-party Certificate Authority (CA) trust model
  to validate a certificate as legitimate.  This discriminates against servers
  with self-signed certificates or certificates signed by free, community-driven
  CA's such as L<CAcert.org|http://cacert.org>.
  
  By default, HTTP::Tiny does not make any assumptions about your trust model,
  threat level or risk tolerance.  It just aims to give you an encrypted channel
  when you need one.
  
  Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
  that an SSL connection has a valid SSL certificate corresponding to the host
  name of the connection and that the SSL certificate has been verified by a CA.
  Assuming you trust the CA, this will protect against a L<man-in-the-middle
  attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>.  If you are
  concerned about security, you should enable this option.
  
  Certificate verification requires a file containing trusted CA certificates.
  If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
  included with it as a source of trusted CA's.  (This means you trust Mozilla,
  the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
  toolchain used to install it, and your operating system security, right?)
  
  If that module is not available, then HTTP::Tiny will search several
  system-specific default locations for a CA certificate file:
  
  =over 4
  
  =item *
  
  /etc/ssl/certs/ca-certificates.crt
  
  =item *
  
  /etc/pki/tls/certs/ca-bundle.crt
  
  =item *
  
  /etc/ssl/ca-bundle.pem
  
  =back
  
  An exception will be raised if C<verify_SSL> is true and no CA certificate file
  is available.
  
  If you desire complete control over SSL connections, the C<SSL_options> attribute
  lets you provide a hash reference that will be passed through to
  C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
  example, to provide your own trusted CA file:
  
      SSL_options => {
          SSL_ca_file => $file_path,
      }
  
  The C<SSL_options> attribute could also be used for such things as providing a
  client certificate for authentication to a server or controlling the choice of
  cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
  details.
  
  =head1 PROXY SUPPORT
  
  HTTP::Tiny can proxy both C<http> and C<https> requests.  Only Basic proxy
  authorization is supported and it must be provided as part of the proxy URL:
  C<http://user:pass@proxy.example.com/>.
  
  HTTP::Tiny supports the following proxy environment variables:
  
  =over 4
  
  =item *
  
  http_proxy
  
  =item *
  
  https_proxy or HTTPS_PROXY
  
  =item *
  
  all_proxy or ALL_PROXY
  
  =back
  
  Tunnelling C<https> over an C<http> proxy using the CONNECT method is
  supported.  If your proxy uses C<https> itself, you can not tunnel C<https>
  over it.
  
  Be warned that proxying an C<https> connection opens you to the risk of a
  man-in-the-middle attack by the proxy server.
  
  The C<no_proxy> environment variable is supported in the format of a
  comma-separated list of domain extensions proxy should not be used for.
  
  Proxy arguments passed to C<new> will override their corresponding
  environment variables.
  
  =head1 LIMITATIONS
  
  HTTP::Tiny is I<conditionally compliant> with the
  L<HTTP/1.1 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 *
  
  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
  
  Despite the limitations listed above, HTTP::Tiny is considered
  feature-complete.  New feature requests should be directed to
  L<HTTP::Tiny::UA>.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item *
  
  L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
  
  =item *
  
  L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
  
  =item *
  
  L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
  
  =item *
  
  L<IO::Socket::IP> - Required for IPv6 support
  
  =item *
  
  L<IO::Socket::SSL> - Required for SSL support
  
  =item *
  
  L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
  
  =item *
  
  L<Mozilla::CA> - Required if you want to validate SSL certificates
  
  =item *
  
  L<Net::SSLeay> - Required for SSL support
  
  =back
  
  =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
  
  =head1 SUPPORT
  
  =head2 Bugs / Feature Requests
  
  Please report any bugs or feature requests through the issue tracker
  at L<https://github.com/chansen/p5-http-tiny/issues>.
  You will be notified automatically of any progress on your issue.
  
  =head2 Source Code
  
  This is open source software.  The code repository is available for
  public review and contribution under the terms of the license.
  
  L<https://github.com/chansen/p5-http-tiny>
  
    git clone https://github.com/chansen/p5-http-tiny.git
  
  =head1 AUTHORS
  
  =over 4
  
  =item *
  
  Christian Hansen <chansen@cpan.org>
  
  =item *
  
  David Golden <dagolden@cpan.org>
  
  =back
  
  =head1 CONTRIBUTORS
  
  =over 4
  
  =item *
  
  Alan Gardner <gardner@pythian.com>
  
  =item *
  
  Alessandro Ghedini <al3xbio@gmail.com>
  
  =item *
  
  Brad Gilbert <bgills@cpan.org>
  
  =item *
  
  Chris Nehren <apeiron@cpan.org>
  
  =item *
  
  Chris Weyl <cweyl@alumni.drew.edu>
  
  =item *
  
  Claes Jakobsson <claes@surfar.nu>
  
  =item *
  
  Clinton Gormley <clint@traveljury.com>
  
  =item *
  
  Craig Berry <cberry@cpan.org>
  
  =item *
  
  David Mitchell <davem@iabyn.com>
  
  =item *
  
  Edward Zborowski <ed@rubensteintech.com>
  
  =item *
  
  Jess Robinson <castaway@desert-island.me.uk>
  
  =item *
  
  Lukas Eklund <leklund@gmail.com>
  
  =item *
  
  Martin J. Evans <mjegh@ntlworld.com>
  
  =item *
  
  Martin-Louis Bright <mlbright@gmail.com>
  
  =item *
  
  Mike Doherty <doherty@cpan.org>
  
  =item *
  
  Petr Písař <ppisar@redhat.com>
  
  =item *
  
  Serguei Trouchelle <stro@cpan.org>
  
  =item *
  
  Syohei YOSHIDA <syohex@gmail.com>
  
  =item *
  
  Tony Cook <tony@develop-help.com>
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  This software is copyright (c) 2014 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{"Hash/MultiValue.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HASH_MULTIVALUE';
  package Hash::MultiValue;
  
  use strict;
  no warnings 'void';
  use 5.006_002;
  our $VERSION = '0.16';
  
  use Carp ();
  use Scalar::Util qw(refaddr);
  
  # there does not seem to be a relevant RT or perldelta entry for this
  use constant _SPLICE_SAME_ARRAY_SEGFAULT => $] < '5.008007';
  
  my %keys;
  my %values;
  my %registry;
  
  BEGIN {
      require Config;
      my $needs_registry = ($^O eq 'Win32' || $Config::Config{useithreads});
      if ($needs_registry) {
          *CLONE = sub {
              foreach my $oldaddr (keys %registry) {
                  my $this = refaddr $registry{$oldaddr};
                  $keys{$this}   = delete $keys{$oldaddr};
                  $values{$this} = delete $values{$oldaddr};
                  Scalar::Util::weaken($registry{$this} = delete $registry{$oldaddr});
              }
          };
      }
      *NEEDS_REGISTRY = sub () { $needs_registry };
  }
  
  if (defined &UNIVERSAL::ref::import) {
      UNIVERSAL::ref->import;
  }
  
  sub ref { 'HASH' }
  
  sub create {
      my $class = shift;
      my $self = bless {}, $class;
      my $this = refaddr $self;
      $keys{$this} = [];
      $values{$this} = [];
      Scalar::Util::weaken($registry{$this} = $self) if NEEDS_REGISTRY;
      $self;
  }
  
  sub new {
      my $class = shift;
      my $self = $class->create;
      unshift @_, $self;
      &{ $self->can('merge_flat') };
  }
  
  sub from_mixed {
      my $class = shift;
      my $self = $class->create;
      unshift @_, $self;
      &{ $self->can('merge_mixed') };
  }
  
  sub DESTROY {
      my $this = refaddr shift;
      delete $keys{$this};
      delete $values{$this};
      delete $registry{$this} if NEEDS_REGISTRY;
  }
  
  sub get {
      my($self, $key) = @_;
      $self->{$key};
  }
  
  sub get_all {
      my($self, $key) = @_;
      my $this = refaddr $self;
      my $k = $keys{$this};
      (@{$values{$this}}[grep { $key eq $k->[$_] } 0 .. $#$k]);
  }
  
  sub get_one {
      my ($self, $key) = @_;
      my @v = $self->get_all($key);
      return $v[0] if @v == 1;
      Carp::croak "Key not found: $key" if not @v;
      Carp::croak "Multiple values match: $key";
  }
  
  sub set {
      my $self = shift;
      my $key = shift;
  
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
  
      my @idx = grep { $key eq $k->[$_] } 0 .. $#$k;
  
      my $added = @_ - @idx;
      if ($added > 0) {
          my $start = $#$k + 1;
          push @$k, ($key) x $added;
          push @idx, $start .. $#$k;
      }
      elsif ($added < 0) {
          my ($start, @drop, @keep) = splice @idx, $added;
          for my $i ($start+1 .. $#$k) {
              if (@drop and $i == $drop[0]) {
                  shift @drop;
                  next;
              }
              push @keep, $i;
          }
  
          splice @$_, $start, 0+@$_, ( _SPLICE_SAME_ARRAY_SEGFAULT
              ? @{[ @$_[@keep] ]} # force different source array
              :     @$_[@keep]
          ) for $k, $v;
      }
  
      if (@_) {
          @$v[@idx] = @_;
          $self->{$key} = $_[-1];
      }
      else {
          delete $self->{$key};
      }
  
      $self;
  }
  
  sub add {
      my $self = shift;
      my $key = shift;
      $self->merge_mixed( $key => \@_ );
      $self;
  }
  
  sub merge_flat {
      my $self = shift;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
      push @{ $_ & 1 ? $v : $k }, $_[$_] for 0 .. $#_;
      @{$self}{@$k} = @$v;
      $self;
  }
  
  sub merge_mixed {
      my $self = shift;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
  
      my $hash;
      $hash = shift if @_ == 1;
  
      while ( my ($key, $value) = @_ ? splice @_, 0, 2 : each %$hash ) {
          if ( CORE::ref($value) eq 'ARRAY' ) {
              next if not @$value;
              push @$k, ($key) x @$value;
              push @$v, @$value;
          }
          else {
              push @$k, $key;
              push @$v, $value;
          }
          $self->{$key} = $v->[-1];
      }
  
      $self;
  }
  
  sub remove {
      my ($self, $key) = @_;
      $self->set($key);
      $self;
  }
  
  sub clear {
      my $self = shift;
      %$self = ();
      my $this = refaddr $self;
      $keys{$this} = [];
      $values{$this} = [];
      $self;
  }
  
  sub clone {
      my $self = shift;
      CORE::ref($self)->new($self->flatten);
  }
  
  sub keys {
      my $self = shift;
      return @{$keys{refaddr $self}};
  }
  
  sub values {
      my $self = shift;
      return @{$values{refaddr $self}};
  }
  
  sub flatten {
      my $self = shift;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
      map { $k->[$_], $v->[$_] } 0 .. $#$k;
  }
  
  sub each {
      my ($self, $code) = @_;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
      for (0 .. $#$k) {
          $code->($k->[$_], $v->[$_]);
      }
      return $self;
  }
  
  sub as_hashref {
      my $self = shift;
      my %hash = %$self;
      \%hash;
  }
  
  sub as_hashref_mixed {
      my $self = shift;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
  
      my %hash;
      push @{$hash{$k->[$_]}}, $v->[$_] for 0 .. $#$k;
      for (CORE::values %hash) {
          $_ = $_->[0] if 1 == @$_;
      }
  
      \%hash;
  }
  
  *mixed = \&as_hashref_mixed;
  
  sub as_hashref_multi {
      my $self = shift;
      my $this = refaddr $self;
      my $k = $keys{$this};
      my $v = $values{$this};
  
      my %hash;
      push @{$hash{$k->[$_]}}, $v->[$_] for 0 .. $#$k;
  
      \%hash;
  }
  
  *multi = \&as_hashref_multi;
  
  sub STORABLE_freeze {
      my $self = shift;
      my $this = refaddr $self;
      return '', $keys{$this}, $values{$this};
  }
  
  sub STORABLE_thaw {
      my $self = shift;
      my ($is_cloning, $serialised, $k, $v) = @_;
      my $this = refaddr $self;
      $keys  {$this} = $k;
      $values{$this} = $v;
      @{$self}{@$k} = @$v;
      return $self;
  }
  
  1;
  __END__
  
  =encoding utf-8
  
  =for stopwords
  
  =head1 NAME
  
  Hash::MultiValue - Store multiple values per key
  
  =head1 SYNOPSIS
  
    use Hash::MultiValue;
  
    my $hash = Hash::MultiValue->new(
        foo => 'a',
        foo => 'b',
        bar => 'baz',
    );
  
    # $hash is an object, but can be used as a hashref and DWIMs!
    my $foo = $hash->{foo};         # 'b' (the last entry)
    my $foo = $hash->get('foo');    # 'b' (always, regardless of context)
    my @foo = $hash->get_all('foo'); # ('a', 'b')
  
    keys %$hash; # ('foo', 'bar')    not guaranteed to be ordered
    $hash->keys; # ('foo', 'foo', 'bar') guaranteed to be ordered
  
  =head1 DESCRIPTION
  
  Hash::MultiValue is an object (and a plain hash reference) that may
  contain multiple values per key, inspired by MultiDict of WebOb.
  
  =head1 RATIONALE
  
  In a typical web application, the request parameters (a.k.a CGI
  parameters) can be single value or multi values. Using CGI.pm style
  C<param> is one way to deal with this problem (and it is good, as long
  as you're aware of its list context gotcha), but there's another
  approach to convert parameters into a hash reference, like Catalyst's
  C<< $c->req->parameters >> does, and it B<sucks>.
  
  Why? Because the value could be just a scalar if there is one value
  and an array ref if there are multiple, depending on I<user input>
  rather than I<how you code it>. So your code should always be like
  this to be defensive:
  
    my $p = $c->req->parameters;
    my @maybe_multi = ref $p->{m} eq 'ARRAY' ? @{$p->{m}} : ($p->{m});
    my $must_single = ref $p->{m} eq 'ARRAY' ? $p->{m}->[0] : $p->{m};
  
  Otherwise you'll get a random runtime exception of I<Can't use string
  as an ARRAY ref> or get stringified array I<ARRAY(0xXXXXXXXXX)> as a
  string, I<depending on user input> and that is miserable and
  insecure.
  
  This module provides a solution to this by making it behave like a
  single value hash reference, but also has an API to get multiple
  values on demand, explicitly.
  
  =head1 HOW THIS WORKS
  
  The object returned by C<new> is a blessed hash reference that
  contains the last entry of the same key if there are multiple values,
  but it also keeps the original pair state in the object tracker (a.k.a
  inside out objects) and allows you to access the original pairs and
  multiple values via the method calls, such as C<get_all> or C<flatten>.
  
  This module does not use C<tie> or L<overload> and is quite fast.
  
  Yes, there is L<Tie::Hash::MultiValue> and this module tries to solve
  exactly the same problem, but using a different implementation.
  
  =head1 UPDATING CONTENTS
  
  When you update the content of the hash, B<DO NOT UPDATE> using the
  hash reference interface: this won't write through to the tracking
  object.
  
    my $hash = Hash::MultiValue->new(...);
  
    # WRONG
    $hash->{foo} = 'bar';
    delete $hash->{foo};
  
    # Correct
    $hash->add(foo => 'bar');
    $hash->remove('foo');
  
  See below for the list of updating methods.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
    $hash = Hash::MultiValue->new(@pairs);
  
  Creates a new object that can be treated as a plain hash reference as well.
  
  =item get
  
    $value = $hash->get($key);
    $value = $hash->{$key};
  
  Returns a single value for the given C<$key>. If there are multiple
  values, the last one (not first one) is returned. See below for why.
  
  Note that this B<always> returns the single element as a scalar,
  regardless of its context, unlike CGI.pm's C<param> method etc.
  
  =item get_one
  
    $value = $hash->get_one($key);
  
  Returns a single value for the given C<$key>. This method B<croaks> if
  there is no value or multiple values associated with the key, so you
  should wrap it with eval or modules like L<Try::Tiny>.
  
  =item get_all
  
    @values = $hash->get_all($key);
  
  Returns a list of values for the given C<$key>. This method B<always>
  returns a list regardless of its context. If there is no value
  attached, the result will be an empty list.
  
  =item keys
  
    @keys = $hash->keys;
  
  Returns a list of all keys, including duplicates (see the example in the
  L</SYNOPSIS>).
  
  If you want only unique keys, use C<< keys %$hash >>, as normal.
  
  =item values
  
    @values = $hash->values;
  
  Returns a list of all values, in the same order as C<< $hash->keys >>.
  
  =item set
  
    $hash->set($key [, $value ... ]);
  
  Changes the stored value(s) of the given C<$key>. This removes or adds
  pairs as necessary to store the new list but otherwise preserves order
  of existing pairs. C<< $hash->{$key} >> is updated to point to the last
  value.
  
  =item add
  
    $hash->add($key, $value [, $value ... ]);
  
  Appends a new value to the given C<$key>. This updates the value of
  C<< $hash->{$key} >> as well so it always points to the last value.
  
  =item remove
  
    $hash->remove($key);
  
  Removes a key and associated values for the given C<$key>.
  
  =item clear
  
    $hash->clear;
  
  Clears the hash to be an empty hash reference.
  
  =item flatten
  
    @pairs = $hash->flatten;
  
  Gets pairs of keys and values. This should be exactly the same pairs
  which are given to C<new> method unless you updated the data.
  
  =item each
  
    $hash->each($code);
  
    # e.g.
    $hash->each(sub { print "$_[0] = $_[1]\n" });
  
  Calls C<$code> once for each C<($key, $value)> pair.  This is a more convenient
  alternative to calling C<flatten> and then iterating over it two items at a
  time.
  
  Inside C<$code>, C<$_> contains the current iteration through the loop,
  starting at 0.  For example:
  
    $hash = Hash::MultiValue->new(a => 1, b => 2, c => 3, a => 4);
  
    $hash->each(sub { print "$_: $_[0] = $_[1]\n" });
    # 0: a = 1
    # 1: b = 2
    # 2: c = 3
    # 3: a = 4
  
  Be careful B<not> to change C<@_> inside your coderef!  It will update
  the tracking object but not the plain hash.  In the future, this
  limitation I<may> be removed.
  
  =item clone
  
    $new = $hash->clone;
  
  Creates a new Hash::MultiValue object that represents the same data,
  but obviously not sharing the reference. It's identical to:
  
    $new = Hash::MultiValue->new($hash->flatten);
  
  =item as_hashref
  
    $copy = $hash->as_hashref;
  
  Creates a new plain (unblessed) hash reference where a value is a
  single scalar. It's identical to:
  
    $copy = +{%$hash};
  
  =item as_hashref_mixed, mixed
  
    $mixed = $hash->as_hashref_mixed;
    $mixed = $hash->mixed;
  
  Creates a new plain (unblessed) hash reference where the value is a
  single scalar, or an array ref when there are multiple values for a
  same key. Handy to create a hash reference that is often used in web
  application frameworks request objects such as L<Catalyst>. Ths method
  does exactly the opposite of C<from_mixed>.
  
  =item as_hashref_multi, multi
  
    $multi = $hash->as_hashref_multi;
    $multi = $hash->multi;
  
  Creates a new plain (unblessed) hash reference where values are all
  array references, regardless of there are single or multiple values
  for a same key.
  
  =item from_mixed
  
    $hash = Hash::MultiValue->from_mixed({
        foo => [ 'a', 'b' ],
        bar => 'c',
    });
  
  Creates a new object out of a hash reference where the value is single
  or an array ref depending on the number of elements. Handy to convert
  from those request objects used in web frameworks such as L<Catalyst>.
  This method does exactly the opposite of C<as_hashref_mixed>.
  
  =back
  
  =head1 WHY LAST NOT FIRST?
  
  You might wonder why this module uses the I<last> value of the same
  key instead of I<first>. There's no strong reasoning on this decision
  since one is as arbitrary as the other, but this is more consistent to
  what Perl does:
  
    sub x {
        return ('a', 'b', 'c');
    }
  
    my $x = x(); # $x = 'c'
  
    my %a = ( a => 1 );
    my %b = ( a => 2 );
  
    my %m = (%a, %b); # $m{a} = 2
  
  When perl gets a list in a scalar context it gets the last entry. Also
  if you merge hashes having a same key, the last one wins.
  
  =head1 NOTES ON ref
  
  If you pass this MultiValue hash object to some upstream functions
  that you can't control and does things like:
  
    if (ref $args eq 'HASH') {
        ...
    }
  
  because this is a blessed hash reference it doesn't match and would
  fail. To avoid that you should call C<as_hashref> to get a
  I<finalized> (= non-blessed) hash reference.
  
  You can also use UNIVERSAL::ref to make it work magically:
  
    use UNIVERSAL::ref;    # before loading Hash::MultiValue
    use Hash::MultiValue;
  
  and then all C<ref> calls to Hash::MultiValue objects will return I<HASH>.
  
  =head1 THREAD SAFETY
  
  Prior to version 0.09, this module wasn't safe in a threaded
  environment, including win32 fork() emulation. Versions newer than
  0.09 is considered thread safe.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
  
  Aristotle Pagaltzis
  
  Hans Dieter Pearcey
  
  Thanks to Michael Peters for the suggestion to use inside-out objects
  instead of tie.
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  =over 4
  
  =item * L<http://pythonpaste.org/webob/#multidict>
  
  =item * L<Tie::Hash::MultiValue>
  
  =back
  
  =cut
HASH_MULTIVALUE

$fatpacked{"POSIX/strftime/Compiler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POSIX_STRFTIME_COMPILER';
  package POSIX::strftime::Compiler;
  
  use 5.008001;
  use strict;
  use warnings;
  use Carp;
  use Time::Local qw//;
  use POSIX qw//;
  use base qw/Exporter/;
  
  our $VERSION = "0.41";
  our @EXPORT_OK = qw/strftime/;
  
  use constant {
      SEC => 0,
      MIN => 1,
      HOUR => 2,
      DAY => 3,
      MONTH => 4,
      YEAR => 5,
      WDAY => 6,
      YDAY => 7,
      ISDST => 8,
      ISO_WEEK_START_WDAY => 1,  # Monday
      ISO_WEEK1_WDAY      => 4,  # Thursday
      YDAY_MINIMUM        => -366,
  };
  
  BEGIN {
      *tzoffset = \&_tzoffset;
      *tzname = \&_tzname;
  
      if (eval { require Time::TZOffset; 1; }) {
          no warnings 'redefine';
          *tzoffset = \&Time::TZOffset::tzoffset;
      }
  }
  
  
  # copy from POSIX/strftime/GNU/PP.pm and modify
  my @offset2zone = qw(
      -1100       0 SST     -1100       0 SST
      -1000       0 HAST    -0900       1 HADT
      -1000       0 HST     -1000       0 HST
      -0930       0 MART    -0930       0 MART
      -0900       0 AKST    -0800       1 AKDT
      -0900       0 GAMT    -0900       0 GAMT
      -0800       0 PST     -0700       1 PDT
      -0800       0 PST     -0800       0 PST
      -0700       0 MST     -0600       1 MDT
      -0700       0 MST     -0700       0 MST
      -0600       0 CST     -0500       1 CDT
      -0600       0 GALT    -0600       0 GALT
      -0500       0 ECT     -0500       0 ECT
      -0500       0 EST     -0400       1 EDT
      -0500       1 EASST   -0600       0 EAST
      -0430       0 VET     -0430       0 VET
      -0400       0 AMT     -0400       0 AMT
      -0400       0 AST     -0300       1 ADT
      -0330       0 NST     -0230       1 NDT
      -0300       0 ART     -0300       0 ART
      -0300       0 PMST    -0200       1 PMDT
      -0300       1 AMST    -0400       0 AMT
      -0300       1 WARST   -0300       1 WARST
      -0200       0 FNT     -0200       0 FNT
      -0200       1 UYST    -0300       0 UYT
      -0100       0 AZOT    +0000       1 AZOST
      -0100       0 CVT     -0100       0 CVT
      +0000       0 GMT     +0000       0 GMT
      +0000       0 WET     +0100       1 WEST
      +0100       0 CET     +0200       1 CEST
      +0100       0 WAT     +0100       0 WAT
      +0200       0 EET     +0200       0 EET
      +0200       0 IST     +0300       1 IDT
      +0200       1 WAST    +0100       0 WAT
      +0300       0 FET     +0300       0 FET
      +030704     0 zzz     +030704     0 zzz
      +0330       0 IRST    +0430       1 IRDT
      +0400       0 AZT     +0500       1 AZST
      +0400       0 GST     +0400       0 GST
      +0430       0 AFT     +0430       0 AFT
      +0500       0 DAVT    +0700       0 DAVT
      +0500       0 MVT     +0500       0 MVT
      +0530       0 IST     +0530       0 IST
      +0545       0 NPT     +0545       0 NPT
      +0600       0 BDT     +0600       0 BDT
      +0630       0 CCT     +0630       0 CCT
      +0700       0 ICT     +0700       0 ICT
      +0800       0 HKT     +0800       0 HKT
      +0845       0 CWST    +0845       0 CWST
      +0900       0 JST     +0900       0 JST
      +0930       0 CST     +0930       0 CST
      +1000       0 PGT     +1000       0 PGT
      +1030       1 CST     +0930       0 CST
      +1100       0 CAST    +0800       0 WST
      +1100       0 NCT     +1100       0 NCT
      +1100       1 EST     +1000       0 EST
      +1100       1 LHST    +1030       0 LHST
      +1130       0 NFT     +1130       0 NFT
      +1200       0 FJT     +1200       0 FJT
      +1300       0 TKT     +1300       0 TKT
      +1300       1 NZDT    +1200       0 NZST
      +1345       1 CHADT   +1245       0 CHAST
      +1400       0 LINT    +1400       0 LINT
      +1400       1 WSDT    +1300       0 WST
  );
  
  sub _tzoffset {
      my $diff = (exists $ENV{TZ} and $ENV{TZ} =~ m!^(?:GMT|UTC)$!)
               ? 0
               : Time::Local::timegm(@_) - Time::Local::timelocal(@_);
      sprintf '%+03d%02u', $diff/60/60, $diff/60%60;
  }
  
  sub _tzname {
      return $ENV{TZ} if exists $ENV{TZ} and $ENV{TZ} =~ m!^(?:GMT|UTC)$!;
  
      my $diff = tzoffset(@_);
  
      my @t1 = my @t2 = @_;
      @t1[3,4] = (1, 1);  # winter
      my $diff1 = tzoffset(@t1);
      @t2[3,4] = (1, 7);  # summer
      my $diff2 = tzoffset(@t2);
  
      for (my $i=0; $i < @offset2zone; $i += 6) {
          next unless $offset2zone[$i] eq $diff1 and $offset2zone[$i+3] eq $diff2;
          return $diff2 eq $diff ? $offset2zone[$i+5] : $offset2zone[$i+2];
      }
  
      if ($diff =~ /^([+-])(\d\d)$/) {
          return sprintf 'GMT%s%d', $1 eq '-' ? '+' : '-', $2;
      };
  
      return 'Etc';
  }
  
  sub iso_week_days {
      my ($yday, $wday) = @_;
  
      # Add enough to the first operand of % to make it nonnegative.
      my $big_enough_multiple_of_7 = (int(- YDAY_MINIMUM / 7) + 2) * 7;
      return ($yday
          - ($yday - $wday + ISO_WEEK1_WDAY + $big_enough_multiple_of_7) % 7
          + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
  }
  
  sub isleap {
      my $year = shift;
      return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) ? 1 : 0
  }
  
  sub isodaysnum {
      my @t = @_;
  
      my $year = ($t[YEAR] + ($t[YEAR] < 0 ? 1900 % 400 : 1900 % 400 - 400));
      my $year_adjust = 0;
      my $days = iso_week_days($t[YDAY], $t[WDAY]);
  
      if ($days < 0) {
          # This ISO week belongs to the previous year.
          $year_adjust = -1;
          $days = iso_week_days($t[YDAY] + (365 + isleap($year -1)), $t[WDAY]);
      }
      else {
          my $d = iso_week_days($t[YDAY] - (365 + isleap($year)), $t[WDAY]);
          if ($d >= 0) {
              # This ISO week belongs to the next year.  */
              $year_adjust = 1;
              $days = $d;
          }
      }
  
      return ($days, $year_adjust);
  }
  
  sub isoyearnum {
      my ($days, $year_adjust) = isodaysnum(@_);
      return $_[YEAR] + 1900 + $year_adjust;
  }
  
  sub isoweeknum {
      my ($days, $year_adjust) = isodaysnum(@_);
      return int($days / 7) + 1;
  }
  
  our %FORMAT_CHARS = map { $_ => 1 } split //, q!%aAbBcCdDeFGghHIjklmMnNpPrRsStTuUVwWxXyYzZ!;
  
  our %SPRINTF_CHARS = (
      '%' => [q!%s!, q!%!],
      'a' => [q!%s!, q!$weekday_abbr[$_[WDAY]]!],
      'A' => [q!%s!, q!$weekday_name[$_[WDAY]]!],
      'b' => [q!%s!, q!$month_abbr[$_[MONTH]]!],
      'B' => [q!%s!, q!$month_name[$_[MONTH]]!],
      'c' => [q!%s %s %2d %02d:%02d:%02d %04d!,
              q!$weekday_abbr[$_[WDAY]], $month_abbr[$_[MONTH]], $_[DAY], $_[HOUR], $_[MIN], $_[SEC], $_[YEAR]+1900!],
      'C' => [q!%02d!, q!($_[YEAR]+1900)/100!],
      'd' => [q!%02d!, q!$_[DAY]!],
      'D' => [q!%02d/%02d/%02d!, q!$_[MONTH]+1,$_[DAY],$_[YEAR]%100!],
      'e' => [q!%2d!, q!$_[DAY]!],
      'F' => [q!%04d-%02d-%02d!, q!$_[YEAR]+1900,$_[MONTH]+1,$_[DAY]!],
      'h' => [q!%s!, q!$month_abbr[$_[MONTH]]!],
      'H' => [q!%02d!, q!$_[HOUR]!],
      'I' => [q!%02d!, q!$_[HOUR]%12 || 1!],
      'j' => [q!%03d!, q!$_[YDAY]+1!],
      'k' => [q!%2d!, q!$_[HOUR]!],
      'l' => [q!%2d!, q!$_[HOUR]%12 || 1!],
      'm' => [q!%02d!, q!$_[MONTH]+1!],
      'M' => [q!%02d!, q!$_[MIN]!],
      'n' => [q!%s!, q!"\n"!],
      'N' => [q!%s!, q!substr(sprintf('%.9f', $_[SEC] - int $_[SEC]), 2)!],
      'p' => [q!%s!, q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
      'P' => [q!%s!, q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "am" : "pm"!],
      'r' => [q!%02d:%02d:%02d %s!, q!$_[HOUR]%12 || 1, $_[MIN], $_[SEC], $_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
      'R' => [q!%02d:%02d!, q!$_[HOUR], $_[MIN]!],
      'S' => [q!%02d!, q!$_[SEC]!],
      't' => [q!%s!, q!"\t"!],
      'T' => [q!%02d:%02d:%02d!, q!$_[HOUR], $_[MIN], $_[SEC]!],
      'u' => [q!%d!, q!$_[WDAY] || 7!],
      'w' => [q!%d!, q!$_[WDAY]!],
      'x' => [q!%02d/%02d/%02d!, q!$_[MONTH]+1,$_[DAY],$_[YEAR]%100!],
      'X' => [q!%02d:%02d:%02d!, q!$_[HOUR], $_[MIN], $_[SEC]!],
      'y' => [q!%02d!, q!$_[YEAR]%100!],
      'Y' => [q!%02d!, q!$_[YEAR]+1900!],
      '%' => [q!%s!, q!'%'!],
  );
  
  if ( eval { require Time::TZOffset; 1 } ) {
      $SPRINTF_CHARS{z} = [q!%s!,q!Time::TZOffset::tzoffset(@_)!];
  }
  
  our %LOCALE_CHARS = (
      '%' => [q!'%%'!],
      'a' => [q!$weekday_abbr[$_[WDAY]]!,1],
      'A' => [q!$weekday_name[$_[WDAY]]!,1],
      'b' => [q!$month_abbr[$_[MONTH]]!],
      'B' => [q!$month_name[$_[MONTH]]!],
      'c' => [q!$weekday_abbr[$_[WDAY]] . ' ' . $month_abbr[$_[MONTH]] . ' ' . substr(' '.$_[DAY],-2) . ' %H:%M:%S %Y'!,1],
      'C' => [q!substr('0'.int(($_[YEAR]+1900)/100), -2)!],  #century
      'h' => [q!$month_abbr[$_[MONTH]]!],
      'N' => [q!substr(sprintf('%.9f', $_[SEC] - int $_[SEC]), 2)!],
      'n' => [q!"\n"!],
      'p' => [q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
      'P' => [q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "am" : "pm"!],
      'r' => [q!sprintf('%02d:%02d:%02d %s',$_[HOUR]%12 || 1, $_[MIN], $_[SEC], $_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM")!],
      't' => [q!"\t"!],
      'x' => [q!'%m/%d/%y'!],
      'X' => [q!'%H:%M:%S'!],
      'z' => [q!'%z'!,1],
      'Z' => [q!'%Z'!,1],
  );
  
  if ( $^O =~ m!^(MSWin32|cygwin)$!i ) {
      %LOCALE_CHARS = (
          %LOCALE_CHARS,
          'D' => [q!'%m/%d/%y'!],
          'F' => [q!'%Y-%m-%d'!],
          'G' => [q!substr('0000'. isoyearnum(@_), -4)!,1],
          'R' => [q!'%H:%M'!],
          'T' => [q!'%H:%M:%S'!],
          'V' => [q!substr('0'.isoweeknum(@_),-2)!,1],
          'e' => [q!substr(' '.$_[DAY],-2)!],
          'g' => [q!substr('0'.isoyearnum(@_)%100,-2)!,1],
          'k' => [q!substr(' '.$_[HOUR],-2)!],
          'l' => [q!substr(' '.($_[HOUR]%12 || 1),-2)!],
          's' => [q!int(Time::Local::timegm(@_))!,1],
          'u' => [q!$_[WDAY] || 7!,1],
          'z' => [q!tzoffset(@_)!,1],
          'Z' => [q!tzname(@_)!,1],
      );
  }
  elsif ( $^O =~ m!^solaris$!i ) {
      $LOCALE_CHARS{s} = [q!int(Time::Local::timegm(@_))!,1];
  }
  
  my $sprintf_char_handler = sub {
      my ($char,$args) = @_;
      return q|! . '%%' .q!| if $char eq ''; #last %
      return q|! . '%%| . $char . q|' . q!| if ! exists $FORMAT_CHARS{$char}; #escape %%
      my ($format, $code) = @{$SPRINTF_CHARS{$char}};
      push @$args, $code;
      return $format;
  };
  
  my $char_handler = sub {
      my ($char,$need9char_ref) = @_;
      return q|! . '%%' .q!| if $char eq ''; #last %
      return q|! . '%%| . $char . q|' . q!| if ! exists $FORMAT_CHARS{$char}; #escape %%
      return q|! . '%| . $char . q|' . q!| if ! exists $LOCALE_CHARS{$char}; #stay
      my ($code,$flag) = @{$LOCALE_CHARS{$char}};
      $$need9char_ref++ if $flag;
      q|! . | . $code . q| . q!|;
  };
  
  sub compile {
      my ($fmt) = @_;
  
      my @weekday_name = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
      my @weekday_abbr = qw(Sun Mon Tue Wed Thu Fri Sat);
      my @month_name = qw(January February March April May June July August September October November December);
      my @month_abbr = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  
      $fmt =~ s/!/\\!/g;
      $fmt =~ s!\%E([cCxXyY])!%$1!g;
      $fmt =~ s!\%O([deHImMSuUVwWy])!%$1!g;
  
      my $sprintf_fmt = $fmt;
      my $disable_sprintf=0;
      my $sprintf_code = '';
      while ( $sprintf_fmt =~ m~ (?:\%([\%\+a-zA-Z])) ~gx ) {
          if ( exists $FORMAT_CHARS{$1} && ! exists $SPRINTF_CHARS{$1} ) {
              $disable_sprintf++
          }
      }
      if ( !$disable_sprintf ) {
          my @args;
          $sprintf_fmt =~ s!
              (?:
                   \%([\%\+a-zA-Z]|$)
              )
          ! $sprintf_char_handler->($1,\@args) !egx;
          $sprintf_code = q~if ( @_ == 9 ) {
              return sprintf(q!~ . $sprintf_fmt .  q~!,~ . join(",", @args) . q~);
          }~;
      }
  
      my $posix_fmt = $fmt;
      my $need9char=0;
      $posix_fmt =~ s!
          (?:
               \%([\%\+a-zA-Z]|$)
          )
      ! $char_handler->($1,\$need9char) !egx;
      
      my $need9char_code='';
      if ( $need9char ) {
          $need9char_code = q~if ( @_ == 6 ) {
            my $sec = $_[0];
            @_ = gmtime Time::Local::timegm(@_);
            $_[0] = $sec;
          }~;
      }
      my $code = q~sub {
          if ( @_ != 9  && @_ != 6 ) {
              Carp::croak 'Usage: strftime(sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)';
          }
          ~ . $sprintf_code . q~
          ~ . $need9char_code . q~
          POSIX::strftime(q!~ . $posix_fmt . q~!,@_);
      }~;
      my $sub = eval $code; ## no critic
      die $@ ."\n=====\n".$code."\n=====\n" if $@;
      wantarray ? ($sub,$code) : $sub;
  }
  
  my %STRFTIME;
  sub strftime {
      my $fmt = shift;
      ($STRFTIME{$fmt} ||= compile($fmt))->(@_);
  }
  
  sub new {
      my $class = shift;
      my $fmt = shift;
      my ($sub,$code) = compile($fmt);
      bless [$sub,$code], $class;
  }
  
  sub to_string {
      my $self = shift;
      $self->[0]->(@_);
  }
  
  sub code_ref {
      my $self = shift;
      $self->[0];
  }
  
  1;
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  POSIX::strftime::Compiler - GNU C library compatible strftime for loggers and servers
  
  =head1 SYNOPSIS
  
      use POSIX::strftime::Compiler qw/strftime/;
  
      say strftime('%a, %d %b %Y %T %z',localtime):
      
      my $fmt = '%a, %d %b %Y %T %z';
      my $psc = POSIX::strftime::Compiler->new($fmt);
      say $psc->to_string(localtime);
  
  =head1 DESCRIPTION
  
  POSIX::strftime::Compiler provides GNU C library compatible strftime(3). But this module will not affected
  by the system locale.  This feature is useful when you want to write loggers, servers and portable applications.
  
  For generate same result strings on any locale, POSIX::strftime::Compiler wraps POSIX::strftime and 
  converts some format characters to perl code
  
  =head1 FUNCTION
  
  =over 4
  
  =item strftime($fmt:String, @time)
  
  Generate formatted string from a format and time.
  
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    strftime('%d/%b/%Y:%T %z',$sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst):
  
  Compiled codes are stored in C<%POSIX::strftime::Compiler::STRFTIME>. This function is not exported by default.
  
  =back
  
  =head1 METHODS
  
  =over 4
  
  =item new($fmt)
  
  create instance of POSIX::strftime::Compiler
  
  =item to_string(@time)
  
  Generate formatted string from time.
  
  =back
  
  =head1 FORMAT CHARACTERS
  
  POSIX::strftime::Compiler supports almost all characters that GNU strftime(3) supports. 
  But C<%E[cCxXyY]> and C<%O[deHImMSuUVwWy]> are not supported, just remove E and O prefix.
  
  =head1 A RECOMMEND MODULE
  
  =over
  
  =item L<Time::TZOffset>
  
  If L<Time::TZOffset> is available, P::s::Compiler use it for more faster time zone offset calculation.
  I strongly recommend you to install this if you use C<%z>.
  
  =back
  
  =head1 PERFORMANCE ISSUES ON WINDOWS
  
  Windows and Cygwin and some system may not support C<%z> and C<%Z>. For these system, 
  POSIX::strftime::Compiler calculate time zone offset and find zone name. This is not fast.
  If you need performance on Windows and Cygwin, please install L<Time::TZOffset>
  
  =head1 SEE ALSO
  
  =over 4
  
  =item L<POSIX::strftime::GNU>
  
  POSIX::strftime::Compiler is built on POSIX::strftime::GNU::PP code
  
  =item L<POSIX>
  
  =item L<Apache::LogFormat::Compiler>
  
  =back
  
  =head1 LICENSE
  
  Copyright (C) Masahiro Nagano.
  
  Format specification is based on strftime(3) manual page which is a part of the Linux man-pages project.
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 AUTHOR
  
  Masahiro Nagano E<lt>kazeburo@gmail.comE<gt>
  
  =cut
  
POSIX_STRFTIME_COMPILER

$fatpacked{"Plack.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK';
  package Plack;
  
  use strict;
  use warnings;
  use 5.008_001;
  our $VERSION = '1.0034';
  
  1;
  __END__
  
  =head1 NAME
  
  Plack - Perl Superglue for Web frameworks and Web Servers (PSGI toolkit)
  
  =head1 DESCRIPTION
  
  Plack is a set of tools for using the PSGI stack. It contains
  middleware components, a reference server and utilities for Web
  application frameworks. Plack is like Ruby's Rack or Python's Paste
  for WSGI.
  
  See L<PSGI> for the PSGI specification and L<PSGI::FAQ> to know what
  PSGI and Plack are and why we need them.
  
  =head1 MODULES AND UTILITIES
  
  =head2 Plack::Handler
  
  L<Plack::Handler> and its subclasses contains adapters for web
  servers. We have adapters for the built-in standalone web server
  L<HTTP::Server::PSGI>, L<CGI|Plack::Handler::CGI>,
  L<FCGI|Plack::Handler::FCGI>, L<Apache1|Plack::Handler::Apache1>,
  L<Apache2|Plack::Handler::Apache2> and
  L<HTTP::Server::Simple|Plack::Handler::HTTP::Server::Simple> included
  in the core Plack distribution.
  
  There are also many HTTP server implementations on CPAN that have Plack
  handlers.
  
  See L<Plack::Handler> when writing your own adapters.
  
  =head2 Plack::Loader
  
  L<Plack::Loader> is a loader to load one L<Plack::Handler> adapter
  and run a PSGI application code reference with it.
  
  =head2 Plack::Util
  
  L<Plack::Util> contains a lot of utility functions for server
  implementors as well as middleware authors.
  
  =head2 .psgi files
  
  A PSGI application is a code reference but it's not easy to pass code
  reference via the command line or configuration files, so Plack uses a
  convention that you need a file named C<app.psgi> or similar, which
  would be loaded (via perl's core function C<do>) to return the PSGI
  application code reference.
  
    # Hello.psgi
    my $app = sub {
        my $env = shift;
        # ...
        return [ $status, $headers, $body ];
    };
  
  If you use a web framework, chances are that they provide a helper
  utility to automatically generate these C<.psgi> files for you, such
  as:
  
    # MyApp.psgi
    use MyApp;
    my $app = sub { MyApp->run_psgi(@_) };
  
  It's important that the return value of C<.psgi> file is the code
  reference. See C<eg/dot-psgi> directory for more examples of C<.psgi>
  files.
  
  =head2 plackup, Plack::Runner
  
  L<plackup> is a command line launcher to run PSGI applications from
  command line using L<Plack::Loader> to load PSGI backends. It can be
  used to run standalone servers and FastCGI daemon processes. Other
  server backends like Apache2 needs a separate configuration but
  C<.psgi> application file can still be the same.
  
  If you want to write your own frontend that replaces, or adds
  functionalities to L<plackup>, take a look at the L<Plack::Runner> module.
  
  =head2 Plack::Middleware
  
  PSGI middleware is a PSGI application that wraps an existing PSGI
  application and plays both side of application and servers. From the
  servers the wrapped code reference still looks like and behaves
  exactly the same as PSGI applications.
  
  L<Plack::Middleware> gives you an easy way to wrap PSGI applications
  with a clean API, and compatibility with L<Plack::Builder> DSL.
  
  =head2 Plack::Builder
  
  L<Plack::Builder> gives you a DSL that you can enable Middleware in
  C<.psgi> files to wrap existent PSGI applications.
  
  =head2 Plack::Request, Plack::Response
  
  L<Plack::Request> gives you a nice wrapper API around PSGI C<$env>
  hash to get headers, cookies and query parameters much like
  L<Apache::Request> in mod_perl.
  
  L<Plack::Response> does the same to construct the response array
  reference.
  
  =head2 Plack::Test
  
  L<Plack::Test> is a unified interface to test your PSGI application
  using standard L<HTTP::Request> and L<HTTP::Response> pair with simple
  callbacks.
  
  =head2 Plack::Test::Suite
  
  L<Plack::Test::Suite> is a test suite to test a new PSGI server backend.
  
  =head1 CONTRIBUTING
  
  =head2 Patches and Bug Fixes
  
  Small patches and bug fixes can be either submitted via nopaste on IRC
  L<irc://irc.perl.org/#plack> or L<the github issue
  tracker|http://github.com/plack/Plack/issues>.  Forking on
  L<github|http://github.com/plack/Plack> is another good way if you
  intend to make larger fixes.
  
  See also L<http://contributing.appspot.com/plack> when you think this
  document is terribly outdated.
  
  =head2 Module Namespaces
  
  Modules added to the Plack:: sub-namespaces should be reasonably generic
  components which are useful as building blocks and not just simply using
  Plack.
  
  Middleware authors are free to use the Plack::Middleware:: namespace for
  their middleware components. Middleware must be written in the pipeline
  style such that they can chained together with other middleware components.
  The Plack::Middleware:: modules in the core distribution are good examples
  of such modules. It is recommended that you inherit from L<Plack::Middleware>
  for these types of modules.
  
  Not all middleware components are wrappers, but instead are more like
  endpoints in a middleware chain. These types of components should use the
  Plack::App:: namespace. Again, look in the core modules to see excellent
  examples of these (L<Plack::App::File>, L<Plack::App::Directory>, etc.).
  It is recommended that you inherit from L<Plack::Component> for these
  types of modules.
  
  B<DO NOT USE> Plack:: namespace to build a new web application or a
  framework. It's like naming your application under CGI:: namespace if
  it's supposed to run on CGI and that is a really bad choice and
  would confuse people badly.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 COPYRIGHT
  
  The following copyright notice applies to all the files provided in
  this distribution, including binary files, unless explicitly noted
  otherwise.
  
  Copyright 2009-2013 Tatsuhiko Miyagawa
  
  =head1 CORE DEVELOPERS
  
  Tatsuhiko Miyagawa (miyagawa)
  
  Tokuhiro Matsuno (tokuhirom)
  
  Jesse Luehrs (doy)
  
  Tomas Doran (bobtfish)
  
  Graham Knop (haarg)
  
  =head1 CONTRIBUTORS
  
  Yuval Kogman (nothingmuch)
  
  Kazuhiro Osawa (Yappo)
  
  Kazuho Oku
  
  Florian Ragwitz (rafl)
  
  Chia-liang Kao (clkao)
  
  Masahiro Honma (hiratara)
  
  Daisuke Murase (typester)
  
  John Beppu
  
  Matt S Trout (mst)
  
  Shawn M Moore (Sartak)
  
  Stevan Little
  
  Hans Dieter Pearcey (confound)
  
  mala
  
  Mark Stosberg
  
  Aaron Trevena
  
  =head1 SEE ALSO
  
  The L<PSGI> specification upon which Plack is based.
  
  L<http://plackperl.org/>
  
  The Plack wiki: L<https://github.com/plack/Plack/wiki>
  
  The Plack FAQ: L<https://github.com/plack/Plack/wiki/Faq>
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK

$fatpacked{"Plack/App/CGIBin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_CGIBIN';
  package Plack::App::CGIBin;
  use strict;
  use warnings;
  use parent qw/Plack::App::File/;
  use Plack::Util::Accessor qw( exec_cb );
  use Plack::App::WrapCGI;
  
  sub allow_path_info { 1 }
  
  my %exec_cache;
  
  sub would_exec {
      my($self, $file) = @_;
  
      return $exec_cache{$file} if exists $exec_cache{$file};
  
      my $exec_cb = $self->exec_cb || sub { $self->exec_cb_default(@_) };
  
      return $exec_cache{$file} = $exec_cb->($file);
  }
  
  sub exec_cb_default {
      my($self, $file) = @_;
  
      if ($file =~ /\.pl$/i) {
          return 0;
      } elsif ($self->shebang_for($file) =~ /^\#\!.*perl/) {
          return 0;
      } else {
          return 1;
      }
  }
  
  sub shebang_for {
      my($self, $file) = @_;
  
      open my $fh, "<", $file or return '';
      my $line = <$fh>;
      return $line;
  }
  
  sub serve_path {
      my($self, $env, $file) = @_;
  
      local @{$env}{qw(SCRIPT_NAME PATH_INFO)} = @{$env}{qw( plack.file.SCRIPT_NAME plack.file.PATH_INFO )};
  
      my $app = $self->{_compiled}->{$file} ||= Plack::App::WrapCGI->new(
          script => $file, execute => $self->would_exec($file),
      )->to_app;
      $app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::CGIBin - cgi-bin replacement for Plack servers
  
  =head1 SYNOPSIS
  
    use Plack::App::CGIBin;
    use Plack::Builder;
  
    my $app = Plack::App::CGIBin->new(root => "/path/to/cgi-bin")->to_app;
    builder {
        mount "/cgi-bin" => $app;
    };
  
    # Or from the command line
    plackup -MPlack::App::CGIBin -e 'Plack::App::CGIBin->new(root => "/path/to/cgi-bin")->to_app'
  
  =head1 DESCRIPTION
  
  Plack::App::CGIBin allows you to load CGI scripts from a directory and
  convert them into a PSGI application.
  
  This would give you the extreme easiness when you have bunch of old
  CGI scripts that is loaded using I<cgi-bin> of Apache web server.
  
  =head1 HOW IT WORKS
  
  This application checks if a given file path is a perl script and if
  so, uses L<CGI::Compile> to compile a CGI script into a sub (like
  L<ModPerl::Registry>) and then run it as a persistent application
  using L<CGI::Emulate::PSGI>.
  
  If the given file is not a perl script, it executes the script just
  like a normal CGI script with fork & exec. This is like a normal web
  server mode and no performance benefit is achieved.
  
  The default mechanism to determine if a given file is a Perl script is
  as follows:
  
  =over 4
  
  =item *
  
  Check if the filename ends with C<.pl>. If yes, it is a Perl script.
  
  =item *
  
  Open the file and see if the shebang (first line of the file) contains
  the word C<perl> (like C<#!/usr/bin/perl>). If yes, it is a Perl
  script.
  
  =back
  
  You can customize this behavior by passing C<exec_cb> callback, which
  takes a file path to its first argument.
  
  For example, if your perl-based CGI script uses lots of global
  variables and such and are not ready to run on a persistent
  environment, you can do:
  
    my $app = Plack::App::CGIBin->new(
        root => "/path/to/cgi-bin",
        exec_cb => sub { 1 },
    )->to_app;
  
  to always force the execute option for any files.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::App::File> L<CGI::Emulate::PSGI> L<CGI::Compile> L<Plack::App::WrapCGI>
  
  See also L<Plack::App::WrapCGI> if you compile one CGI script into a
  PSGI application without serving CGI scripts from a directory, to
  remove overhead of filesystem lookups, etc.
  
  =cut
PLACK_APP_CGIBIN

$fatpacked{"Plack/App/Cascade.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_CASCADE';
  package Plack::App::Cascade;
  use strict;
  use base qw(Plack::Component);
  
  use Plack::Util;
  use Plack::Util::Accessor qw(apps catch codes);
  
  sub add {
      my $self = shift;
      $self->apps([]) unless $self->apps;
      push @{$self->apps}, @_;
  }
  
  sub prepare_app {
      my $self = shift;
      my %codes = map { $_ => 1 } @{ $self->catch || [ 404 ] };
      $self->codes(\%codes);
  }
  
  sub call {
      my($self, $env) = @_;
  
      return sub {
          my $respond = shift;
  
          my $done;
          my $respond_wrapper = sub {
              my $res = shift;
              if ($self->codes->{$res->[0]}) {
                  # suppress output by giving the app an
                  # output spool which drops everything on the floor
                  return Plack::Util::inline_object
                      write => sub { }, close => sub { };
              } else {
                  $done = 1;
                  return $respond->($res);
              }
          };
  
          my @try = @{$self->apps || []};
          my $tries_left = 0 + @try;
  
          if (not $tries_left) {
              return $respond->([ 404, [ 'Content-Type' => 'text/html' ], [ '404 Not Found' ] ])
          }
  
          for my $app (@try) {
              my $res = $app->($env);
              if ($tries_left-- == 1) {
                  $respond_wrapper = sub { $respond->(shift) };
              }
  
              if (ref $res eq 'CODE') {
                  $res->($respond_wrapper);
              } else {
                  $respond_wrapper->($res);
              }
              return if $done;
          }
      };
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Cascade - Cascadable compound application
  
  =head1 SYNOPSIS
  
    use Plack::App::Cascade;
    use Plack::App::URLMap;
    use Plack::App::File;
  
    # Serve static files from multiple search paths
    my $cascade = Plack::App::Cascade->new;
    $cascade->add( Plack::App::File->new(root => "/www/example.com/foo")->to_app );
    $cascade->add( Plack::App::File->new(root => "/www/example.com/bar")->to_app );
  
    my $app = Plack::App::URLMap->new;
    $app->map("/static", $cascade);
    $app->to_app;
  
  =head1 DESCRIPTION
  
  Plack::App::Cascade is a Plack middleware component that compounds
  several apps and tries them to return the first response that is not
  404.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
    $app = Plack::App::Cascade->new(apps => [ $app1, $app2 ]);
  
  Creates a new Cascade application.
  
  =item add
  
    $app->add($app1);
    $app->add($app2, $app3);
  
  Appends a new application to the list of apps to try. You can pass the
  multiple apps to the one C<add> call.
  
  =item catch
  
    $app->catch([ 403, 404 ]);
  
  Sets which error codes to catch and process onwards. Defaults to C<404>.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::App::URLMap> Rack::Cascade
  
  =cut
PLACK_APP_CASCADE

$fatpacked{"Plack/App/Directory.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_DIRECTORY';
  package Plack::App::Directory;
  use parent qw(Plack::App::File);
  use strict;
  use warnings;
  use Plack::Util;
  use HTTP::Date;
  use Plack::MIME;
  use DirHandle;
  use URI::Escape;
  use Plack::Request;
  
  # Stolen from rack/directory.rb
  my $dir_file = "<tr><td class='name'><a href='%s'>%s</a></td><td class='size'>%s</td><td class='type'>%s</td><td class='mtime'>%s</td></tr>";
  my $dir_page = <<PAGE;
  <html><head>
    <title>%s</title>
    <meta http-equiv="content-type" content="text/html; charset=utf-8" />
    <style type='text/css'>
  table { width:100%%; }
  .name { text-align:left; }
  .size, .mtime { text-align:right; }
  .type { width:11em; }
  .mtime { width:15em; }
    </style>
  </head><body>
  <h1>%s</h1>
  <hr />
  <table>
    <tr>
      <th class='name'>Name</th>
      <th class='size'>Size</th>
      <th class='type'>Type</th>
      <th class='mtime'>Last Modified</th>
    </tr>
  %s
  </table>
  <hr />
  </body></html>
  PAGE
  
  sub should_handle {
      my($self, $file) = @_;
      return -d $file || -f $file;
  }
  
  sub return_dir_redirect {
      my ($self, $env) = @_;
      my $uri = Plack::Request->new($env)->uri;
      return [ 301,
          [
              'Location' => $uri . '/',
              'Content-Type' => 'text/plain',
              'Content-Length' => 8,
          ],
          [ 'Redirect' ],
      ];
  }
  
  sub serve_path {
      my($self, $env, $dir, $fullpath) = @_;
  
      if (-f $dir) {
          return $self->SUPER::serve_path($env, $dir, $fullpath);
      }
  
      my $dir_url = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
  
      if ($dir_url !~ m{/$}) {
          return $self->return_dir_redirect($env);
      }
  
      my @files = ([ "../", "Parent Directory", '', '', '' ]);
  
      my $dh = DirHandle->new($dir);
      my @children;
      while (defined(my $ent = $dh->read)) {
          next if $ent eq '.' or $ent eq '..';
          push @children, $ent;
      }
  
      for my $basename (sort { $a cmp $b } @children) {
          my $file = "$dir/$basename";
          my $url = $dir_url . $basename;
  
          my $is_dir = -d $file;
          my @stat = stat _;
  
          $url = join '/', map {uri_escape($_)} split m{/}, $url;
  
          if ($is_dir) {
              $basename .= "/";
              $url      .= "/";
          }
  
          my $mime_type = $is_dir ? 'directory' : ( Plack::MIME->mime_type($file) || 'text/plain' );
          push @files, [ $url, $basename, $stat[7], $mime_type, HTTP::Date::time2str($stat[9]) ];
      }
  
      my $path  = Plack::Util::encode_html("Index of $env->{PATH_INFO}");
      my $files = join "\n", map {
          my $f = $_;
          sprintf $dir_file, map Plack::Util::encode_html($_), @$f;
      } @files;
      my $page  = sprintf $dir_page, $path, $path, $files;
  
      return [ 200, ['Content-Type' => 'text/html; charset=utf-8'], [ $page ] ];
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Directory - Serve static files from document root with directory index
  
  =head1 SYNOPSIS
  
    # app.psgi
    use Plack::App::Directory;
    my $app = Plack::App::Directory->new({ root => "/path/to/htdocs" })->to_app;
  
  =head1 DESCRIPTION
  
  This is a static file server PSGI application with directory index a la Apache's mod_autoindex.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item root
  
  Document root directory. Defaults to the current directory.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::App::File>
  
  =cut
PLACK_APP_DIRECTORY

$fatpacked{"Plack/App/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_FILE';
  package Plack::App::File;
  use strict;
  use warnings;
  use parent qw/Plack::Component/;
  use File::Spec::Unix;
  use Cwd ();
  use Plack::Util;
  use Plack::MIME;
  use HTTP::Date;
  
  use Plack::Util::Accessor qw( root file content_type encoding );
  
  sub should_handle {
      my($self, $file) = @_;
      return -f $file;
  }
  
  sub call {
      my $self = shift;
      my $env  = shift;
  
      my($file, $path_info) = $self->file || $self->locate_file($env);
      return $file if ref $file eq 'ARRAY';
  
      if ($path_info) {
          $env->{'plack.file.SCRIPT_NAME'} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
          $env->{'plack.file.SCRIPT_NAME'} =~ s/\Q$path_info\E$//;
          $env->{'plack.file.PATH_INFO'}   = $path_info;
      } else {
          $env->{'plack.file.SCRIPT_NAME'} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
          $env->{'plack.file.PATH_INFO'}   = '';
      }
  
      return $self->serve_path($env, $file);
  }
  
  sub locate_file {
      my($self, $env) = @_;
  
      my $path = $env->{PATH_INFO} || '';
  
      if ($path =~ /\0/) {
          return $self->return_400;
      }
  
      my $docroot = $self->root || ".";
      my @path = split /[\\\/]/, $path, -1; # -1 *MUST* be here to avoid security issues!
      if (@path) {
          shift @path if $path[0] eq '';
      } else {
          @path = ('.');
      }
  
      if (grep /^\.{2,}$/, @path) {
          return $self->return_403;
      }
  
      my($file, @path_info);
      while (@path) {
          my $try = File::Spec::Unix->catfile($docroot, @path);
          if ($self->should_handle($try)) {
              $file = $try;
              last;
          } elsif (!$self->allow_path_info) {
              last;
          }
          unshift @path_info, pop @path;
      }
  
      if (!$file) {
          return $self->return_404;
      }
  
      if (!-r $file) {
          return $self->return_403;
      }
  
      return $file, join("/", "", @path_info);
  }
  
  sub allow_path_info { 0 }
  
  sub serve_path {
      my($self, $env, $file) = @_;
  
      my $content_type = $self->content_type || Plack::MIME->mime_type($file)
                         || 'text/plain';
  
      if ("CODE" eq ref $content_type) {
  		$content_type = $content_type->($file);
      }
  
      if ($content_type =~ m!^text/!) {
          $content_type .= "; charset=" . ($self->encoding || "utf-8");
      }
  
      open my $fh, "<:raw", $file
          or return $self->return_403;
  
      my @stat = stat $file;
  
      Plack::Util::set_io_path($fh, Cwd::realpath($file));
  
      return [
          200,
          [
              'Content-Type'   => $content_type,
              'Content-Length' => $stat[7],
              'Last-Modified'  => HTTP::Date::time2str( $stat[9] )
          ],
          $fh,
      ];
  }
  
  sub return_403 {
      my $self = shift;
      return [403, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['forbidden']];
  }
  
  sub return_400 {
      my $self = shift;
      return [400, ['Content-Type' => 'text/plain', 'Content-Length' => 11], ['Bad Request']];
  }
  
  # Hint: subclasses can override this to return undef to pass through 404
  sub return_404 {
      my $self = shift;
      return [404, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['not found']];
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::App::File - Serve static files from root directory
  
  =head1 SYNOPSIS
  
    use Plack::App::File;
    my $app = Plack::App::File->new(root => "/path/to/htdocs")->to_app;
  
    # Or map the path to a specific file
    use Plack::Builder;
    builder {
        mount "/favicon.ico" => Plack::App::File->new(file => '/path/to/favicon.ico')->to_app;
    };
  
  =head1 DESCRIPTION
  
  This is a static file server PSGI application, and internally used by
  L<Plack::Middleware::Static>. This application serves file from
  document root if the path matches with the local file. Use
  L<Plack::App::Directory> if you want to list files in the directory
  as well.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item root
  
  Document root directory. Defaults to C<.> (current directory)
  
  =item file
  
  The file path to create responses from. Optional.
  
  If it's set the application would B<ALWAYS> create a response out of
  the file and there will be no security check etc. (hence fast). If
  it's not set, the application uses C<root> to find the matching file.
  
  =item encoding
  
  Set the file encoding for text files. Defaults to C<utf-8>.
  
  =item content_type
  
  Set the file content type. If not set L<Plack::MIME> will try to detect it
  based on the file extension or fall back to C<text/plain>.
  Can be set to a callback which should work on $_[0] to check full path file 
  name.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Middleware::Static> L<Plack::App::Directory>
  
  =cut
  
  
PLACK_APP_FILE

$fatpacked{"Plack/App/PSGIBin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PSGIBIN';
  package Plack::App::PSGIBin;
  use strict;
  use warnings;
  use parent qw/Plack::App::File/;
  use Plack::Util;
  
  sub allow_path_info { 1 }
  
  sub serve_path {
      my($self, $env, $file) = @_;
  
      local @{$env}{qw(SCRIPT_NAME PATH_INFO)} = @{$env}{qw( plack.file.SCRIPT_NAME plack.file.PATH_INFO )};
  
      my $app = $self->{_compiled}->{$file} ||= Plack::Util::load_psgi($file);
      $app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::PSGIBin - Run .psgi files from a directory
  
  =head1 SYNOPSIS
  
    use Plack::App::PSGIBin;
    use Plack::Builder;
  
    my $app = Plack::App::PSGIBin->new(root => "/path/to/psgi/scripts")->to_app;
    builder {
        mount "/psgi" => $app;
    };
  
    # Or from the command line
    plackup -MPlack::App::PSGIBin -e 'Plack::App::PSGIBin->new(root => "/path/psgi/scripts")->to_app'
  
  =head1 DESCRIPTION
  
  This application loads I<.psgi> files (or actually whichever filename
  extensions) from the root directory and run it as a PSGI
  application. Suppose you have a directory containing C<foo.psgi> and
  C<bar.psgi>, map this application to C</app> with
  L<Plack::App::URLMap> and you can access them via the URL:
  
    http://example.com/app/foo.psgi
    http://example.com/app/bar.psgi
  
  to load them. You can rename the file to the one without C<.psgi>
  extension to make the URL look nicer, or use the URL rewriting tools
  like L<Plack::Middleware::Rewrite> to do the same thing.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::App::CGIBin>
PLACK_APP_PSGIBIN

$fatpacked{"Plack/App/Proxy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY';
  package Plack::App::Proxy;
  
  use strict;
  use 5.008_001;
  use parent 'Plack::Component';
  use Plack::Util::Accessor qw/remote preserve_host_header backend options/;
  use Plack::Request;
  use Plack::Util;
  use HTTP::Headers;
  
  our $VERSION = '0.29';
  
  sub prepare_app {
      my $self = shift;
      $self->backend($ENV{PLACK_PROXY_BACKEND} || 'AnyEvent::HTTP') unless defined $self->backend;
  }
  
  # hop-by-hop headers (see also RFC2616)
  my @hop_by_hop = qw(
      Connection Keep-Alive Proxy-Authenticate Proxy-Authorization
      TE Trailer Transfer-Encoding Upgrade
  );
  
  sub filter_headers {
      my $self = shift;
      my ( $headers ) = @_;
  
      # Save from known hop-by-hop deletion.
      my @connection_tokens = $headers->header('Connection');
  
      # Remove hop-by-hop headers.
      $headers->remove_header( $_ ) for @hop_by_hop;
  
      # Connection header's tokens are also hop-by-hop.
      for my $token ( @connection_tokens ){
          $headers->remove_header( $_ ) for split /\s*,\s*/, $token;
      }
  }
  
  sub build_url_from_env {
      my($self, $env) = @_;
  
      return $env->{'plack.proxy.url'}
          if exists $env->{'plack.proxy.url'};
  
      my $url = $env->{'plack.proxy.remote'} || $self->remote
          or return;
  
      # avoid double slashes
      $url =~ s!/$!! unless $env->{SCRIPT_NAME} && $env->{SCRIPT_NAME} =~ m!/$!;
  
      $url .= $env->{PATH_INFO} || '';
      $url .= '?' . $env->{QUERY_STRING} if defined $env->{QUERY_STRING} && length $env->{QUERY_STRING} > 0;
  
      return $url;
  }
  
  sub build_headers_from_env {
      my($self, $env, $req) = @_;
  
      my $headers = $req->headers->clone;
      $headers->header("X-Forwarded-For" => $env->{REMOTE_ADDR});
      $headers->remove_header("Host") unless $self->preserve_host_header;
      $self->filter_headers( $headers );
  
      +{ map {$_ => scalar $headers->header($_) } $headers->header_field_names };
  }
  
  sub call {
      my ($self, $env) = @_;
  
      unless ($env->{'psgi.streaming'}) {
          die "Plack::App::Proxy only runs with the server with psgi.streaming support";
      }
  
      my $url = $self->build_url_from_env($env)
          or return [502, ["Content-Type","text/html"], ["Can't determine proxy remote URL"]];
  
      my $req = Plack::Request->new($env);
      my $headers = $self->build_headers_from_env($env, $req);
  
      my $method  = $env->{REQUEST_METHOD};
      my $content = $req->content;
  
      my $backend_class = Plack::Util::load_class(
          $self->backend, 'Plack::App::Proxy::Backend'
      );
  
      return $backend_class->new(
          url              => $url,
          req              => $req,
          headers          => $headers,
          method           => $method,
          content          => $content,
          options          => $self->options,
          response_headers => sub { $self->response_headers(@_) },
      )->call($env);
  }
  
  sub response_headers {
      my ($self, $headers) = @_;
  
      $self->filter_headers( $headers );
  
      # Remove PSGI forbidden headers
      $headers->remove_header('Status');
  
      my @headers;
      $headers->scan( sub { push @headers, @_ } );
  
      return @headers;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Proxy - proxy requests
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    # proxy all requests for /static to 127.0.0.1:80
    builder {
        mount "/static" => Plack::App::Proxy->new(remote => "http://127.0.0.1:80")->to_app;
    };
  
    # Call from other app
    my $proxy = Plack::App::Proxy->new->to_app;
    my $app = sub {
        my $env = shift;
        ...
        $env->{'plack.proxy.url'} = $url;
        $proxy->($env);
    };
  
  =head1 DESCRIPTION
  
  Plack::App::Proxy is a middleware-aware proxy application for Plack.
  
  =head1 OPTIONS
  
  =over 4
  
  =item remote
  
    Plack::App::Proxy->new(remote => 'http://perl.org')->to_app;
  
  Specifies the base remote URL to proxy requests to.
  
    builder {
        mount "/example",
            Plack::App::Proxy->new(remote => 'http://example.com/app/foo')->to_app;
    };
  
  This proxies incoming requests for C</example/bar> proxied to
  C<http://example.com/app/foo/bar>.
  
  =item preserve_host_header
  
  Preserves the original Host header, which is useful when you do
  reverse proxying to the internal hosts.
  
  =item backend
  
  The HTTP backend to use. This dist comes with C<LWP> and C<AnyEvent::HTTP>
  backends. C<AnyEvent::HTTP> is the default if no backend is specified.
  
  =item options
  
  The options for the HTTP backend instance.
  
  =back
  
  =head1 MIDDLEWARE CONFIGURATIONS
  
  This application is just like a normal PSGI application and is
  middleware aware, which means you can modify proxy requests (and
  responses) using Plack middleware stack.
  
  It also supports the following special environment variables:
  
  =over 4
  
  =item plack.proxy.url
  
  Overrides the proxy request URL.
  
  =item plack.proxy.remote
  
  Overrides the base URL path to proxy to.
  
  =back
  
  For example, the following builder code allows you to proxy all GET
  requests for .png paths to the lolcat image (yes, a silly example) but
  proxies to the internal host otherwise.
  
    my $mw = sub {
        my $app = shift;
        sub {
            my $env = shift;
            if ($env->{REQUEST_METHOD} eq 'GET' && $env->{PATH_INFO} =~ /\.png$/) {
                $env->{'plack.proxy.url'} = 'http://lolcat.example.com/lol.png';
            }
            $app->($env);
        };
    };
  
    use Plack::Builder;
  
    builder {
        enable $mw;
        Plack::App::Proxy->new(remote => 'http://10.0.0.1:8080')->to_app;
    };
  
  =head1 AUTHOR
  
  Lee Aylward
  
  Masahiro Honma
  
  Tatsuhiko Miyagawa
  
  Jesse Luehrs
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<Plack::Builder>
  
  =cut
PLACK_APP_PROXY

$fatpacked{"Plack/App/Proxy/Backend.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY_BACKEND';
  package Plack::App::Proxy::Backend;
  
  use strict;
  use parent 'Plack::Component';
  use Plack::Util::Accessor qw/url req headers method content response_headers options/;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Proxy::Backend - pluggable backend for making the actual HTTP request
  
  =head1 SYNOPSIS
  
    package Plack::App::Proxy::Backend::foo;
    use parent 'Plack::App::Proxy::Backend';
    sub call {
        my $self = shift;
        my ($env) = @_;
        # ...
    }
  
  =head1 DESCRIPTION
  
  This is a base class for HTTP backends for L<Plack::App::Proxy>.
  
  =head1 AUTHOR
  
  Lee Aylward
  
  Masahiro Honma
  
  Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK_APP_PROXY_BACKEND

$fatpacked{"Plack/App/Proxy/Backend/AnyEvent/HTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY_BACKEND_ANYEVENT_HTTP';
  package Plack::App::Proxy::Backend::AnyEvent::HTTP;
  
  use strict;
  use parent 'Plack::App::Proxy::Backend';
  use AnyEvent::HTTP;
  
  sub call {
      my $self = shift;
      my ($env) = @_;
  
      return sub {
          my $respond = shift;
          my $cv = AE::cv;
          my $writer;
          AnyEvent::HTTP::http_request(
              $self->method => $self->url,
              headers => $self->headers,
              body => $self->content,
              recurse => 0,  # want not to treat any redirections
              persistent => 0,
              %{ $self->options || {} },
              on_header => sub {
                  my $headers = shift;
  
                  if ($headers->{Status} !~ /^59\d+/) {
                      $env->{'plack.proxy.last_protocol'} = $headers->{HTTPVersion};
                      $env->{'plack.proxy.last_status'}   = $headers->{Status};
                      $env->{'plack.proxy.last_reason'}   = $headers->{Reason};
                      $env->{'plack.proxy.last_url'}      = $headers->{URL};
  
                      my $http_headers = HTTP::Headers->new(
                        map { $_ => $headers->{$_} } grep {! /^[A-Z]/} keys %$headers
                      );
  
                      my $cookies = $http_headers->header( 'Set-Cookie' );
                      if ( $cookies ) {
                          my @cookies = split /,(?=\S+)/, $cookies;
                          $http_headers->header( Set_Cookie => \@cookies );
                      }
  
                      $writer = $respond->([
                          $headers->{Status},
                          [$self->response_headers->($http_headers)],
                      ]);
                  }
                  return 1;
              },
              on_body => sub {
                $writer->write($_[0]);
                return 1;
              },
              sub {
                  my (undef, $headers) = @_;
  
                  if (!$writer and $headers->{Status} =~ /^59\d/) {
                      $respond->([502, ["Content-Type","text/html"], ["Gateway error: $headers->{Reason}"]]);
                  }
  
                  $writer->close if $writer;
                  $cv->send;
  
                  # http_request may not release $cb with perl 5.8.8
                  # and AE::HTTP 1.44. So free $env manually.
                  undef $env;
  
                  # Free the reference manually for perl 5.8.x
                  # to avoid nested closure memory leaks.
                  undef $respond;
              }
          );
          $cv->recv unless $env->{"psgi.nonblocking"};
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Proxy::Backend::AnyEvent::HTTP - backend which uses AnyEvent::HTTP
  
  =head1 SYNOPSIS
  
    my $app = Plack::App::Proxy->new(backend => 'AnyEvent::HTTP')->to_app;
  
  =head1 DESCRIPTION
  
  This backend uses L<AnyEvent::HTTP> to make HTTP requests. This is the default
  backend used when no backend is specified in the constructor.
  
  =head1 AUTHOR
  
  Lee Aylward
  
  Masahiro Honma
  
  Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK_APP_PROXY_BACKEND_ANYEVENT_HTTP

$fatpacked{"Plack/App/Proxy/Backend/HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY_BACKEND_HTTP_TINY';
  package Plack::App::Proxy::Backend::HTTP::Tiny;
  
  =head1 NAME
  
  Plack::App::Proxy::HTTP::Tiny - backend for Plack::App::Proxy
  
  =head1 SYNOPSIS
  
    # In app.psgi
    use Plack::Builder;
    use Plack::App::Proxy::Anonymous;
  
    builder {
        enable "Proxy::Requests";
        Plack::App::Proxy->new(backend => 'HTTP::Tiny')->to_app;
    };
  
  =head1 DESCRIPTION
  
  This backend uses L<HTTP::Tiny> to make HTTP requests.
  
  L<HTTP::Tiny> backend is Pure-Perl only and doesn't require any
  architecture specific files.
  
  It is possible to bundle it e.g. by L<App::FatPacker>.
  
  =for readme stop
  
  =cut
  
  
  use 5.006;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0100';
  
  
  use parent qw(Plack::App::Proxy::Backend);
  
  use HTTP::Headers;
  
  
  sub call {
      my ($self, $env) = @_;
  
      return sub {
          my ($respond) = @_;
  
          my $ua = Plack::App::Proxy::Backend::HTTP::Tiny::PreserveHeaders->new(
              max_redirect => 0,
              %{ $self->options || {} }
          );
  
          my $writer;
  
          my $res = $ua->request(
              $self->method => $self->url, {
                  headers => $self->headers,
                  content => $self->content,
                  data_callback => sub {
                      my ($data, $res) = @_;
  
                      return if $res->{status} =~ /^59\d+/;
  
                      if (not $writer) {
                          $env->{'plack.proxy.last_protocol'} = '1.1'; # meh
                          $env->{'plack.proxy.last_status'}   = $res->{status};
                          $env->{'plack.proxy.last_reason'}   = $res->{reason};
                          $env->{'plack.proxy.last_url'}      = $self->url;
  
                          $writer = $respond->([
                              $res->{status},
                              [$self->response_headers->(HTTP::Headers->new(%{$res->{headers}}))],
                          ]);
                      }
  
                      $writer->write($data);
                  },
              }
          );
  
          if ($writer) {
              $writer->close;
              return;
          }
  
          if ($res->{status} =~ /^59\d/) {
              return $respond->([502, ['Content-Type' => 'text/html'], ["Gateway error: $res->{content}"]]);
          }
  
          return $respond->([
              $res->{status},
              [$self->response_headers->(HTTP::Headers->new(%{$res->{headers}}))],
              [$res->{content}],
          ]);
      };
  }
  
  
  package Plack::App::Proxy::Backend::HTTP::Tiny::PreserveHeaders;
  
  use parent 'HTTP::Tiny';
  
  # Preserve Host and User-Agent headers
  sub _prepare_headers_and_cb {
      my ($self, $request, $args, $url, $auth) = @_;
  
      my ($host, $user_agent);
  
      while (my ($k, $v) = each %{$args->{headers}}) {
          $host = $v if lc $k eq 'host';
          $user_agent = $v if lc $k eq 'user-agent';
      }
  
      $self->SUPER::_prepare_headers_and_cb($request, $args, $url, $auth);
  
      $request->{headers}{'host'} = $host if $host;
      delete $request->{headers}{'user-agent'} if not defined $user_agent;
  
      return;
  }
  
  
  1;
  
  
  =for readme continue
  
  =head1 SEE ALSO
  
  L<Plack>, L<Plack::App::Proxy>, L<Plack::Middleware::Proxy::Requests>,
  L<HTTP::Tiny>.
  
  =head1 BUGS
  
  This module might be incompatible with further versions of
  L<Plack::App::Proxy> module.
  
  If you find the bug or want to implement new features, please report it at
  L<https://github.com/dex4er/perl-Plack-App-Proxy-Backend-HTTP-Tiny/issues>
  
  The code repository is available at
  L<http://github.com/dex4er/perl-Plack-App-Proxy-Backend-HTTP-Tiny>
  
  =head1 AUTHOR
  
  Piotr Roszatycki <dexter@cpan.org>
  
  =head1 LICENSE
  
  Copyright (c) 2014 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
PLACK_APP_PROXY_BACKEND_HTTP_TINY

$fatpacked{"Plack/App/Proxy/Backend/LWP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY_BACKEND_LWP';
  package Plack::App::Proxy::Backend::LWP;
  
  use strict;
  use parent 'Plack::App::Proxy::Backend';
  use LWP::UserAgent;
  
  sub call {
      my $self = shift;
      my ($env) = @_;
  
      return sub {
          my $respond = shift;
  
          my $req = HTTP::Request->new(
              $self->method => $self->url,
              HTTP::Headers->new(%{ $self->headers }),
              $self->content
          );
  
          my $ua = LWP::UserAgent->new(%{ $self->options || {} });
          my $writer;
  
          $ua->add_handler(
              response_header => sub {
                  my ($res) = @_;
  
                  $env->{'plack.proxy.last_protocol'} = '1.1'; # meh
                  $env->{'plack.proxy.last_status'}   = $res->code;
                  $env->{'plack.proxy.last_reason'}   = $res->message;
                  $env->{'plack.proxy.last_url'}      = $self->url;
  
                  $writer = $respond->([
                      $res->code,
                      [$self->response_headers->($res->headers)],
                  ]);
              },
          );
          $ua->add_handler(
              response_data => sub {
                  my (undef, undef, undef, $data) = @_;
                  $writer->write($data);
                  return 1;
              },
          );
          $ua->add_handler(
              response_done => sub {
                  $writer->close if $writer;
              },
          );
  
          my $res = $ua->simple_request($req);
          return if $writer;
          $respond->([
              $res->code,
              [$self->response_headers->($res->headers)],
              [$res->content],
          ]);
      };
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Proxy::Backend::LWP - backend which uses LWP::UserAgent
  
  =head1 SYNOPSIS
  
    my $app = Plack::App::Proxy->new(backend => 'LWP')->to_app;
  
  =head1 DESCRIPTION
  
  This backend uses L<LWP::UserAgent> to make HTTP requests.
  
  =head1 AUTHOR
  
  Lee Aylward
  
  Masahiro Honma
  
  Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK_APP_PROXY_BACKEND_LWP

$fatpacked{"Plack/App/Proxy/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_PROXY_TEST';
  package Plack::App::Proxy::Test;
  use strict;
  use warnings;
  use Carp;
  use Plack::Loader;
  use Plack::Test;
  use Test::More;
  use Test::TCP;
  use LWP::UserAgent;
  use base Exporter::;
  our @EXPORT = qw(test_proxy);
  
  BEGIN {
    # disable HTTP proxy when testing since we are connecting to localhost
    delete $ENV{http_proxy};
  }
  
  our @BACKENDS = qw/LWP AnyEvent::HTTP/;
  
  sub test_proxy {
      my %args = @_;
  
      local $Plack::Test::Impl = 'Server';
  
      my $client = delete $args{client} or croak "client test code needed";
      my $app    = delete $args{app}    or croak "app needed";
      my $proxy  = delete $args{proxy}  or croak "proxy needed";
      my $host   = delete $args{host} || '127.0.0.1';
  
      for my $backend (@BACKENDS) {
  
          local $ENV{PLACK_PROXY_BACKEND} = $backend;
  
          test_tcp(
              client => sub {
                  my $port = shift;
                  test_psgi(
                      app => $proxy->( $host, $port ),
                      client => $client,
                      host => $host,
                      # disable the auto redirection of LWP::UA
                      ua => LWP::UserAgent->new( max_redirect => 0 ),
                  );
              },
              server => sub {
                  my $port = shift;
  
                  # Use an ordinary server.
                  local $ENV{PLACK_SERVER} = 'Standalone';
  
                  my $server = Plack::Loader->auto(port => $port, host => $host);
                  $server->run($app);
              },
          );
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::Proxy::Test - Is utilities to test Plack::App::Proxy.
  
  =head1 SYNOPSIS
  
    test_proxy(
        app   => $backend_app,
        proxy => sub { Plack::App::Proxy->new(remote => "http://$_[0]:$_[1]") },
        client => sub {
            my $cb = shift;
            my $res = $cb->(GET '/');
            ok $res->is_success, "Check the status line.";
        },
    );
  
  =head1 DESCRIPTION
  
  Plack::App::Proxy::Test provids test_proxy function which wraps 
  test_psgi of Plack::Test simply. 
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item test_proxy
  
    test_proxy app    => $app, 
               proxy  => $proxy_cb->($app_host, $app_port), 
               client => $client_cb->($cb);
  
  =back
  
  test_proxy runs two servers, 'C<app>' as an origin server and the proxy server.
  In 'C<proxy>' callback, you should create the proxy server instance to send 
  requests to 'C<app>' server. Then 'C<client>' callback is called to run your 
  tests. In 'C<client>' callback, all HTTP requests are sent to 'C<proxy>' 
  server. (And the proxy server will proxy your request to the app server.)
  
  =head1 AUTHOR
  
  Masahiro Honma E<lt>hiratara@cpan.orgE<gt>
  
  =cut
  
  =head1 SEE ALSO
  
  L<Plack::App::Proxy> L<Plack::Test>
  
  =cut
  
PLACK_APP_PROXY_TEST

$fatpacked{"Plack/App/URLMap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_URLMAP';
  package Plack::App::URLMap;
  use strict;
  use warnings;
  use parent qw(Plack::Component);
  use constant DEBUG => $ENV{PLACK_URLMAP_DEBUG};
  
  use Carp ();
  
  sub mount { shift->map(@_) }
  
  sub map {
      my $self = shift;
      my($location, $app) = @_;
  
      my $host;
      if ($location =~ m!^https?://(.*?)(/.*)!) {
          $host     = $1;
          $location = $2;
      }
  
      if ($location !~ m!^/!) {
          Carp::croak("Paths need to start with /");
      }
      $location =~ s!/$!!;
  
      push @{$self->{_mapping}}, [ $host, $location, qr/^\Q$location\E/, $app ];
  }
  
  sub prepare_app {
      my $self = shift;
      # sort by path length
      $self->{_sorted_mapping} = [
          map  { [ @{$_}[2..5] ] }
          sort { $b->[0] <=> $a->[0] || $b->[1] <=> $a->[1] }
          map  { [ ($_->[0] ? length $_->[0] : 0), length($_->[1]), @$_ ] } @{$self->{_mapping}},
      ];
  }
  
  sub call {
      my ($self, $env) = @_;
  
      my $path_info   = $env->{PATH_INFO};
      my $script_name = $env->{SCRIPT_NAME};
  
      my($http_host, $server_name) = @{$env}{qw( HTTP_HOST SERVER_NAME )};
  
      if ($http_host and my $port = $env->{SERVER_PORT}) {
          $http_host =~ s/:$port$//;
      }
  
      for my $map (@{ $self->{_sorted_mapping} }) {
          my($host, $location, $location_re, $app) = @$map;
          my $path = $path_info; # copy
          no warnings 'uninitialized';
          DEBUG && warn "Matching request (Host=$http_host Path=$path) and the map (Host=$host Path=$location)\n";
          next unless not defined $host     or
                      $http_host   eq $host or
                      $server_name eq $host;
          next unless $location eq '' or $path =~ s!$location_re!!;
          next unless $path eq '' or $path =~ m!^/!;
          DEBUG && warn "-> Matched!\n";
  
          my $orig_path_info   = $env->{PATH_INFO};
          my $orig_script_name = $env->{SCRIPT_NAME};
  
          $env->{PATH_INFO}  = $path;
          $env->{SCRIPT_NAME} = $script_name . $location;
          return $self->response_cb($app->($env), sub {
              $env->{PATH_INFO} = $orig_path_info;
              $env->{SCRIPT_NAME} = $orig_script_name;
          });
      }
  
      DEBUG && warn "All matching failed.\n";
  
      return [404, [ 'Content-Type' => 'text/plain' ], [ "Not Found" ]];
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::URLMap - Map multiple apps in different paths
  
  =head1 SYNOPSIS
  
    use Plack::App::URLMap;
  
    my $app1 = sub { ... };
    my $app2 = sub { ... };
    my $app3 = sub { ... };
  
    my $urlmap = Plack::App::URLMap->new;
    $urlmap->map("/" => $app1);
    $urlmap->map("/foo" => $app2);
    $urlmap->map("http://bar.example.com/" => $app3);
  
    my $app = $urlmap->to_app;
  
  =head1 DESCRIPTION
  
  Plack::App::URLMap is a PSGI application that can dispatch multiple
  applications based on URL path and host names (a.k.a "virtual hosting")
  and takes care of rewriting C<SCRIPT_NAME> and C<PATH_INFO> (See
  L</"HOW THIS WORKS"> for details). This module is inspired by
  Ruby's Rack::URLMap.
  
  =head1 METHODS
  
  =over 4
  
  =item map
  
    $urlmap->map("/foo" => $app);
    $urlmap->map("http://bar.example.com/" => $another_app);
  
  Maps URL path or an absolute URL to a PSGI application. The match
  order is sorted by host name length and then path length (longest strings
  first).
  
  URL paths need to match from the beginning and should match completely
  until the path separator (or the end of the path). For example, if you
  register the path C</foo>, it I<will> match with the request C</foo>,
  C</foo/> or C</foo/bar> but it I<won't> match with C</foox>.
  
  Mapping URLs with host names is also possible, and in that case the URL
  mapping works like a virtual host.
  
  Mappings will nest.  If $app is already mapped to C</baz> it will
  match a request for C</foo/baz> but not C</foo>. See L</"HOW THIS
  WORKS"> for more details.
  
  =item mount
  
  Alias for C<map>.
  
  =item to_app
  
    my $handler = $urlmap->to_app;
  
  Returns the PSGI application code reference. Note that the
  Plack::App::URLMap object is callable (by overloading the code
  dereference), so returning the object itself as a PSGI application
  should also work.
  
  =back
  
  =head1 PERFORMANCE
  
  If you C<map> (or C<mount> with Plack::Builder) N applications,
  Plack::App::URLMap will need to at most iterate through N paths to
  match incoming requests.
  
  It is a good idea to use C<map> only for a known, limited amount of
  applications, since mounting hundreds of applications could affect
  runtime request performance.
  
  =head1 DEBUGGING
  
  You can set the environment variable C<PLACK_URLMAP_DEBUG> to see how
  this application matches with the incoming request host names and
  paths.
  
  =head1 HOW THIS WORKS
  
  This application works by I<fixing> C<SCRIPT_NAME> and C<PATH_INFO>
  before dispatching the incoming request to the relocated
  applications.
  
  Say you have a Wiki application that takes C</index> and C</page/*>
  and makes a PSGI application C<$wiki_app> out of it, using one of
  supported web frameworks, you can put the whole application under
  C</wiki> by:
  
    # MyWikiApp looks at PATH_INFO and handles /index and /page/*
    my $wiki_app = sub { MyWikiApp->run(@_) };
    
    use Plack::App::URLMap;
    my $app = Plack::App::URLMap->new;
    $app->mount("/wiki" => $wiki_app);
  
  When a request comes in with C<PATH_INFO> set to C</wiki/page/foo>,
  the URLMap application C<$app> strips the C</wiki> part from
  C<PATH_INFO> and B<appends> that to C<SCRIPT_NAME>.
  
  That way, if the C<$app> is mounted under the root
  (i.e. C<SCRIPT_NAME> is C<"">) with standalone web servers like
  L<Starman>, C<SCRIPT_NAME> is now locally set to C</wiki> and
  C<PATH_INFO> is changed to C</page/foo> when C<$wiki_app> gets called.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Builder>
  
  =cut
PLACK_APP_URLMAP

$fatpacked{"Plack/App/WrapCGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_APP_WRAPCGI';
  package Plack::App::WrapCGI;
  use strict;
  use warnings;
  use parent qw(Plack::Component);
  use Plack::Util::Accessor qw(script execute _app);
  use File::Spec;
  use CGI::Emulate::PSGI;
  use CGI::Compile;
  use Carp;
  use POSIX ":sys_wait_h";
  
  sub slurp_fh {
      my $fh = $_[0];
      local $/;
      my $v = <$fh>;
      defined $v ? $v : '';
  }
  
  sub prepare_app {
      my $self = shift;
      my $script = $self->script
          or croak "'script' is not set";
  
      $script = File::Spec->rel2abs($script);
  
      if ($self->execute) {
          my $app = sub {
              my $env = shift;
  
              pipe( my $stdoutr, my $stdoutw );
              pipe( my $stdinr,  my $stdinw );
  
  
              my $pid = fork();
              Carp::croak("fork failed: $!") unless defined $pid;
  
  
              if ($pid == 0) { # child
                  local $SIG{__DIE__} = sub {
                      print STDERR @_;
                      exit(1);
                  };
  
                  close $stdoutr;
                  close $stdinw;
  
                  local %ENV = (%ENV, CGI::Emulate::PSGI->emulate_environment($env));
  
                  open( STDOUT, ">&=" . fileno($stdoutw) )
                    or Carp::croak "Cannot dup STDOUT: $!";
                  open( STDIN, "<&=" . fileno($stdinr) )
                    or Carp::croak "Cannot dup STDIN: $!";
  
                  chdir(File::Basename::dirname($script));
                  exec($script) or Carp::croak("cannot exec: $!");
  
                  exit(2);
              }
  
              close $stdoutw;
              close $stdinr;
  
              syswrite($stdinw, slurp_fh($env->{'psgi.input'}));
              # close STDIN so child will stop waiting
              close $stdinw;
  
              my $res = '';
              while (waitpid($pid, WNOHANG) <= 0) {
                  $res .= slurp_fh($stdoutr);
              }
              $res .= slurp_fh($stdoutr);
  
              if (POSIX::WIFEXITED($?)) {
                  return CGI::Parse::PSGI::parse_cgi_output(\$res);
              } else {
                  Carp::croak("Error at run_on_shell CGI: $!");
              }
          };
          $self->_app($app);
      } else {
          my $sub = CGI::Compile->compile($script);
          my $app = CGI::Emulate::PSGI->handler($sub);
  
          $self->_app($app);
      }
  }
  
  sub call {
      my($self, $env) = @_;
      $self->_app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::App::WrapCGI - Compiles a CGI script as PSGI application
  
  =head1 SYNOPSIS
  
    use Plack::App::WrapCGI;
  
    my $app = Plack::App::WrapCGI->new(script => "/path/to/script.pl")->to_app;
  
    # if you want to execute as a real CGI script
    my $app = Plack::App::WrapCGI->new(script => "/path/to/script.rb", execute => 1)->to_app;
  
  =head1 DESCRIPTION
  
  Plack::App::WrapCGI compiles a CGI script into a PSGI application
  using L<CGI::Compile> and L<CGI::Emulate::PSGI>, and runs it with any
  PSGI server as a PSGI application.
  
  See also L<Plack::App::CGIBin> if you have a directory that contains a
  lot of CGI scripts and serve them like Apache's mod_cgi.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
    my $app = Plack::App::WrapCGI->new(%args);
  
  Creates a new PSGI application using the given script. I<%args> has two
  parameters:
  
  =over 8
  
  =item script
  
  The path to a CGI-style program. This is a required parameter.
  
  =item execute
  
  An optional parameter. When set to a true value, this app will run the script
  with a CGI-style C<fork>/C<exec> model. Note that you may run programs written
  in other languages with this approach.
  
  =back
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::App::CGIBin>
  
  =cut
PLACK_APP_WRAPCGI

$fatpacked{"Plack/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_BUILDER';
  package Plack::Builder;
  use strict;
  use parent qw( Exporter );
  our @EXPORT = qw( builder add enable enable_if mount );
  
  use Carp ();
  use Plack::App::URLMap;
  use Plack::Middleware::Conditional; # TODO delayed load?
  use Scalar::Util ();
  
  sub new {
      my $class = shift;
      bless { middlewares => [ ] }, $class;
  }
  
  sub add_middleware {
      my($self, $mw, @args) = @_;
  
      if (ref $mw ne 'CODE') {
          my $mw_class = Plack::Util::load_class($mw, 'Plack::Middleware');
          $mw = sub { $mw_class->wrap($_[0], @args) };
      }
  
      push @{$self->{middlewares}}, $mw;
  }
  
  sub add_middleware_if {
      my($self, $cond, $mw, @args) = @_;
  
      if (ref $mw ne 'CODE') {
          my $mw_class = Plack::Util::load_class($mw, 'Plack::Middleware');
          $mw = sub { $mw_class->wrap($_[0], @args) };
      }
  
      push @{$self->{middlewares}}, sub {
          Plack::Middleware::Conditional->wrap($_[0], condition => $cond, builder => $mw);
      };
  }
  
  # do you want remove_middleware() etc.?
  
  sub _mount {
      my ($self, $location, $app) = @_;
  
      if (!$self->{_urlmap}) {
          $self->{_urlmap} = Plack::App::URLMap->new;
      }
  
      $self->{_urlmap}->map($location => $app);
      $self->{_urlmap}; # for backward compat.
  }
  
  sub to_app {
      my($self, $app) = @_;
  
      if ($app) {
          $self->wrap($app);
      } elsif ($self->{_urlmap}) {
          $self->{_urlmap} = $self->{_urlmap}->to_app
              if Scalar::Util::blessed($self->{_urlmap});
          $self->wrap($self->{_urlmap});
      } else {
          Carp::croak("to_app() is called without mount(). No application to build.");
      }
  }
  
  sub wrap {
      my($self, $app) = @_;
  
      if ($self->{_urlmap} && $app ne $self->{_urlmap}) {
          Carp::carp("WARNING: wrap() and mount() can't be used altogether in Plack::Builder.\n" .
                     "WARNING: This causes all previous mount() mappings to be ignored.");
      }
  
      for my $mw (reverse @{$self->{middlewares}}) {
          $app = $mw->($app);
      }
  
      $app;
  }
  
  # DSL goes here
  our $_add = our $_add_if = our $_mount = sub {
      Carp::croak("enable/mount should be called inside builder {} block");
  };
  
  sub enable         { $_add->(@_) }
  sub enable_if(&$@) { $_add_if->(@_) }
  
  sub mount {
      my $self = shift;
      if (Scalar::Util::blessed($self)) {
          $self->_mount(@_);
      }else{
          $_mount->($self, @_);
      }
  }
  
  sub builder(&) {
      my $block = shift;
  
      my $self = __PACKAGE__->new;
  
      my $mount_is_called;
      my $urlmap = Plack::App::URLMap->new;
      local $_mount = sub {
          $mount_is_called++;
          $urlmap->map(@_);
          $urlmap;
      };
      local $_add = sub {
          $self->add_middleware(@_);
      };
      local $_add_if = sub {
          $self->add_middleware_if(@_);
      };
  
      my $app = $block->();
  
      if ($mount_is_called) {
          if ($app ne $urlmap) {
              Carp::carp("WARNING: You used mount() in a builder block, but the last line (app) isn't using mount().\n" .
                         "WARNING: This causes all mount() mappings to be ignored.\n");
          } else {
              $app = $app->to_app;
          }
      }
  
      $app = $app->to_app if $app and Scalar::Util::blessed($app) and $app->can('to_app');
  
      $self->to_app($app);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Builder - OO and DSL to enable Plack Middlewares
  
  =head1 SYNOPSIS
  
    # in .psgi
    use Plack::Builder;
  
    my $app = sub { ... };
  
    builder {
        enable "Deflater";
        enable "Session", store => "File";
        enable "Debug", panels => [ qw(DBITrace Memory Timer) ];
        enable "+My::Plack::Middleware";
        $app;
    };
  
    # use URLMap
  
    builder {
        mount "/foo" => builder {
            enable "Foo";
            $app;
        };
  
        mount "/bar" => $app2;
        mount "http://example.com/" => builder { $app3 };
    };
  
    # using OO interface
    my $builder = Plack::Builder->new;
    $builder->add_middleware('Foo', opt => 1);
    $builder->add_middleware('Bar');
    $builder->wrap($app);
  
  =head1 DESCRIPTION
  
  Plack::Builder gives you a quick domain specific language (DSL) to
  wrap your application with L<Plack::Middleware> subclasses. The
  middleware you're trying to use should use L<Plack::Middleware> as a
  base class to use this DSL, inspired by Rack::Builder.
  
  Whenever you call C<enable> on any middleware, the middleware app is
  pushed to the stack inside the builder, and then reversed when it
  actually creates a wrapped application handler. C<"Plack::Middleware::">
  is added as a prefix by default. So:
  
    builder {
        enable "Foo";
        enable "Bar", opt => "val";
        $app;
    };
  
  is syntactically equal to:
  
    $app = Plack::Middleware::Bar->wrap($app, opt => "val");
    $app = Plack::Middleware::Foo->wrap($app);
  
  In other words, you're supposed to C<enable> middleware from outer to inner.
  
  =head1 INLINE MIDDLEWARE
  
  Plack::Builder allows you to code middleware inline using a nested
  code reference.
  
  If the first argument to C<enable> is a code reference, it will be
  passed an C<$app> and should return another code reference
  which is a PSGI application that consumes C<$env> at runtime. So:
  
    builder {
        enable sub {
            my $app = shift;
            sub {
                my $env = shift;
                # do preprocessing
                my $res = $app->($env);
                # do postprocessing
                return $res;
            };
        };
        $app;
    };
  
  is equal to:
  
    my $mw = sub {
        my $app = shift;
        sub { my $env = shift; $app->($env) };
    };
  
    $app = $mw->($app);
  
  =head1 URLMap support
  
  Plack::Builder has a native support for L<Plack::App::URLMap> via the C<mount> method.
  
    use Plack::Builder;
    my $app = builder {
        mount "/foo" => $app1;
        mount "/bar" => builder {
            enable "Foo";
            $app2;
        };
    };
  
  See L<Plack::App::URLMap>'s C<map> method to see what they mean. With
  C<builder> you can't use C<map> as a DSL, for the obvious reason :)
  
  B<NOTE>: Once you use C<mount> in your builder code, you have to use
  C<mount> for all the paths, including the root path (C</>). You can't
  have the default app in the last line of C<builder> like:
  
    my $app = sub {
        my $env = shift;
        ...
    };
  
    builder {
        mount "/foo" => sub { ... };
        $app; # THIS DOESN'T WORK
    };
  
  You'll get warnings saying that your mount configuration will be
  ignored. Instead you should use C<< mount "/" => ... >> in the last
  line to set the default fallback app.
  
    builder {
        mount "/foo" => sub { ... };
        mount "/" => $app;
    }
  
  Note that the C<builder> DSL returns a whole new PSGI application, which means
  
  =over 4
  
  =item *
  
  C<builder { ... }> should normally the last statement of a C<.psgi>
  file, because the return value of C<builder> is the application that
  is actually executed.
  
  =item *
  
  You can nest your C<builder> blocks, mixed with C<mount> statements (see L</"URLMap support">
  above):
  
    builder {
        mount "/foo" => builder {
            mount "/bar" => $app;
        }
    }
  
  will locate the C<$app> under C</foo/bar>, since the inner C<builder>
  block puts it under C</bar> and it results in a new PSGI application
  which is located under C</foo> because of the outer C<builder> block.
  
  =back
  
  =head1 CONDITIONAL MIDDLEWARE SUPPORT
  
  You can use C<enable_if> to conditionally enable middleware based on
  the runtime environment.
  
    builder {
        enable_if { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' } 'StackTrace', force => 1;
        $app;
    };
  
  See L<Plack::Middleware::Conditional> for details.
  
  =head1 OBJECT ORIENTED INTERFACE
  
  Object oriented interface supports the same functionality with the DSL
  version in a clearer interface, probably with more typing required.
  
    # With mount
    my $builder = Plack::Builder->new;
    $builder->add_middleware('Foo', opt => 1);
    $builder->mount('/foo' => $foo_app);
    $builder->mount('/' => $root_app);
    $builder->to_app;
  
    # Nested builders. Equivalent to:
    # builder {
    #     mount '/foo' => builder {
    #         enable 'Foo';
    #         $app;
    #     };
    #     mount '/' => $app2;
    # };
    my $builder_out = Plack::Builder->new;
    my $builder_in  = Plack::Builder->new;
    $builder_in->add_middleware('Foo');
    $builder_out->mount("/foo" => $builder_in->wrap($app));
    $builder_out->mount("/" => $app2);
    $builder_out->to_app;
  
    # conditional. You can also directly use Plack::Middleware::Conditional
    my $builder = Plack::Builder->new;
    $builder->add_middleware_if(sub { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' }, 'StackTrace');
    $builder->wrap($app);
  
  =head1 SEE ALSO
  
  L<Plack::Middleware> L<Plack::App::URLMap> L<Plack::Middleware::Conditional>
  
  =cut
  
  
  
PLACK_BUILDER

$fatpacked{"Plack/Component.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_COMPONENT';
  package Plack::Component;
  use strict;
  use warnings;
  use Carp ();
  use Plack::Util;
  use overload '&{}' => \&to_app_auto, fallback => 1;
  
  sub new {
      my $proto = shift;
      my $class = ref $proto || $proto;
  
      my $self;
      if (@_ == 1 && ref $_[0] eq 'HASH') {
          $self = bless {%{$_[0]}}, $class;
      } else {
          $self = bless {@_}, $class;
      }
  
      $self;
  }
  
  sub to_app_auto {
      my $self = shift;
      if (($ENV{PLACK_ENV} || '') eq 'development') {
          my $class = ref($self);
          warn "WARNING: Automatically converting $class instance to a PSGI code reference. " .
            "If you see this warning for each request, you probably need to explicitly call " .
            "to_app() i.e. $class->new(...)->to_app in your PSGI file.\n";
      }
      $self->to_app(@_);
  }
  
  # NOTE:
  # this is for back-compat only,
  # future modules should use
  # Plack::Util::Accessor directly
  # or their own favorite accessor
  # generator.
  # - SL
  sub mk_accessors {
      my $self = shift;
      Plack::Util::Accessor::mk_accessors( ref( $self ) || $self, @_ )
  }
  
  sub prepare_app { return }
  
  sub to_app {
      my $self = shift;
      $self->prepare_app;
      return sub { $self->call(@_) };
  }
  
  
  sub response_cb {
      my($self, $res, $cb) = @_;
      Plack::Util::response_cb($res, $cb);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Component - Base class for PSGI endpoints
  
  =head1 SYNOPSIS
  
    package Plack::App::Foo;
    use parent qw( Plack::Component );
  
    sub call {
        my($self, $env) = @_;
        # Do something with $env
  
        my $res = ...; # create a response ...
  
        # return the response
        return $res;
    }
  
  =head1 DESCRIPTION
  
  Plack::Component is the base class shared between L<Plack::Middleware>
  and C<Plack::App::*> modules. If you are writing middleware, you should
  inherit from L<Plack::Middleware>, but if you are writing a
  Plack::App::* you should inherit from this directly.
  
  =head1 REQUIRED METHOD
  
  =over 4
  
  =item call ($env)
  
  You are expected to implement a C<call> method in your component. This
  is where all the work gets done. It receives the PSGI C<$env> hash-ref
  as an argument and is expected to return a proper PSGI response value.
  
  =back
  
  =head1 METHODS
  
  =over 4
  
  =item new (%opts | \%opts)
  
  The constructor accepts either a hash or a hashref and uses that to
  create the instance. It will call no other methods and simply return
  the instance that is created.
  
  =item prepare_app
  
  This method is called by C<to_app> and is meant as a hook to be used to
  prepare your component before it is packaged as a PSGI C<$app>.
  
  =item to_app
  
  This is the method used in several parts of the Plack infrastructure to
  convert your component into a PSGI C<$app>. You should not ever need to
  override this method; it is recommended to use C<prepare_app> and C<call>
  instead.
  
  =item response_cb
  
  This is a wrapper for C<response_cb> in L<Plack::Util>. See
  L<Plack::Middleware/RESPONSE CALLBACK> for details.
  
  =back
  
  =head1 OBJECT LIFECYCLE
  
  Objects for the derived classes (Plack::App::* or
  Plack::Middleware::*) are created at the PSGI application compile
  phase using C<new>, C<prepare_app> and C<to_app>, and the created
  object persists during the web server lifecycle, unless it is running
  on the non-persistent environment like CGI. C<call> is invoked against
  the same object whenever a new request comes in.
  
  You can check if it is running in a persistent environment by checking
  C<psgi.run_once> key in the C<$env> being true (non-persistent) or
  false (persistent), but it is best for you to write your middleware
  safely for a persistent environment. To accomplish that, you should
  avoid saving per-request data like C<$env> in your object.
  
  =head1 BACKWARDS COMPATIBILITY
  
  The L<Plack::Middleware> module used to inherit from L<Class::Accessor::Fast>,
  which has been removed in favor of the L<Plack::Util::Accessor> module. When
  developing new components it is recommended to use L<Plack::Util::Accessor>
  like so:
  
    use Plack::Util::Accessor qw( foo bar baz );
  
  However, in order to keep backwards compatibility this module provides a
  C<mk_accessors> method similar to L<Class::Accessor::Fast>. New code should
  not use this and use L<Plack::Util::Accessor> instead.
  
  =head1 SEE ALSO
  
  L<Plack> L<Plack::Builder> L<Plack::Middleware>
  
  =cut
PLACK_COMPONENT

$fatpacked{"Plack/HTTPParser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HTTPPARSER';
  package Plack::HTTPParser;
  use strict;
  use parent qw(Exporter);
  
  our @EXPORT = qw( parse_http_request );
  
  use Try::Tiny;
  
  {
      if (!$ENV{PLACK_HTTP_PARSER_PP} && try { require HTTP::Parser::XS; 1 }) {
          *parse_http_request = \&HTTP::Parser::XS::parse_http_request;
      } else {
          require Plack::HTTPParser::PP;
          *parse_http_request = \&Plack::HTTPParser::PP::parse_http_request;
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::HTTPParser - Parse HTTP headers
  
  =head1 SYNOPSIS
  
    use Plack::HTTPParser qw(parse_http_request);
  
    my $ret = parse_http_request($header_str, \%env);
    # see HTTP::Parser::XS docs
  
  =head1 DESCRIPTION
  
  Plack::HTTPParser is a wrapper class to dispatch C<parse_http_request>
  to Kazuho Oku's XS based HTTP::Parser::XS or pure perl fallback based
  on David Robins HTTP::Parser.
  
  If you want to force the use of the slower pure perl version even if the
  fast XS version is available, set the environment variable
  C<PLACK_HTTP_PARSER_PP> to 1.
  
  =head1 SEE ALSO
  
  L<HTTP::Parser::XS> L<HTTP::Parser>
  
  =cut
PLACK_HTTPPARSER

$fatpacked{"Plack/HTTPParser/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HTTPPARSER_PP';
  package Plack::HTTPParser::PP;
  use strict;
  use warnings;
  use URI::Escape;
  
  sub parse_http_request {
      my($chunk, $env) = @_;
      $env ||= {};
  
      # pre-header blank lines are allowed (RFC 2616 4.1)
      $chunk =~ s/^(\x0d?\x0a)+//;
      return -2 unless length $chunk;
  
      # double line break indicates end of header; parse it
      if ($chunk =~ /^(.*?\x0d?\x0a\x0d?\x0a)/s) {
          return _parse_header($chunk, length $1, $env);
      }
      return -2;  # still waiting for unknown amount of header lines
  }
  
  sub _parse_header {
      my($chunk, $eoh, $env) = @_;
  
      my $header = substr($chunk, 0, $eoh,'');
      $chunk =~ s/^\x0d?\x0a\x0d?\x0a//;
  
      # parse into lines
      my @header  = split /\x0d?\x0a/,$header;
      my $request = shift @header;
  
      # join folded lines
      my @out;
      for(@header) {
          if(/^[ \t]+/) {
              return -1 unless @out;
              $out[-1] .= $_;
          } else {
              push @out, $_;
          }
      }
  
      # parse request or response line
      my $obj;
      my ($major, $minor);
  
      my ($method,$uri,$http) = split / /,$request;
      return -1 unless $http and $http =~ /^HTTP\/(\d+)\.(\d+)$/i;
      ($major, $minor) = ($1, $2);
  
      $env->{REQUEST_METHOD}  = $method;
      $env->{SERVER_PROTOCOL} = "HTTP/$major.$minor";
      $env->{REQUEST_URI}     = $uri;
  
      my($path, $query) = ( $uri =~ /^([^?]*)(?:\?(.*))?$/s );
      for ($path, $query) { s/\#.*$// if defined && length } # dumb clients sending URI fragments
  
      $env->{PATH_INFO}    = URI::Escape::uri_unescape($path);
      $env->{QUERY_STRING} = $query || '';
      $env->{SCRIPT_NAME}  = '';
  
      # import headers
      my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
      my $k;
      for my $header (@out) {
          if ( $header =~ s/^($token): ?// ) {
              $k = $1;
              $k =~ s/-/_/g;
              $k = uc $k;
  
              if ($k !~ /^(?:CONTENT_LENGTH|CONTENT_TYPE)$/) {
                  $k = "HTTP_$k";
              }
          } elsif ( $header =~ /^\s+/) {
              # multiline header
          } else {
              return -1;
          }
  
          if (exists $env->{$k}) {
              $env->{$k} .= ", $header";
          } else {
              $env->{$k} = $header;
          }
      }
  
      return $eoh;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::HTTPParser::PP - Pure perl fallback of HTTP::Parser::XS
  
  =head1 DESCRIPTION
  
  Do not use this module directly. Use L<Plack::HTTPParser> instead.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
  
PLACK_HTTPPARSER_PP

$fatpacked{"Plack/Handler.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER';
  package Plack::Handler;
  use strict;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Handler - Connects PSGI applications and Web servers
  
  =head1 SYNOPSIS
  
    package Plack::Handler::AwesomeWebServer;
    sub new {
        my($class, %opt) = @_;
        ...
        return $self;
    }
  
    sub run {
        my($self, $app) = @_;
        # launch the AwesomeWebServer and run $app in the loop
    }
  
    # then from command line
    plackup -s AwesomeWebServer -a app.psgi
  
  =head1 DESCRIPTION
  
  Plack::Handler defines an adapter (connector) interface to adapt
  L<plackup> and L<Plack::Runner> to various PSGI web servers, such as
  Apache2 for mod_perl and Standalone for L<HTTP::Server::PSGI>.
  
  It is an empty class, and as long as they implement the methods
  defined as an Server adapter interface, they do not need to inherit
  Plack::Handler.
  
  If you write a new handler for existing web servers, I recommend you
  to include the full name of the server module after I<Plack::Handler>
  prefix, like L<Plack::Handler::Net::Server::Coro> if you write a
  handler for L<Net::Server::Coro>. That way you'll be using plackup
  command line option like:
  
    plackup -s Net::Server::Coro
  
  that makes it easy to figure out which web server you're going to use.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
    $server = FooBarServer->new(%args);
  
  Creates a new adapter object. I<%args> can take arbitrary parameters
  to configure server environments but common parameters are:
  
  =over 8
  
  =item port
  
  Port number the server listens to.
  
  =item host
  
  Address the server listens to. Set to undef to listen any interface.
  
  =back
  
  =item run
  
    $server->run($app);
  
  Starts the server process and when a request comes in, run the PSGI
  application passed in C<$app> in the loop.
  
  =item register_service
  
    $server->register_service($app);
  
  Optional interface if your server should run in parallel with other
  event loop, particularly L<AnyEvent>. This is the same as C<run> but
  doesn't run the main loop.
  
  =back
  
  =head1 SEE ALSO
  
  rackup
  
  =cut
  
PLACK_HANDLER

$fatpacked{"Plack/Handler/Apache1.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_APACHE1';
  package Plack::Handler::Apache1;
  use strict;
  use Apache::Request;
  use Apache::Constants qw(:common :response);
  
  use Plack::Util;
  use Scalar::Util;
  
  my %apps; # psgi file to $app mapping
  
  sub new { bless {}, shift }
  
  sub preload {
      my $class = shift;
      for my $app (@_) {
          $class->load_app($app);
      }
  }
  
  sub load_app {
      my($class, $app) = @_;
      return $apps{$app} ||= do {
          # Trick Catalyst, CGI.pm, CGI::Cookie and others that check
          # for $ENV{MOD_PERL}.
          #
          # Note that we delete it instead of just localizing
          # $ENV{MOD_PERL} because some users may check if the key
          # exists, and we do it this way because "delete local" is new
          # in 5.12:
          # http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
          local $ENV{MOD_PERL};
          delete $ENV{MOD_PERL};
  
          Plack::Util::load_psgi $app;
      };
  }
  
  sub handler {
      my $class = __PACKAGE__;
      my $r     = shift;
      my $psgi  = $r->dir_config('psgi_app');
      $class->call_app($r, $class->load_app($psgi));
  }
  
  sub call_app {
      my ($class, $r, $app) = @_;
  
      $r->subprocess_env; # let Apache create %ENV for us :)
  
      my $env = {
          %ENV,
          'psgi.version'        => [ 1, 1 ],
          'psgi.url_scheme'     => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
          'psgi.input'          => $r,
          'psgi.errors'         => *STDERR,
          'psgi.multithread'    => Plack::Util::FALSE,
          'psgi.multiprocess'   => Plack::Util::TRUE,
          'psgi.run_once'       => Plack::Util::FALSE,
          'psgi.streaming'      => Plack::Util::TRUE,
          'psgi.nonblocking'    => Plack::Util::FALSE,
          'psgix.harakiri'      => Plack::Util::TRUE,
      };
  
      if (defined(my $HTTP_AUTHORIZATION = $r->headers_in->{Authorization})) {
          $env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
      }
  
      my $vpath    = $env->{SCRIPT_NAME} . ($env->{PATH_INFO} || '');
  
      my $location = $r->location || "/";
         $location =~ s{/$}{};
      (my $path_info = $vpath) =~ s/^\Q$location\E//;
  
      $env->{SCRIPT_NAME} = $location;
      $env->{PATH_INFO}   = $path_info;
  
      my $res = $app->($env);
  
      if (ref $res eq 'ARRAY') {
          _handle_response($r, $res);
      }
      elsif (ref $res eq 'CODE') {
          $res->(sub {
              _handle_response($r, $_[0]);
          });
      }
      else {
          die "Bad response $res";
      }
  
      if ($env->{'psgix.harakiri.commit'}) {
          $r->child_terminate;
      }
  
      return OK;
  }
  
  sub _handle_response {
      my ($r, $res) = @_;
      my ($status, $headers, $body) = @{ $res };
  
      my $hdrs = ($status >= 200 && $status < 300)
          ? $r->headers_out : $r->err_headers_out;
  
      Plack::Util::header_iter($headers, sub {
          my($h, $v) = @_;
          if (lc $h eq 'content-type') {
              $r->content_type($v);
          } else {
              $hdrs->add($h => $v);
          }
      });
  
      $r->status($status);
      $r->send_http_header;
  
      if (defined $body) {
          if (Plack::Util::is_real_fh($body)) {
              $r->send_fd($body);
          } else {
              Plack::Util::foreach($body, sub { $r->print(@_) });
          }
      }
      else {
          return Plack::Util::inline_object
              write => sub { $r->print(@_) },
              close => sub { };
      }
  }
  
  1;
  
  __END__
  
  
  =head1 NAME
  
  Plack::Handler::Apache1 - Apache 1.3.x mod_perl handlers to run PSGI application
  
  =head1 SYNOPSIS
  
    <Location />
    SetHandler perl-script
    PerlHandler Plack::Handler::Apache1
    PerlSetVar psgi_app /path/to/app.psgi
    </Location>
  
    <Perl>
    use Plack::Handler::Apache1;
    Plack::Handler::Apache1->preload("/path/to/app.psgi");
    </Perl>
  
  =head1 DESCRIPTION
  
  This is a mod_perl handler module to run any PSGI application with mod_perl on Apache 1.3.x.
  
  If you want to run PSGI applications I<behind> Apache instead of using
  mod_perl, see L<Plack::Handler::FCGI> to run with FastCGI, or use
  standalone HTTP servers such as L<Starman> or L<Starlet> proxied with
  mod_proxy.
  
  =head1 AUTHOR
  
  Aaron Trevena
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
  
PLACK_HANDLER_APACHE1

$fatpacked{"Plack/Handler/Apache2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_APACHE2';
  package Plack::Handler::Apache2;
  use strict;
  use warnings;
  use Apache2::RequestRec;
  use Apache2::RequestIO;
  use Apache2::RequestUtil;
  use Apache2::Response;
  use Apache2::Const -compile => qw(OK);
  use Apache2::Log;
  use APR::Table;
  use IO::Handle;
  use Plack::Util;
  use Scalar::Util;
  use URI;
  use URI::Escape;
  
  my %apps; # psgi file to $app mapping
  
  sub new { bless {}, shift }
  
  sub preload {
      my $class = shift;
      for my $app (@_) {
          $class->load_app($app);
      }
  }
  
  sub load_app {
      my($class, $app) = @_;
      return $apps{$app} ||= do {
          # Trick Catalyst, CGI.pm, CGI::Cookie and others that check
          # for $ENV{MOD_PERL}.
          #
          # Note that we delete it instead of just localizing
          # $ENV{MOD_PERL} because some users may check if the key
          # exists, and we do it this way because "delete local" is new
          # in 5.12:
          # http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
          local $ENV{MOD_PERL};
          delete $ENV{MOD_PERL};
  
          Plack::Util::load_psgi $app;
      };
  }
  
  sub call_app {
      my ($class, $r, $app) = @_;
  
      $r->subprocess_env; # let Apache create %ENV for us :)
  
      my $env = {
          %ENV,
          'psgi.version'           => [ 1, 1 ],
          'psgi.url_scheme'        => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
          'psgi.input'             => $r,
          'psgi.errors'            => *STDERR,
          'psgi.multithread'       => Plack::Util::FALSE,
          'psgi.multiprocess'      => Plack::Util::TRUE,
          'psgi.run_once'          => Plack::Util::FALSE,
          'psgi.streaming'         => Plack::Util::TRUE,
          'psgi.nonblocking'       => Plack::Util::FALSE,
          'psgix.harakiri'         => Plack::Util::TRUE,
          'psgix.cleanup'          => Plack::Util::TRUE,
          'psgix.cleanup.handlers' => [],
      };
  
      if (defined(my $HTTP_AUTHORIZATION = $r->headers_in->{Authorization})) {
          $env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
      }
  
      # If you supply more than one Content-Length header Apache will
      # happily concat the values with ", ", e.g. "72, 72". This
      # violates the PSGI spec so fix this up and just take the first
      # one.
      if (exists $env->{CONTENT_LENGTH} && $env->{CONTENT_LENGTH} =~ /,/) {
          no warnings qw(numeric);
          $env->{CONTENT_LENGTH} = int $env->{CONTENT_LENGTH};
      }
  
      # Actually, we can not trust PATH_INFO from mod_perl because mod_perl squeezes multiple slashes into one slash.
      my $uri = URI->new("http://".$r->hostname.$r->unparsed_uri);
  
      $env->{PATH_INFO} = uri_unescape($uri->path);
  
      $class->fixup_path($r, $env);
  
      my $res = $app->($env);
  
      if (ref $res eq 'ARRAY') {
          _handle_response($r, $res);
      }
      elsif (ref $res eq 'CODE') {
          $res->(sub {
              _handle_response($r, $_[0]);
          });
      }
      else {
          die "Bad response $res";
      }
  
      if (@{ $env->{'psgix.cleanup.handlers'} }) {
          $r->push_handlers(
              PerlCleanupHandler => sub {
                  for my $cleanup_handler (@{ $env->{'psgix.cleanup.handlers'} }) {
                      $cleanup_handler->($env);
                  }
  
                  if ($env->{'psgix.harakiri.commit'}) {
                      $r->child_terminate;
                  }
              },
          );
      } else {
          if ($env->{'psgix.harakiri.commit'}) {
              $r->child_terminate;
          }
      }
  
      return Apache2::Const::OK;
  }
  
  sub handler {
      my $class = __PACKAGE__;
      my $r     = shift;
      my $psgi  = $r->dir_config('psgi_app');
      $class->call_app($r, $class->load_app($psgi));
  }
  
  # The method for PH::Apache2::Registry to override.
  sub fixup_path {
      my ($class, $r, $env) = @_;
  
      # $env->{PATH_INFO} is created from unparsed_uri so it is raw.
      my $path_info = $env->{PATH_INFO} || '';
  
      # Get argument of <Location> or <LocationMatch> directive
      # This may be string or regexp and we can't know either.
      my $location = $r->location;
  
      # Let's *guess* if we're in a LocationMatch directive
      if ($location eq '/') {
          # <Location /> could be handled as a 'root' case where we make
          # everything PATH_INFO and empty SCRIPT_NAME as in the PSGI spec
          $env->{SCRIPT_NAME} = '';
      } elsif ($path_info =~ s{^($location)/?}{/}) {
          $env->{SCRIPT_NAME} = $1 || '';
      } else {
          # Apache's <Location> is matched but here is not.
          # This is something wrong. We can only respect original.
          $r->server->log_error(
              "Your request path is '$path_info' and it doesn't match your Location(Match) '$location'. " .
              "This should be due to the configuration error. See perldoc Plack::Handler::Apache2 for details."
          );
      }
  
      $env->{PATH_INFO}   = $path_info;
  }
  
  sub _handle_response {
      my ($r, $res) = @_;
  
      my ($status, $headers, $body) = @{ $res };
  
      my $hdrs = ($status >= 200 && $status < 300)
          ? $r->headers_out : $r->err_headers_out;
  
      Plack::Util::header_iter($headers, sub {
          my($h, $v) = @_;
          if (lc $h eq 'content-type') {
              $r->content_type($v);
          } elsif (lc $h eq 'content-length') {
              $r->set_content_length($v);
          } else {
              $hdrs->add($h => $v);
          }
      });
  
      $r->status($status);
  
      if (Scalar::Util::blessed($body) and $body->can('path') and my $path = $body->path) {
          $r->sendfile($path);
      } elsif (defined $body) {
          Plack::Util::foreach($body, sub { $r->print(@_) });
          $r->rflush;
      }
      else {
          return Plack::Util::inline_object
              write => sub { $r->print(@_); $r->rflush },
              close => sub { $r->rflush };
      }
  
      return Apache2::Const::OK;
  }
  
  1;
  
  __END__
  
  =encoding utf-8
  
  =head1 NAME
  
  Plack::Handler::Apache2 - Apache 2.0 mod_perl handler to run PSGI application
  
  =head1 SYNOPSIS
  
    # in your httpd.conf
    <Location />
    SetHandler perl-script
    PerlResponseHandler Plack::Handler::Apache2
    PerlSetVar psgi_app /path/to/app.psgi
    </Location>
  
    # Optionally preload your apps in startup
    PerlPostConfigRequire /etc/httpd/startup.pl
  
  See L</STARTUP FILE> for more details on writing a C<startup.pl>.
  
  =head1 DESCRIPTION
  
  This is a mod_perl handler module to run any PSGI application with mod_perl on Apache 2.x.
  
  If you want to run PSGI applications I<behind> Apache instead of using
  mod_perl, see L<Plack::Handler::FCGI> to run with FastCGI, or use
  standalone HTTP servers such as L<Starman> or L<Starlet> proxied with
  mod_proxy.
  
  =head1 CREATING CUSTOM HANDLER
  
  If you want to create a custom handler that loads or creates PSGI
  applications using other means than loading from C<.psgi> files, you
  can create your own handler class and use C<call_app> class method to
  run your application.
  
    package My::ModPerl::Handler;
    use Plack::Handler::Apache2;
  
    sub get_app {
      # magic!
    }
  
    sub handler {
      my $r = shift;
      my $app = get_app();
      Plack::Handler::Apache2->call_app($r, $app);
    }
  
  =head1 STARTUP FILE
  
  Here is an example C<startup.pl> to preload PSGI applications:
  
      #!/usr/bin/env perl
  
      use strict;
      use warnings;
      use Apache2::ServerUtil ();
  
      BEGIN {
          return unless Apache2::ServerUtil::restart_count() > 1;
  
          require lib;
          lib->import('/path/to/my/perl/libs');
  
          require Plack::Handler::Apache2;
  
          my @psgis = ('/path/to/app1.psgi', '/path/to/app2.psgi');
          foreach my $psgi (@psgis) {
              Plack::Handler::Apache2->preload($psgi);
          }
      }
  
      1; # file must return true!
  
  See L<http://perl.apache.org/docs/2.0/user/handlers/server.html#Startup_File>
  for general information on the C<startup.pl> file for preloading perl modules
  and your apps.
  
  Some things to keep in mind when writing this file:
  
  =over 4
  
  =item * multiple init phases
  
  You have to check that L<Apache2::ServerUtil/restart_count> is C<< > 1 >>,
  otherwise your app will load twice and the env vars you set with
  L<PerlSetEnv|http://perl.apache.org/docs/2.0/user/config/config.html#C_PerlSetEnv_>
  will not be available when your app is loading the first time.
  
  Use the example above as a template.
  
  =item * C<@INC>
  
  The C<startup.pl> file is a good place to add entries to your C<@INC>.
  Use L<lib> to add entries, they can be in your app or C<.psgi> as well, but if
  your modules are in a L<local::lib> or some such, you will need to add the path
  for anything to load.
  
  Alternately, if you follow the example above, you can use:
  
      PerlSetEnv PERL5LIB /some/path
  
  or
  
      PerlSwitches -I/some/path
  
  in your C<httpd.conf>, which will also work.
  
  =item * loading errors
  
  Any exceptions thrown in your C<startup.pl> will stop Apache from starting at
  all.
  
  You probably don't want a stray syntax error to bring your whole server down in
  a shared or development environment, in which case it's a good idea to wrap the
  L</preload> call in an eval, using something like this:
  
      require Plack::Handler::Apache2;
  
      my @psgis = ('/path/to/app1.psgi', '/path/to/app2.psgi');
  
      foreach my $psgi (@psgis) {
          eval {
              Plack::Handler::Apache2->preload($psgi); 1;
          } or do {
              my $error = $@ || 'Unknown Error';
              # STDERR goes to the error_log
              print STDERR "Failed to load psgi '$psgi': $error\n";
          };
      }
  
  
  =item * dynamically loaded modules
  
  Some modules load their dependencies at runtime via e.g. L<Class::Load>. These
  modules will not get preloaded into your parent process by just including the
  app/module you are using.
  
  As an optimization, you can dump C<%INC> from a request to see if you are using
  any such modules and preload them in your C<startup.pl>.
  
  Another method is dumping the difference between the C<%INC> on
  process start and process exit. You can use something like this to
  accomplish this:
  
      my $start_inc = { %INC };
  
      END {
          my @m;
          foreach my $m (keys %INC) {
              push @m, $m unless exists $start_inc->{$m};
          }
  
          if (@m) {
              # STDERR goes to the error_log
              print STDERR "The following modules need to be preloaded:\n";
              print STDERR "$_\n" for @m;
          }
      }
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 CONTRIBUTORS
  
  Paul Driver
  
  Ævar Arnfjörð Bjarmason
  
  Rafael Kitover
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
PLACK_HANDLER_APACHE2

$fatpacked{"Plack/Handler/Apache2/Registry.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_APACHE2_REGISTRY';
  package Plack::Handler::Apache2::Registry;
  use strict;
  use warnings;
  use Try::Tiny;
  use Apache2::Const;
  use Apache2::Log;
  use parent qw/Plack::Handler::Apache2/;
  
  sub handler {
      my $class = __PACKAGE__;
      my ($r) = @_;
  
      return try {
          my $app = $class->load_app( $r->filename );
          $class->call_app( $r, $app );
      }catch{
          if(/no such file/i){
              $r->log_error( $_ );
              return Apache2::Const::NOT_FOUND;
          }else{
              $r->log_error( $_ );
              return Apache2::Const::SERVER_ERROR;
          }
      };
  }
  
  # Overriding
  sub fixup_path {
      my ($class, $r, $env) = @_;
      $env->{PATH_INFO} =~ s{^$env->{SCRIPT_NAME}}{};
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Handler::Apache2::Registry - Runs .psgi files.
  
  =head1 SYNOPSIS
  
    PerlModule Plack::Handler::Apache2::Registry;
    <Location /psgi-bin>
    SetHandler modperl
    PerlHandler Plack::Handler::Apache2::Registry
    </Location>
  
  =head1 DESCRIPTION
  
  This is a handler module to run any *.psgi files with mod_perl2,
  just like ModPerl::Registry.
  
  =head1 AUTHOR
  
  Masahiro Honma E<lt>hiratara@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Plack::Handler::Apache2>
  
  =cut
  
PLACK_HANDLER_APACHE2_REGISTRY

$fatpacked{"Plack/Handler/CGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_CGI';
  package Plack::Handler::CGI;
  use strict;
  use warnings;
  use IO::Handle;
  
  # copied from HTTP::Status
  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
  );
  
  sub new { bless {}, shift }
  
  sub run {
      my ($self, $app) = @_;
  
      my $env = $self->setup_env();
  
      my $res = $app->($env);
      if (ref $res eq 'ARRAY') {
          $self->_handle_response($res);
      }
      elsif (ref $res eq 'CODE') {
          $res->(sub {
              $self->_handle_response($_[0]);
          });
      }
      else {
          die "Bad response $res";
      }
  }
  
  sub setup_env {
      my ( $self, $override_env ) = @_;
  
      $override_env ||= {};
  
      binmode STDIN;
      binmode STDERR;
  
      my $env = {
          %ENV,
          'psgi.version'    => [ 1, 1 ],
          'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
          'psgi.input'      => *STDIN,
          'psgi.errors'     => *STDERR,
          'psgi.multithread'  => 0,
          'psgi.multiprocess' => 1,
          'psgi.run_once'     => 1,
          'psgi.streaming'    => 1,
          'psgi.nonblocking'  => 1,
          %{ $override_env },
      };
  
      delete $env->{HTTP_CONTENT_TYPE};
      delete $env->{HTTP_CONTENT_LENGTH};
      $env->{'HTTP_COOKIE'} ||= $ENV{COOKIE}; # O'Reilly server bug
  
      if (!exists $env->{PATH_INFO}) {
          $env->{PATH_INFO} = '';
      }
  
      if ($env->{SCRIPT_NAME} eq '/') {
          $env->{SCRIPT_NAME} = '';
          $env->{PATH_INFO}   = '/' . $env->{PATH_INFO};
      }
  
      return $env;
  }
  
  
  
  sub _handle_response {
      my ($self, $res) = @_;
  
      *STDOUT->autoflush(1);
      binmode STDOUT;
  
      my $hdrs;
      my $message = $StatusCode{$res->[0]};
      $hdrs = "Status: $res->[0] $message\015\012";
  
      my $headers = $res->[1];
      while (my ($k, $v) = splice(@$headers, 0, 2)) {
          $hdrs .= "$k: $v\015\012";
      }
      $hdrs .= "\015\012";
  
      print STDOUT $hdrs;
  
      my $body = $res->[2];
      my $cb = sub { print STDOUT $_[0] };
  
      # inline Plack::Util::foreach here
      if (ref $body eq 'ARRAY') {
          for my $line (@$body) {
              $cb->($line) if length $line;
          }
      }
      elsif (defined $body) {
          local $/ = \65536 unless ref $/;
          while (defined(my $line = $body->getline)) {
              $cb->($line) if length $line;
          }
          $body->close;
      }
      else {
          return Plack::Handler::CGI::Writer->new;
      }
  }
  
  package Plack::Handler::CGI::Writer;
  sub new   { bless \do { my $x }, $_[0] }
  sub write { print STDOUT $_[1] }
  sub close { }
  
  package Plack::Handler::CGI;
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Handler::CGI - CGI handler for Plack
  
  =head1 SYNOPSIS
  
  Want to run PSGI application as a CGI script? Rename .psgi to .cgi and
  change the shebang line like:
  
    #!/usr/bin/env plackup
    # rest of the file can be the same as other .psgi file
  
  You can alternatively create a .cgi file that contains something like:
  
    #!/usr/bin/perl
    use Plack::Loader;
    my $app = Plack::Util::load_psgi("/path/to/app.psgi");
    Plack::Loader->auto->run($app);
  
  This will auto-recognize the CGI environment variable to load this class.
  
  If you really want to explicitly load the CGI handler, you can. For instance
  you might do this when you want to embed a PSGI application server built into
  CGI-compatible perl-based web server:
  
    use Plack::Handler::CGI;
    Plack::Handler::CGI->new->run($app);
  
  =head1 DESCRIPTION
  
  This is a handler module to run any PSGI application as a CGI script.
  
  =head1 UTILITY METHODS
  
  =head2 setup_env()
  
    my $env = Plack::Handler::CGI->setup_env();
    my $env = Plack::Handler::CGI->setup_env(\%override_env);
  
  Sets up the PSGI environment hash for a CGI request from C<< %ENV >>> and returns it.
  You can provide a hashref of key/value pairs to override the defaults if you would like.
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
  
  
PLACK_HANDLER_CGI

$fatpacked{"Plack/Handler/FCGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_FCGI';
  package Plack::Handler::FCGI;
  use strict;
  use warnings;
  use constant RUNNING_IN_HELL => $^O eq 'MSWin32';
  
  use Scalar::Util qw(blessed);
  use Plack::Util;
  use FCGI;
  use HTTP::Status qw(status_message);
  use URI;
  use URI::Escape;
  
  sub new {
      my $class = shift;
      my $self  = bless {@_}, $class;
  
      $self->{leave_umask} ||= 0;
      $self->{keep_stderr} ||= 0;
      $self->{nointr}      ||= 0;
      $self->{daemonize}   ||= $self->{detach}; # compatibility
      $self->{nproc}       ||= 1 unless blessed $self->{manager};
      $self->{pid}         ||= $self->{pidfile}; # compatibility
      $self->{listen}      ||= [ ":$self->{port}" ] if $self->{port}; # compatibility
      $self->{backlog}     ||= 100;
      $self->{manager}     = 'FCGI::ProcManager' unless exists $self->{manager};
  
      $self;
  }
  
  sub run {
      my ($self, $app) = @_;
  
      my $running_on_server_starter = exists $ENV{SERVER_STARTER_PORT};
      my $sock = 0;
      if (-S STDIN) {
          # running from web server. Do nothing
          # Note it should come before listen check because of plackup's default
      } elsif ($running_on_server_starter) {
          # Runing under Server::Starter
          require Server::Starter;
          my %socks = %{Server::Starter::server_ports()};
          if (scalar(keys(%socks)) > 1) {
              die "More than one socket are specified by Server::Starter";
          }
          $sock = (values %socks)[0];
      } elsif ($self->{listen}) {
          my $old_umask = umask;
          unless ($self->{leave_umask}) {
              umask(0);
          }
          $sock = FCGI::OpenSocket( $self->{listen}->[0], $self->{backlog} )
              or die "failed to open FastCGI socket: $!";
          unless ($self->{leave_umask}) {
              umask($old_umask);
          }
      } elsif (!RUNNING_IN_HELL) {
          die "STDIN is not a socket: specify a listen location";
      }
  
      @{$self}{qw(stdin stdout stderr)} 
        = (IO::Handle->new, IO::Handle->new, IO::Handle->new);
  
      my %env;
      my $request = FCGI::Request(
          $self->{stdin}, $self->{stdout}, $self->{stderr},
          \%env, $sock,
          ($self->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR),
      );
  
      my $proc_manager;
  
      if ($self->{listen} or $running_on_server_starter) {
          $self->daemon_fork if $self->{daemonize};
  
          if ($self->{manager}) {
              if (blessed $self->{manager}) {
                  for (qw(nproc pid proc_title)) {
                      die "Don't use '$_' when passing in a 'manager' object"
                          if $self->{$_};
                  }
                  $proc_manager = $self->{manager};
              } else {
                  Plack::Util::load_class($self->{manager});
                  $proc_manager = $self->{manager}->new({
                      n_processes => $self->{nproc},
                      pid_fname   => $self->{pid},
                      (exists $self->{proc_title}
                           ? (pm_title => $self->{proc_title}) : ()),
                  });
              }
  
              # detach *before* the ProcManager inits
              $self->daemon_detach if $self->{daemonize};
  
              $proc_manager->pm_manage;
          }
          elsif ($self->{daemonize}) {
              $self->daemon_detach;
          }
      }
  
      while ($request->Accept >= 0) {
          $proc_manager && $proc_manager->pm_pre_dispatch;
  
          my $env = {
              %env,
              'psgi.version'      => [1,1],
              'psgi.url_scheme'   => ($env{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
              'psgi.input'        => $self->{stdin},
              'psgi.errors'       => 
                  ($self->{keep_stderr} ? \*STDERR : $self->{stderr}),
              'psgi.multithread'  => Plack::Util::FALSE,
              'psgi.multiprocess' => Plack::Util::TRUE,
              'psgi.run_once'     => Plack::Util::FALSE,
              'psgi.streaming'    => Plack::Util::TRUE,
              'psgi.nonblocking'  => Plack::Util::FALSE,
              'psgix.harakiri'    => defined $proc_manager,
          };
  
          delete $env->{HTTP_CONTENT_TYPE};
          delete $env->{HTTP_CONTENT_LENGTH};
  
          # lighttpd munges multiple slashes in PATH_INFO into one. Try recovering it
          my $uri = URI->new("http://localhost" .  $env->{REQUEST_URI});
          $env->{PATH_INFO} = uri_unescape($uri->path);
          $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E//;
  
          # root access for mod_fastcgi
          if (!exists $env->{PATH_INFO}) {
              $env->{PATH_INFO} = '';
          }
  
          # typical fastcgi_param from nginx might get empty values
          for my $key (qw(CONTENT_TYPE CONTENT_LENGTH)) {
              no warnings;
              delete $env->{$key} if exists $env->{$key} && $env->{$key} eq '';
          }
  
          if (defined(my $HTTP_AUTHORIZATION = $env->{Authorization})) {
              $env->{HTTP_AUTHORIZATION} = $HTTP_AUTHORIZATION;
          }
  
          my $res = Plack::Util::run_app $app, $env;
  
          if (ref $res eq 'ARRAY') {
              $self->_handle_response($res);
          }
          elsif (ref $res eq 'CODE') {
              $res->(sub {
                  $self->_handle_response($_[0]);
              });
          }
          else {
              die "Bad response $res";
          }
  
          # give pm_post_dispatch the chance to do things after the client thinks
          # the request is done
          $request->Finish;
  
          $proc_manager && $proc_manager->pm_post_dispatch();
  
          if ($proc_manager && $env->{'psgix.harakiri.commit'}) {
              $proc_manager->pm_exit("safe exit with harakiri");
          }
      }
  }
  
  sub _handle_response {
      my ($self, $res) = @_;
  
      $self->{stdout}->autoflush(1);
      binmode $self->{stdout};
  
      my $hdrs;
      my $message = status_message($res->[0]);
      $hdrs = "Status: $res->[0] $message\015\012";
  
      my $headers = $res->[1];
      while (my ($k, $v) = splice @$headers, 0, 2) {
          $hdrs .= "$k: $v\015\012";
      }
      $hdrs .= "\015\012";
  
      print { $self->{stdout} } $hdrs;
  
      my $cb = sub { print { $self->{stdout} } $_[0] };
      my $body = $res->[2];
      if (defined $body) {
          Plack::Util::foreach($body, $cb);
      }
      else {
          return Plack::Util::inline_object
              write => $cb,
              close => sub { };
      }
  }
  
  sub daemon_fork {
      require POSIX;
      fork && exit;
  }
  
  sub daemon_detach {
      my $self = shift;
      print "FastCGI daemon started (pid $$)\n";
      open STDIN,  "+</dev/null" or die $!; ## no critic
      open STDOUT, ">&STDIN"     or die $!;
      open STDERR, ">&STDIN"     or die $!;
      POSIX::setsid();
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Handler::FCGI - FastCGI handler for Plack
  
  =head1 SYNOPSIS
  
    # Run as a standalone daemon
    plackup -s FCGI --listen /tmp/fcgi.sock --daemonize --nproc 10
  
    # Run from your web server like mod_fastcgi
    #!/usr/bin/env plackup -s FCGI
    my $app = sub { ... };
  
    # Roll your own
    my $server = Plack::Handler::FCGI->new(
        nproc  => $num_proc,
        listen => [ $port_or_socket ],
        detach => 1,
    );
    $server->run($app);
  
  
  =head1 DESCRIPTION
  
  This is a handler module to run any PSGI application as a standalone
  FastCGI daemon or a .fcgi script.
  
  =head2 OPTIONS
  
  =over 4
  
  =item listen
  
      listen => [ '/path/to/socket' ]
      listen => [ ':8080' ]
  
  Listen on a socket path, hostname:port, or :port.
  
  =item port
  
  listen via TCP on port on all interfaces (Same as C<< listen => ":$port" >>)
  
  =item leave-umask
  
  Set to 1 to disable setting umask to 0 for socket open
  
  =item nointr
  
  Do not allow the listener to be interrupted by Ctrl+C
  
  =item nproc
  
  Specify a number of processes for FCGI::ProcManager
  
  =item pid
  
  Specify a filename for the pid file
  
  =item manager
  
  Specify either a FCGI::ProcManager subclass, or an actual FCGI::ProcManager-compatible object.
  
    use FCGI::ProcManager::Dynamic;
    Plack::Handler::FCGI->new(
        manager => FCGI::ProcManager::Dynamic->new(...),
    );
  
  =item daemonize
  
  Daemonize the process.
  
  =item proc-title
  
  Specify process title
  
  =item keep-stderr
  
  Send psgi.errors to STDERR instead of to the FCGI error stream.
  
  =item backlog
  
  Maximum length of the queue of pending connections
  
  =back
  
  =head2 WEB SERVER CONFIGURATIONS
  
  In all cases, you will want to install L<FCGI> and L<FCGI::ProcManager>.
  You may find it most convenient to simply install L<Task::Plack> which
  includes both of these.
  
  =head3 nginx
  
  This is an example nginx configuration to run your FCGI daemon on a
  Unix domain socket and run it at the server's root URL (/).
  
    http {
      server {
        listen 3001;
        location / {
          set $script "";
          set $path_info $uri;
          fastcgi_pass unix:/tmp/fastcgi.sock;
          fastcgi_param  SCRIPT_NAME      $script;
          fastcgi_param  PATH_INFO        $path_info;
          fastcgi_param  QUERY_STRING     $query_string;
          fastcgi_param  REQUEST_METHOD   $request_method;
          fastcgi_param  CONTENT_TYPE     $content_type;
          fastcgi_param  CONTENT_LENGTH   $content_length;
          fastcgi_param  REQUEST_URI      $request_uri;
          fastcgi_param  SERVER_PROTOCOL  $server_protocol;
          fastcgi_param  REMOTE_ADDR      $remote_addr;
          fastcgi_param  REMOTE_PORT      $remote_port;
          fastcgi_param  SERVER_ADDR      $server_addr;
          fastcgi_param  SERVER_PORT      $server_port;
          fastcgi_param  SERVER_NAME      $server_name;
        }
      }
    }
  
  If you want to host your application in a non-root path, then you
  should mangle this configuration to set the path to C<SCRIPT_NAME> and
  the rest of the path in C<PATH_INFO>.
  
  See L<http://wiki.nginx.org/NginxFcgiExample> for more details.
  
  =head3 Apache mod_fastcgi
  
  After installing C<mod_fastcgi>, you should add the C<FastCgiExternalServer>
  directive to your Apache config:
  
    FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/fcgi.sock
  
    ## Then set up the location that you want to be handled by fastcgi:
  
    # EITHER from a given path
    Alias /myapp/ /tmp/myapp.fcgi/
  
    # OR at the root
    Alias / /tmp/myapp.fcgi/
  
  Now you can use plackup to listen to the socket that you've just configured in Apache.
  
    $  plackup -s FCGI --listen /tmp/myapp.sock psgi/myapp.psgi
  
  The above describes the "standalone" method, which is usually appropriate.
  There are other methods, described in more detail at 
  L<Catalyst::Engine::FastCGI/Standalone_server_mode> (with regards to Catalyst, but which may be set up similarly for Plack).
  
  See also L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html#FastCgiExternalServer>
  for more details.
  
  =head3 lighttpd
  
  To host the app in the root path, you're recommended to use lighttpd
  1.4.23 or newer with C<fix-root-scriptname> flag like below.
  
    fastcgi.server = ( "/" =>
       ((
         "socket" => "/tmp/fcgi.sock",
         "check-local" => "disable",
         "fix-root-scriptname" => "enable",
       ))
  
  If you use lighttpd older than 1.4.22 where you don't have
  C<fix-root-scriptname>, mounting apps under the root causes wrong
  C<SCRIPT_NAME> and C<PATH_INFO> set. Also, mounting under the empty
  root (C<"">) or a path that has a trailing slash would still cause
  weird values set even with C<fix-root-scriptname>. In such cases you
  can use L<Plack::Middleware::LighttpdScriptNameFix> to fix it.
  
  To mount in the non-root path over TCP:
  
    fastcgi.server = ( "/foo" =>
       ((
         "host" = "127.0.0.1",
         "port" = "5000",
         "check-local" => "disable",
       ))
  
  It's recommended that your mount path does B<NOT> have the trailing
  slash. If you I<really> need to have one, you should consider using
  L<Plack::Middleware::LighttpdScriptNameFix> to fix the wrong
  B<PATH_INFO> values set by lighttpd.
  
  =cut
  
  =head2 Authorization
  
  Most fastcgi configuration does not pass C<Authorization> headers to
  C<HTTP_AUTHORIZATION> environment variable by default for security
  reasons. Authentication middleware such as L<Plack::Middleware::Auth::Basic> or
  L<Catalyst::Authentication::Credential::HTTP> requires the variable to
  be set up. Plack::Handler::FCGI supports extracting the C<Authorization> environment
  variable when it is configured that way.
  
  Apache2 with mod_fastcgi:
  
    --pass-header Authorization
  
  mod_fcgid:
  
    FcgiPassHeader Authorization
  
  =head2 Server::Starter
  
  This plack handler supports L<Server::Starter> as a superdaemon.
  Simply launch plackup from start_server with a path option.
  The listen option is ignored when launched from Server::Starter.
  
    start_server --path=/tmp/socket -- plackup -s FCGI app.psgi 
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
  
PLACK_HANDLER_FCGI

$fatpacked{"Plack/Handler/HTTP/Server/PSGI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_HTTP_SERVER_PSGI';
  package Plack::Handler::HTTP::Server::PSGI;
  use strict;
  
  # for temporary backward compat
  use parent qw( HTTP::Server::PSGI );
  
  sub new {
      my($class, %args) = @_;
      bless { %args }, $class;
  }
  
  sub run {
      my($self, $app) = @_;
      $self->_server->run($app);
  }
  
  sub _server {
      my $self = shift;
      HTTP::Server::PSGI->new(%$self);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Handler::HTTP::Server::PSGI - adapter for HTTP::Server::PSGI
  
  =head1 SYNOPSIS
  
    % plackup -s HTTP::Server::PSGI \
        --host 127.0.0.1 --port 9091 --timeout 120
  
  =head1 BACKWARD COMPATIBLITY
  
  Since Plack 0.99_22 this handler doesn't support preforking
  configuration i.e. C<--max-workers>. Use L<Starman> or L<Starlet> if
  you need preforking PSGI web server.
  
  =head1 CONFIGURATIONS
  
  =over 4
  
  =item host
  
  Host the server binds to. Defaults to all interfaces.
  
  =item port
  
  Port number the server listens on. Defaults to 8080.
  
  =item timeout
  
  Number of seconds a request times out. Defaults to 300.
  
  =item max-reqs-per-child
  
  Number of requests per worker to process. Defaults to 100.
  
  =back
  
  =head1 AUTHOR
  
  Kazuho Oku
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack> L<HTTP::Server::PSGI>
  
  =cut
PLACK_HANDLER_HTTP_SERVER_PSGI

$fatpacked{"Plack/Handler/Standalone.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_STANDALONE';
  package Plack::Handler::Standalone;
  use strict;
  use warnings;
  use parent qw( Plack::Handler::HTTP::Server::PSGI );
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Handler::Standalone - adapter for HTTP::Server::PSGI
  
  =head1 SYNOPSIS
  
    % plackup -s Standalone \
        --host 127.0.0.1 --port 9091 --timeout 120
  
  =head1 DESCRIPTION
  
  Plack::Handler::Standalone is an adapter for default Plack server
  implementation L<HTTP::Server::PSGI>. This is just an alias for
  L<Plack::Handler::HTTP::Server::PSGI>.
  
  =head1 SEE ALSO
  
  L<Plack::Handler::HTTP::Server::PSGI>
  
  =cut
PLACK_HANDLER_STANDALONE

$fatpacked{"Plack/Handler/Starlight.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_STARLIGHT';
  package Plack::Handler::Starlight;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0303';
  
  use base qw(Starlight::Server);
  
  use Config ();
  use English '-no_match_vars';
  use Fcntl ();
  use File::Spec;
  use POSIX ();
  use Plack::Util;
  
  use constant HAS_WIN32_PROCESS => $^O eq 'cygwin' && eval { require Win32::Process; 1; };
  
  use constant DEBUG => $ENV{PERL_STARLIGHT_DEBUG};
  
  sub new {
      my ($class, %args) = @_;
  
      # setup before instantiation
      my $max_workers = 10;
      for (qw(max_workers workers)) {
          $max_workers = delete $args{$_}
              if defined $args{$_};
      }
  
      # instantiate and set the variables
      my $self = $class->SUPER::new(%args);
      if ($^O eq 'MSWin32') {
          # forks are emulated
          $self->{is_multithread}  = Plack::Util::TRUE;
          $self->{is_multiprocess} = Plack::Util::FALSE;
      }
      else {
          # real forks
          $self->{is_multithread}  = Plack::Util::FALSE;
          $self->{is_multiprocess} = Plack::Util::TRUE;
      };
      $self->{max_workers} = $max_workers;
  
      $self->{main_process} = $$;
      $self->{processes} = +{};
  
      $self->{_kill_stalled_processes_delay} = 10;
  
      $self;
  }
  
  sub run {
      my($self, $app) = @_;
  
      $self->_daemonize();
  
      warn "*** starting main process $$" if DEBUG;
      $self->setup_listener();
  
      $self->_setup_privileges();
  
      local $SIG{PIPE} = 'IGNORE';
  
      local $SIG{CHLD} = sub {
          my ($sig) = @_;
          warn "*** SIG$sig received in process $$" if DEBUG;
          local ($!, $?);
          my $pid = waitpid(-1, &POSIX::WNOHANG);
          return if $pid == -1;
          delete $self->{processes}->{$pid};
      };
  
      my $sigint = $self->{_sigint};
      my $sigterm = $^O eq 'MSWin32' ? 'KILL' : 'TERM';
  
      if ($self->{max_workers} != 0) {
          local $SIG{$sigint} = local $SIG{TERM} = sub {
              my ($sig) = @_;
              warn "*** SIG$sig received in process $$" if DEBUG;
              $self->{term_received}++;
          };
          for (my $loop = 0; not $self->{term_received}; $loop++) {
              warn "*** running ", scalar keys %{$self->{processes}}, " processes" if DEBUG;
              if ($loop >= $self->{_kill_stalled_processes_delay} / ($self->{main_process_delay}||1)) {
                  $loop = 0;
                  # check stalled processes once per n sec
                  foreach my $pid (keys %{$self->{processes}}) {
                      delete $self->{processes}->{$pid} if not kill 0, $pid;
                  }
              }
              foreach my $n (1 + scalar keys %{$self->{processes}} .. $self->{max_workers}) {
                  $self->_create_process($app);
                  $self->_sleep($self->{spawn_interval});
              }
              # slow down main process
              $self->_sleep($self->{main_process_delay});
          }
          if (my @pids = keys %{$self->{processes}}) {
              warn "*** stopping ", scalar @pids, " processes" if DEBUG;
              foreach my $pid (@pids) {
                  warn "*** stopping process $pid" if DEBUG;
                  kill $sigterm, $pid;
              }
              if (HAS_WIN32_PROCESS) {
                  $self->_sleep(1);
                  foreach my $pid (keys %{$self->{processes}}) {
                      my $winpid = Cygwin::pid_to_winpid($pid) or next;
                      warn "*** terminating process $pid winpid $winpid" if DEBUG;
                      Win32::Process::KillProcess($winpid, 0);
                  }
              }
              $self->_sleep(1);
              foreach my $pid (keys %{$self->{processes}}) {
                  warn "*** waiting for process ", $pid if DEBUG;
                  waitpid $pid, 0;
              }
          }
          if ($^O eq 'cygwin' and not HAS_WIN32_PROCESS) {
              warn "Win32::Process is not installed. Some processes might be still active.\n";
          }
          warn "*** stopping main process $$" if DEBUG;
          exit 0;
      } else {
          # run directly, mainly for debugging
          local $SIG{$sigint} = local $SIG{TERM} = sub {
              my ($sig) = @_;
              warn "*** SIG$sig received in process $$" if DEBUG;
              exit 0;
          };
          while (1) {
              $self->accept_loop($app, $self->_calc_reqs_per_child());
              $self->_sleep($self->{spawn_interval});
          }
      }
  }
  
  1;
PLACK_HANDLER_STARLIGHT

$fatpacked{"Plack/Handler/Thrall.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_HANDLER_THRALL';
  package Plack::Handler::Thrall;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0302';
  
  use base qw(Thrall::Server);
  
  use threads;
  
  use Config ();
  use English '-no_match_vars';
  use Fcntl ();
  use File::Spec;
  use POSIX ();
  use Plack::Util;
  
  use constant DEBUG => $ENV{PERL_THRALL_DEBUG};
  
  sub new {
      my ($class, %args) = @_;
  
      # setup before instantiation
      my $max_workers = 10;
      for (qw(max_workers workers)) {
          $max_workers = delete $args{$_}
              if defined $args{$_};
      }
  
      # instantiate and set the variables
      my $self = $class->SUPER::new(%args);
  
      $self->{is_multithread}  = Plack::Util::TRUE;
      $self->{is_multiprocess} = Plack::Util::FALSE;
  
      $self->{max_workers} = $max_workers;
  
      $self->{main_thread} = threads->tid;
      $self->{processes} = +{};
  
      $self->{_kill_stalled_processes_delay} = 10;
  
      $self;
  }
  
  sub run {
      my($self, $app) = @_;
  
      $self->_daemonize();
  
      # EV does not work with threads
      $ENV{PERL_ANYEVENT_MODEL} = 'Perl';
      $ENV{PERL_ANYEVENT_IO_MODEL} = 'Perl';
  
      warn "*** starting main thread ", threads->tid if DEBUG;
      $self->setup_listener();
  
      $self->_setup_privileges();
  
      # Threads don't like simple 'IGNORE'
      local $SIG{PIPE} = sub { 'IGNORE' };
  
      my $sigint = $self->{_sigint};
      my $sigterm = $^O eq 'MSWin32' ? 'KILL' : 'TERM';
  
      if ($self->{max_workers} != 0) {
          if ($self->{thread_stack_size}) {
              threads->set_stack_size($self->{thread_stack_size});
          }
          local $SIG{$sigint} = local $SIG{TERM} = sub {
              my ($sig) = @_;
              warn "*** SIG$sig received in thread ", threads->tid if DEBUG;
              $self->{term_received}++;
              if (threads->tid) {
                  $self->{main_thread}->kill('TERM');
                  foreach my $thr (threads->list(threads::running)) {
                      $thr->kill('TERM') if $thr->tid != threads->tid;
                  }
              }
          };
          foreach my $n (1 .. $self->{max_workers}) {
              $self->_create_thread($app);
              $self->_sleep($self->{spawn_interval});
          }
          while (not $self->{term_received}) {
              warn "*** running ", scalar threads->list, " threads" if DEBUG;
              foreach my $thr (threads->list(threads::joinable)) {
                  warn "*** wait for thread ", $thr->tid if DEBUG;
                  eval {
                      $thr->detach;
                  };
                  warn $@ if $@;
                  $self->_create_thread($app);
                  $self->_sleep($self->{spawn_interval});
              }
              # slow down main thread
              $self->_sleep($self->{main_thread_delay});
          }
          foreach my $thr (threads->list) {
              $thr->detach;
          }
          warn "*** stopping main thread ", threads->tid if DEBUG;
          exit 0;
      } else {
          # run directly, mainly for debugging
          local $SIG{$sigint} = local $SIG{TERM} = sub {
              my ($sig) = @_;
              warn "*** SIG$sig received in thread ", threads->tid if DEBUG;
              exit 0;
          };
          while (1) {
              $self->accept_loop($app, $self->_calc_reqs_per_child());
              $self->_sleep($self->{spawn_interval});
          }
      }
  }
  
  1;
PLACK_HANDLER_THRALL

$fatpacked{"Plack/LWPish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LWPISH';
  package Plack::LWPish;
  use strict;
  use warnings;
  use HTTP::Tiny;
  use HTTP::Response;
  use Hash::MultiValue;
  
  sub new {
      my $class = shift;
      my $self  = bless {}, $class;
      $self->{http} = @_ == 1 ? $_[0] : HTTP::Tiny->new(@_);
      $self;
  }
  
  sub request {
      my($self, $req) = @_;
  
      my @headers;
      $req->headers->scan(sub { push @headers, @_ });
  
      my $options = {
          headers => Hash::MultiValue->new(@headers)->mixed,
      };
      $options->{content} = $req->content if defined $req->content && length($req->content);
  
      my $response = $self->{http}->request($req->method, $req->url, $options);
  
      my $res = HTTP::Response->new(
          $response->{status},
          $response->{reason},
          [ Hash::MultiValue->from_mixed($response->{headers})->flatten ],
          $response->{content},
      );
      $res->request($req);
  
      return $res;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::LWPish - HTTP::Request/Response compatible interface with HTTP::Tiny backend
  
  =head1 SYNOPSIS
  
    use Plack::LWPish;
  
    my $request = HTTP::Request->new(GET => 'http://perl.com/');
  
    my $ua = Plack::LWPish->new;
    my $res = $ua->request($request); # returns HTTP::Response
  
  =head1 DESCRIPTION
  
  This module is an adapter object that implements one method,
  C<request> that acts like L<LWP::UserAgent>'s request method
  i.e. takes HTTP::Request object and returns HTTP::Response object.
  
  This module is used solely inside L<Plack::Test::Suite> and
  L<Plack::Test::Server>, and you are recommended to take a look at
  L<HTTP::Thin> if you would like to use this outside Plack.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<HTTP::Thin> L<HTTP::Tiny> L<LWP::UserAgent>
  
  =cut
PLACK_LWPISH

$fatpacked{"Plack/Loader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER';
  package Plack::Loader;
  use strict;
  use Carp ();
  use Plack::Util;
  use Try::Tiny;
  
  sub new {
      my $class = shift;
      bless {}, $class;
  }
  
  sub watch {
      # do nothing. Override in subclass
  }
  
  sub auto {
      my($class, @args) = @_;
  
      my $backend = $class->guess
          or Carp::croak("Couldn't auto-guess server server implementation. Set it with PLACK_SERVER");
  
      my $server = try {
          $class->load($backend, @args);
      } catch {
          if (($ENV{PLACK_ENV}||'') eq 'development' or !/^Can't locate /) {
              warn "Autoloading '$backend' backend failed. Falling back to the Standalone. ",
                  "(You might need to install Plack::Handler::$backend from CPAN.  Caught error was: $_)\n"
                      if $ENV{PLACK_ENV} && $ENV{PLACK_ENV} eq 'development';
          }
          $class->load('Standalone' => @args);
      };
  
      return $server;
  }
  
  sub load {
      my($class, $server, @args) = @_;
  
      my($server_class, $error);
      try {
          $server_class = Plack::Util::load_class($server, 'Plack::Handler');
      } catch {
          $error ||= $_;
      };
  
      if ($server_class) {
          $server_class->new(@args);
      } else {
          die $error;
      }
  }
  
  sub preload_app {
      my($self, $builder) = @_;
      $self->{app} = $builder->();
  }
  
  sub guess {
      my $class = shift;
  
      my $env = $class->env;
  
      return $env->{PLACK_SERVER} if $env->{PLACK_SERVER};
  
      if ($env->{PHP_FCGI_CHILDREN} || $env->{FCGI_ROLE} || $env->{FCGI_SOCKET_PATH}) {
          return "FCGI";
      } elsif ($env->{GATEWAY_INTERFACE}) {
          return "CGI";
      } elsif (exists $INC{"Coro.pm"}) {
          return "Corona";
      } elsif (exists $INC{"AnyEvent.pm"}) {
          return "Twiggy";
      } elsif (exists $INC{"POE.pm"}) {
          return "POE";
      } else {
          return "Standalone";
      }
  }
  
  sub env { \%ENV }
  
  sub run {
      my($self, $server, $builder) = @_;
      $server->run($self->{app});
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Loader - (auto)load Plack Servers
  
  =head1 SYNOPSIS
  
    # auto-select server backends based on env vars
    use Plack::Loader;
    Plack::Loader->auto(%args)->run($app);
  
    # specify the implementation with a name
    Plack::Loader->load('FCGI', %args)->run($app);
  
  =head1 DESCRIPTION
  
  Plack::Loader is a factory class to load one of Plack::Handler subclasses based on the environment.
  
  =head1 AUTOLOADING
  
  C<< Plack::Loader->auto(%args) >> will autoload the most correct
  server implementation by guessing from environment variables and Perl INC
  hashes.
  
  =over 4
  
  =item PLACK_SERVER
  
    env PLACK_SERVER=AnyEvent ...
  
  Plack users can specify the specific implementation they want to load
  using the C<PLACK_SERVER> environment variable.
  
  =item PHP_FCGI_CHILDREN, GATEWAY_INTERFACE
  
  If there's one of FastCGI or CGI specific environment variables set,
  use the corresponding server implementation.
  
  =item %INC
  
  If one of L<AnyEvent>, L<Coro> or L<POE> is loaded, the relevant
  server implementation such as L<Twiggy>, L<Corona> or
  L<POE::Component::Server::PSGI> will be loaded, if they're available.
  
  =back
  
  =cut
  
  
PLACK_LOADER

$fatpacked{"Plack/Loader/Delayed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER_DELAYED';
  package Plack::Loader::Delayed;
  use strict;
  use parent qw(Plack::Loader);
  
  sub preload_app {
      my($self, $builder) = @_;
      $self->{builder} = $builder;
  }
  
  sub run {
      my($self, $server) = @_;
  
      my $compiled;
      my $app = sub {
          $compiled ||= $self->{builder}->();
          $compiled->(@_);
      };
  
      $server->{psgi_app_builder} = $self->{builder};
      $server->run($app);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Loader::Delayed - Delay the loading of .psgi until the first run
  
  =head1 SYNOPSIS
  
    plackup -s Starlet -L Delayed myapp.psgi
  
  =head1 DESCRIPTION
  
  This loader delays the compilation of specified PSGI application until
  the first request time. This prevents bad things from happening with
  preforking web servers like L<Starlet>, when your application
  manipulates resources such as sockets or database connections in the
  master startup process and then shared by children.
  
  You can combine this loader with C<-M> command line option, like:
  
    plackup -s Starlet -MCatalyst -L Delayed myapp.psgi
  
  loads the module Catalyst in the master process for the better process
  management with copy-on-write, however the application C<myapp.psgi>
  is loaded per children.
  
  L<Starman> since version 0.2000 loads this loader by default unless
  you specify the command line option C<--preload-app> for the
  L<starman> executable.
  
  =head1 DEVELOPERS
  
  Web server developers can make use of C<psgi_app_builder> attribute
  callback set in Plack::Handler, to load the application earlier than
  the first request time.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<plackup>
  
  =cut
  
PLACK_LOADER_DELAYED

$fatpacked{"Plack/Loader/Restarter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER_RESTARTER';
  package Plack::Loader::Restarter;
  use strict;
  use warnings;
  use parent qw(Plack::Loader);
  use Plack::Util;
  use Try::Tiny;
  
  sub new {
      my($class, $runner) = @_;
      bless { watch => [] }, $class;
  }
  
  sub preload_app {
      my($self, $builder) = @_;
      $self->{builder} = $builder;
  }
  
  sub watch {
      my($self, @dir) = @_;
      push @{$self->{watch}}, @dir;
  }
  
  sub _fork_and_start {
      my($self, $server) = @_;
  
      delete $self->{pid}; # re-init in case it's a restart
  
      my $pid = fork;
      die "Can't fork: $!" unless defined $pid;
  
      if ($pid == 0) { # child
          return $server->run($self->{builder}->());
      } else {
          $self->{pid} = $pid;
      }
  }
  
  sub _kill_child {
      my $self = shift;
  
      my $pid = $self->{pid} or return;
      warn "Killing the existing server (pid:$pid)\n";
      kill 'TERM' => $pid;
      waitpid($pid, 0);
  }
  
  sub valid_file {
      my($self, $file) = @_;
  
      # vim temporary file is  4913 to 5036
      # http://www.mail-archive.com/vim_dev@googlegroups.com/msg07518.html
      if ( $file->{path} =~ m{(\d+)$} && $1 >= 4913 && $1 <= 5036) {
          return 0;
      }
      $file->{path} !~ m!\.(?:git|svn)[/\\]|\.(?:bak|swp|swpx|swx)$|~$|_flymake\.p[lm]$|\.#!;
  }
  
  sub run {
      my($self, $server) = @_;
  
      $self->_fork_and_start($server);
      return unless $self->{pid};
  
      require Filesys::Notify::Simple;
      my $watcher = Filesys::Notify::Simple->new($self->{watch});
      warn "Watching @{$self->{watch}} for file updates.\n";
      local $SIG{TERM} = sub { $self->_kill_child; exit(0); };
  
      while (1) {
          my @restart;
  
          # this is blocking
          $watcher->wait(sub {
              my @events = @_;
              @events = grep $self->valid_file($_), @events;
              return unless @events;
  
              @restart = @events;
          });
  
          next unless @restart;
  
          for my $ev (@restart) {
              warn "-- $ev->{path} updated.\n";
          }
  
          $self->_kill_child;
          warn "Successfully killed! Restarting the new server process.\n";
          $self->_fork_and_start($server);
          return unless $self->{pid};
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Loader::Restarter - Restarting loader
  
  =head1 SYNOPSIS
  
    plackup -r -R paths
  
  =head1 DESCRIPTION
  
  Plack::Loader::Restarter is a loader backend that implements C<-r> and
  C<-R> option for the L<plackup> script. It forks the server as a child
  process and the parent watches the directories for file updates, and
  whenever it receives the notification, kills the child server and
  restart.
  
  =head1 SEE ALSO
  
  L<Plack::Runner>, L<Catalyst::Restarter>
  
  =cut
PLACK_LOADER_RESTARTER

$fatpacked{"Plack/Loader/Shotgun.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_LOADER_SHOTGUN';
  package Plack::Loader::Shotgun;
  use strict;
  use parent qw(Plack::Loader);
  use Storable;
  use Try::Tiny;
  use Plack::Middleware::BufferedStreaming;
  
  die <<DIE if $^O eq 'MSWin32' && !$ENV{PLACK_SHOTGUN_MEMORY_LEAK};
  
  Shotgun loader uses fork(2) system call to create a fresh Perl interpreter, that is known to not work
  properly in a fork-emulation layer on Windows and cause huge memory leaks.
  
  If you're aware of this and still want to run the loader, run it with the environment variable
  PLACK_SHOTGUN_MEMORY_LEAK on.
  
  DIE
  
  sub preload_app {
      my($self, $builder) = @_;
      $self->{builder} = sub { Plack::Middleware::BufferedStreaming->wrap($builder->()) };
  }
  
  sub run {
      my($self, $server) = @_;
  
      my $app = sub {
          my $env = shift;
  
          pipe my $read, my $write;
  
          my $pid = fork;
          if ($pid) {
              # parent
              close $write;
              my $res = Storable::thaw(join '', <$read>);
              close $read;
              waitpid($pid, 0);
  
              return $res;
          } else {
              # child
              close $read;
  
              my $res;
              try {
                  $env->{'psgi.streaming'} = 0;
                  $res = $self->{builder}->()->($env);
                  my @body;
                  Plack::Util::foreach($res->[2], sub { push @body, $_[0] });
                  $res->[2] = \@body;
              } catch {
                  $env->{'psgi.errors'}->print($_);
                  $res = [ 500, [ "Content-Type", "text/plain" ], [ "Internal Server Error" ] ];
              };
  
              print {$write} Storable::freeze($res);
              close $write;
              exit;
          }
      };
  
      $server->run($app);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Loader::Shotgun - forking implementation of plackup
  
  =head1 SYNOPSIS
  
    plackup -L Shotgun
  
  =head1 DESCRIPTION
  
  Shotgun loader delays the compilation and execution of your
  application until the runtime. When a new request comes in, this forks
  a new child, compiles your code and runs the application.
  
  This should be an ultimate alternative solution when reloading with
  L<Plack::Middleware::Refresh> doesn't work, or plackup's default C<-r>
  filesystem watcher causes problems. I can imagine this is useful for
  applications which expects their application is only evaluated once
  (like in-file templates) or on operating systems with broken fork
  implementation, etc.
  
  This is much like good old CGI's fork and run but you don't need a web
  server, and there's a benefit of preloading modules that are not
  likely to change. For instance if you develop a web application using
  Moose and DBIx::Class,
  
    plackup -MMoose -MDBIx::Class -L Shotgun yourapp.psgi
  
  would preload those modules and only re-evaluates your code in every
  request.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa with an inspiration from L<http://github.com/rtomayko/shotgun>
  
  =head1 SEE ALSO
  
  L<plackup>
  
  =cut
PLACK_LOADER_SHOTGUN

$fatpacked{"Plack/MIME.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIME';
  package Plack::MIME;
  use strict;
  
  # stolen from rack.mime.rb
  our $MIME_TYPES = {
      ".3gp"     => "video/3gpp",
      ".a"       => "application/octet-stream",
      ".ai"      => "application/postscript",
      ".aif"     => "audio/x-aiff",
      ".aiff"    => "audio/x-aiff",
      ".asc"     => "application/pgp-signature",
      ".asf"     => "video/x-ms-asf",
      ".asm"     => "text/x-asm",
      ".asx"     => "video/x-ms-asf",
      ".atom"    => "application/atom+xml",
      ".au"      => "audio/basic",
      ".avi"     => "video/x-msvideo",
      ".bat"     => "application/x-msdownload",
      ".bin"     => "application/octet-stream",
      ".bmp"     => "image/bmp",
      ".bz2"     => "application/x-bzip2",
      ".c"       => "text/x-c",
      ".cab"     => "application/vnd.ms-cab-compressed",
      ".cc"      => "text/x-c",
      ".chm"     => "application/vnd.ms-htmlhelp",
      ".class"   => "application/octet-stream",
      ".com"     => "application/x-msdownload",
      ".conf"    => "text/plain",
      ".cpp"     => "text/x-c",
      ".crt"     => "application/x-x509-ca-cert",
      ".css"     => "text/css",
      ".csv"     => "text/csv",
      ".cxx"     => "text/x-c",
      ".deb"     => "application/x-debian-package",
      ".der"     => "application/x-x509-ca-cert",
      ".diff"    => "text/x-diff",
      ".djv"     => "image/vnd.djvu",
      ".djvu"    => "image/vnd.djvu",
      ".dll"     => "application/x-msdownload",
      ".dmg"     => "application/octet-stream",
      ".doc"     => "application/msword",
      ".dot"     => "application/msword",
      ".dtd"     => "application/xml-dtd",
      ".dvi"     => "application/x-dvi",
      ".ear"     => "application/java-archive",
      ".eml"     => "message/rfc822",
      ".eps"     => "application/postscript",
      ".exe"     => "application/x-msdownload",
      ".f"       => "text/x-fortran",
      ".f77"     => "text/x-fortran",
      ".f90"     => "text/x-fortran",
      ".flv"     => "video/x-flv",
      ".for"     => "text/x-fortran",
      ".gem"     => "application/octet-stream",
      ".gemspec" => "text/x-script.ruby",
      ".gif"     => "image/gif",
      ".gz"      => "application/x-gzip",
      ".h"       => "text/x-c",
      ".hh"      => "text/x-c",
      ".htm"     => "text/html",
      ".html"    => "text/html",
      ".ico"     => "image/vnd.microsoft.icon",
      ".ics"     => "text/calendar",
      ".ifb"     => "text/calendar",
      ".iso"     => "application/octet-stream",
      ".jar"     => "application/java-archive",
      ".java"    => "text/x-java-source",
      ".jnlp"    => "application/x-java-jnlp-file",
      ".jpeg"    => "image/jpeg",
      ".jpg"     => "image/jpeg",
      ".js"      => "application/javascript",
      ".json"    => "application/json",
      ".log"     => "text/plain",
      ".m3u"     => "audio/x-mpegurl",
      ".m4v"     => "video/mp4",
      ".man"     => "text/troff",
      ".manifest"=> "text/cache-manifest",
      ".mathml"  => "application/mathml+xml",
      ".mbox"    => "application/mbox",
      ".mdoc"    => "text/troff",
      ".me"      => "text/troff",
      ".mid"     => "audio/midi",
      ".midi"    => "audio/midi",
      ".mime"    => "message/rfc822",
      ".mml"     => "application/mathml+xml",
      ".mng"     => "video/x-mng",
      ".mov"     => "video/quicktime",
      ".mp3"     => "audio/mpeg",
      ".mp4"     => "video/mp4",
      ".mp4v"    => "video/mp4",
      ".mpeg"    => "video/mpeg",
      ".mpg"     => "video/mpeg",
      ".ms"      => "text/troff",
      ".msi"     => "application/x-msdownload",
      ".odp"     => "application/vnd.oasis.opendocument.presentation",
      ".ods"     => "application/vnd.oasis.opendocument.spreadsheet",
      ".odt"     => "application/vnd.oasis.opendocument.text",
      ".ogg"     => "application/ogg",
      ".ogv"     => "video/ogg",
      ".p"       => "text/x-pascal",
      ".pas"     => "text/x-pascal",
      ".pbm"     => "image/x-portable-bitmap",
      ".pdf"     => "application/pdf",
      ".pem"     => "application/x-x509-ca-cert",
      ".pgm"     => "image/x-portable-graymap",
      ".pgp"     => "application/pgp-encrypted",
      ".pkg"     => "application/octet-stream",
      ".pl"      => "text/x-script.perl",
      ".pm"      => "text/x-script.perl-module",
      ".png"     => "image/png",
      ".pnm"     => "image/x-portable-anymap",
      ".ppm"     => "image/x-portable-pixmap",
      ".pps"     => "application/vnd.ms-powerpoint",
      ".ppt"     => "application/vnd.ms-powerpoint",
      ".ps"      => "application/postscript",
      ".psd"     => "image/vnd.adobe.photoshop",
      ".py"      => "text/x-script.python",
      ".qt"      => "video/quicktime",
      ".ra"      => "audio/x-pn-realaudio",
      ".rake"    => "text/x-script.ruby",
      ".ram"     => "audio/x-pn-realaudio",
      ".rar"     => "application/x-rar-compressed",
      ".rb"      => "text/x-script.ruby",
      ".rdf"     => "application/rdf+xml",
      ".roff"    => "text/troff",
      ".rpm"     => "application/x-redhat-package-manager",
      ".rss"     => "application/rss+xml",
      ".rtf"     => "application/rtf",
      ".ru"      => "text/x-script.ruby",
      ".s"       => "text/x-asm",
      ".sgm"     => "text/sgml",
      ".sgml"    => "text/sgml",
      ".sh"      => "application/x-sh",
      ".sig"     => "application/pgp-signature",
      ".snd"     => "audio/basic",
      ".so"      => "application/octet-stream",
      ".svg"     => "image/svg+xml",
      ".svgz"    => "image/svg+xml",
      ".swf"     => "application/x-shockwave-flash",
      ".t"       => "text/troff",
      ".tar"     => "application/x-tar",
      ".tbz"     => "application/x-bzip-compressed-tar",
      ".tcl"     => "application/x-tcl",
      ".tex"     => "application/x-tex",
      ".texi"    => "application/x-texinfo",
      ".texinfo" => "application/x-texinfo",
      ".text"    => "text/plain",
      ".tif"     => "image/tiff",
      ".tiff"    => "image/tiff",
      ".torrent" => "application/x-bittorrent",
      ".tr"      => "text/troff",
      ".txt"     => "text/plain",
      ".vcf"     => "text/x-vcard",
      ".vcs"     => "text/x-vcalendar",
      ".vrml"    => "model/vrml",
      ".war"     => "application/java-archive",
      ".wav"     => "audio/x-wav",
      ".wma"     => "audio/x-ms-wma",
      ".wmv"     => "video/x-ms-wmv",
      ".wmx"     => "video/x-ms-wmx",
      ".woff"    => "application/font-woff",
      ".wrl"     => "model/vrml",
      ".wsdl"    => "application/wsdl+xml",
      ".xbm"     => "image/x-xbitmap",
      ".xhtml"   => "application/xhtml+xml",
      ".xls"     => "application/vnd.ms-excel",
      ".xml"     => "application/xml",
      ".xpm"     => "image/x-xpixmap",
      ".xsl"     => "application/xml",
      ".xslt"    => "application/xslt+xml",
      ".yaml"    => "text/yaml",
      ".yml"     => "text/yaml",
      ".zip"     => "application/zip",
  };
  
  my $fallback = sub { };
  
  sub mime_type {
      my($class, $file) = @_;
      $file =~ /(\.[a-zA-Z0-9]+)$/ or return;
      $MIME_TYPES->{lc $1} || $fallback->(lc $1);
  }
  
  sub add_type {
      my $class = shift;
      while (my($ext, $type) = splice @_, 0, 2) {
          $MIME_TYPES->{lc $ext} = $type;
      }
  }
  
  sub set_fallback {
      my($class, $cb) = @_;
      $fallback = $cb;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::MIME - MIME type registry
  
  =head1 SYNOPSIS
  
    use Plack::MIME;
  
    my $mime = Plack::MIME->mime_type(".png"); # image/png
  
    # register new type(s)
    Plack::MIME->add_type(".foo" => "application/x-foo");
  
    # Use MIME::Types as a fallback
    use MIME::Types 'by_suffix';
    Plack::MIME->set_fallback(sub { (by_suffix $_[0])[0] });
  
  =head1 DESCRIPTION
  
  Plack::MIME is a simple MIME type registry for Plack applications. The
  selection of MIME types is based on Rack's Rack::Mime module.
  
  =head1 SEE ALSO
  
  Rack::Mime L<MIME::Types>
  
  =cut
  
  
PLACK_MIME

$fatpacked{"Plack/Middleware.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE';
  package Plack::Middleware;
  use strict;
  use warnings;
  use Carp ();
  use parent qw(Plack::Component);
  use Plack::Util;
  use Plack::Util::Accessor qw( app );
  
  sub wrap {
      my($self, $app, @args) = @_;
      if (ref $self) {
          $self->{app} = $app;
      } else {
          $self = $self->new({ app => $app, @args });
      }
      return $self->to_app;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware - Base class for easy-to-use PSGI middleware
  
  =head1 SYNOPSIS
  
    package Plack::Middleware::Foo;
    use parent qw( Plack::Middleware );
  
    sub call {
        my($self, $env) = @_;
        # Do something with $env
  
        # $self->app is the original app
        my $res = $self->app->($env);
  
        # Do something with $res
        return $res;
    }
  
    # then in app.psgi
    use Plack::Builder;
  
    my $app = sub { ... } # as usual
  
    builder {
        enable "Plack::Middleware::Foo";
        enable "Plack::Middleware::Bar", %options;
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware is a utility base class to write PSGI
  middleware. All you have to do is to inherit from Plack::Middleware
  and then implement the callback C<call> method (or the C<to_app> method
  that would return the PSGI code reference) to do the actual work. You
  can use C<< $self->app >> to call the original (wrapped) application.
  
  Your middleware object is created at the PSGI application compile time
  and is persistent during the web server life cycle (unless it is a
  non-persistent environment such as CGI), so you should never set or
  cache per-request data like C<$env> in your middleware object. See
  also L<Plack::Component/"OBJECT LIFECYCLE">.
  
  See L<Plack::Builder> how to actually enable middleware in your
  I<.psgi> application file using the DSL. If you do not like our
  builder DSL, you can also use the C<wrap> method to wrap your application
  with a middleware:
  
    use Plack::Middleware::Foo;
  
    my $app = sub { ... };
    $app = Plack::Middleware::Foo->wrap($app, %options);
    $app = Plack::Middleware::Bar->wrap($app, %options);
  
  =head1 RESPONSE CALLBACK
  
  The typical middleware is written like this:
  
    package Plack::Middleware::Something;
    use parent qw(Plack::Middleware);
  
    sub call {
        my($self, $env) = @_;
        # pre-processing $env
        my $res = $self->app->($env);
        # post-processing $res
        return $res;
    }
  
  The tricky thing about post-processing the response is that it could
  either be an immediate 3 element array ref, or a code reference that
  implements the delayed (streaming) interface.
  
  Dealing with these two types of response in each piece of middleware
  is pointless, so you're recommended to use the C<response_cb> wrapper
  function in L<Plack::Util> when implementing a post processing
  middleware.
  
    sub call {
        my($self, $env) = @_;
        # pre-processing $env
        my $res = $app->($env);
  
        return Plack::Util::response_cb($res, sub {
            my $res = shift;
            # do something with $res;
        });
    }
  
  The callback function gets a response as an array reference, and you can
  update the reference to implement the post-processing. In the normal
  case, this arrayref will have three elements (as described by the PSGI
  spec), but will have only two elements when using a C<$writer> as
  described below.
  
    package Plack::Middleware::Always500;
    use parent qw(Plack::Middleware);
    use Plack::Util;
  
    sub call {
        my($self, $env) = @_;
        my $res  = $self->app->($env);
        return Plack::Util::response_cb($res, sub {
            my $res = shift;
            $res->[0] = 500;
            return;
        });
    }
  
  In this example, the callback gets the C<$res> and updates its first
  element (status code) to 500. Using C<response_cb> makes sure that
  this works with the delayed response too.
  
  You're not required (and not recommended either) to return a new array
  reference - they will be simply ignored. You're suggested to
  explicitly return, unless you fiddle with the content filter callback
  (see below).
  
  Similarly, note that you have to keep the C<$res> reference when you
  swap the entire response.
  
    Plack::Util::response_cb($res, sub {
        my $res = shift;
        $res = [ $new_status, $new_headers, $new_body ]; # THIS DOES NOT WORK
        return;
    });
  
  This does not work, since assigning a new anonymous array to C<$res>
  doesn't update the original PSGI response value. You should instead
  do:
  
    Plack::Util::response_cb($res, sub {
        my $res = shift;
        @$res = ($new_status, $new_headers, $new_body); # THIS WORKS
        return;
    });
  
  The third element of the response array ref is a body, and it could
  be either an arrayref or L<IO::Handle>-ish object. The application could
  also make use of the C<$writer> object if C<psgi.streaming> is in
  effect, and in this case, the third element will not exist
  (C<@$res == 2>). Dealing with these variants is again really painful,
  and C<response_cb> can take care of that too, by allowing you to return
  a content filter as a code reference.
  
    # replace all "Foo" in content body with "Bar"
    Plack::Util::response_cb($res, sub {
        my $res = shift;
        return sub {
            my $chunk = shift;
            return unless defined $chunk;
            $chunk =~ s/Foo/Bar/g;
            return $chunk;
        }
    });
  
  The callback takes one argument C<$chunk> and your callback is
  expected to return the updated chunk. If the given C<$chunk> is undef,
  it means the stream has reached the end, so your callback should also
  return undef, or return the final chunk and return undef when called
  next time.
  
  =head1 SEE ALSO
  
  L<Plack> L<Plack::Builder> L<Plack::Component>
  
  =cut
PLACK_MIDDLEWARE

$fatpacked{"Plack/Middleware/AccessLog.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_ACCESSLOG';
  package Plack::Middleware::AccessLog;
  use strict;
  use warnings;
  use parent qw( Plack::Middleware );
  use Plack::Util::Accessor qw( logger format compiled_format);
  use Apache::LogFormat::Compiler;
  
  my %formats = (
      common => '%h %l %u %t "%r" %>s %b',
      combined => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"',
  );
  
  sub prepare_app {
      my $self = shift;
      my $fmt = $self->format || "combined";
      $fmt = $formats{$fmt} if exists $formats{$fmt};
      $self->compiled_format(Apache::LogFormat::Compiler->new($fmt));
  }
  
  sub call {
      my $self = shift;
      my($env) = @_;
  
      my $res = $self->app->($env);
  
      if ( ref($res) && ref($res) eq 'ARRAY' ) {
          my $content_length = Plack::Util::content_length($res->[2]);
          my $log_line = $self->log_line($res->[0], $res->[1], $env, { content_length => $content_length });
          if ( my $logger = $self->logger ) {
              $logger->($log_line);
          }
          else {
              $env->{'psgi.errors'}->print($log_line);
          }  
          return $res;
      }
  
      return $self->response_cb($res, sub {
          my $res = shift;
          my $content_length = Plack::Util::content_length($res->[2]);
          my $log_line = $self->log_line($res->[0], $res->[1], $env, { content_length => $content_length });
          if ( my $logger = $self->logger ) {
              $logger->($log_line);
          }
          else {
              $env->{'psgi.errors'}->print($log_line);
          }  
      });
  }
  
  sub log_line {
      my($self, $status, $headers, $env, $opts) = @_;
  
      $self->compiled_format->log_line(
          $env,
          [$status,$headers],
          $opts->{content_length},
          $opts->{time}
      );
  }
  
  1;
  
  __END__
  
  =for stopwords
  LogFormat
  
  =head1 NAME
  
  Plack::Middleware::AccessLog - Logs requests like Apache's log format
  
  =head1 SYNOPSIS
  
    # in app.psgi
    use Plack::Builder;
  
    builder {
        enable "Plack::Middleware::AccessLog", format => "combined";
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::AccessLog forwards the request to the given app and
  logs request and response details to the logger callback. The format
  can be specified using Apache-like format strings (or C<combined> or
  C<common> for the default formats). If none is specified C<combined> is
  used.
  
  This middleware uses calculable Content-Length by checking body type,
  and cannot log the time taken to serve requests. It also logs the
  request B<before> the response is actually sent to the client. Use
  L<Plack::Middleware::AccessLog::Timed> if you want to log details
  B<after> the response is transmitted (more like a real web server) to
  the client.
  
  This middleware is enabled by default when you run L<plackup> as a
  default C<development> environment.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item format
  
    enable "Plack::Middleware::AccessLog",
        format => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"';
  
  Takes a format string (or a preset template C<combined> or C<custom>)
  to specify the log format. This middleware uses L<Apache::LogFormat::Compiler> to
  generate access_log lines. See more details on perldoc L<Apache::LogFormat::Compiler>
  
     %%    a percent sign
     %h    REMOTE_ADDR from the PSGI environment, or -
     %l    remote logname not implemented (currently always -)
     %u    REMOTE_USER from the PSGI environment, or -
     %t    [local timestamp, in default format]
     %r    REQUEST_METHOD, REQUEST_URI and SERVER_PROTOCOL from the PSGI environment
     %s    the HTTP status code of the response
     %b    content length of the response
     %T    custom field for handling times in subclasses
     %D    custom field for handling sub-second times in subclasses
     %v    SERVER_NAME from the PSGI environment, or -
     %V    HTTP_HOST or SERVER_NAME from the PSGI environment, or -
     %p    SERVER_PORT from the PSGI environment
     %P    the worker's process id
     %m    REQUEST_METHOD from the PSGI environment
     %U    PATH_INFO from the PSGI environment
     %q    QUERY_STRING from the PSGI environment
     %H    SERVER_PROTOCOL from the PSGI environment
  
  Some of these format fields are only supported by middleware that subclasses C<AccessLog>.
  
  In addition, custom values can be referenced, using C<%{name}>,
  with one of the mandatory modifier flags C<i>, C<o> or C<t>:
  
     %{variable-name}i    HTTP_VARIABLE_NAME value from the PSGI environment
     %{header-name}o      header-name header in the response
     %{time-format]t      localtime in the specified strftime format
  
  =item logger
  
    my $logger = Log::Dispatch->new(...);
    enable "Plack::Middleware::AccessLog",
        logger => sub { $logger->log(level => 'debug', message => @_) };
  
  Sets a callback to print log message to. It prints to the C<psgi.errors>
  output stream by default.
  
  =back
  
  =head1 AUTHORS
  
  Tatsuhiko Miyagawa
  
  Masahiro Nagano
  
  =head1 SEE ALSO
  
  L<Apache::LogFormat::Compiler>, L<http://httpd.apache.org/docs/2.2/mod/mod_log_config.html> Rack::CustomLogger
  
  =cut
  
PLACK_MIDDLEWARE_ACCESSLOG

$fatpacked{"Plack/Middleware/AccessLog/Timed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_ACCESSLOG_TIMED';
  package Plack::Middleware::AccessLog::Timed;
  use strict;
  use warnings;
  use parent qw( Plack::Middleware::AccessLog );
  
  use Time::HiRes;
  use Plack::Util;
  
  sub call {
      my $self = shift;
      my($env) = @_;
  
      my $time = Time::HiRes::gettimeofday;
      my $length = 0;
      my $logger = $self->logger || sub { $env->{'psgi.errors'}->print(@_) };
  
      my $res = $self->app->($env);
  
      return $self->response_cb($res, sub {
          my $res = shift;
          my($status, $header, $body) = @$res;
  
          if (!defined $body) {
              my $length;
  
              return sub {
                  my $line = shift;
                  
                  $length += length $line if defined $line;
  
                  unless( defined $line ) {
                      my $now = Time::HiRes::gettimeofday;
                      $logger->( $self->log_line($status, $header, $env, { time => $now - $time, content_length => $length }) );
                  }
  
                  return $line;
              };
          }
  
          my $getline = ref $body eq 'ARRAY' ? sub { shift @$body } : sub { $body->getline };
  
          my $timer_body = Plack::Util::inline_object(
              getline => sub {
                  my $line = $getline->();
                  $length += length $line if defined $line;
                  return $line;
              },
              close => sub {
                  $body->close if ref $body ne 'ARRAY';
  
                  my $now = Time::HiRes::gettimeofday;
                  $logger->( $self->log_line($status, $header, $env, { time => $now - $time, content_length => $length }) );
              },
          );
  
          @$res = ($status, $header, $timer_body);
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::AccessLog::Timed - Logs requests with time and accurate body size
  
  =head1 SYNOPSIS
  
    # in app.psgi
    use Plack::Builder;
  
    builder {
        enable "Plack::Middleware::AccessLog::Timed",
            format => "%v %h %l %u %t \"%r\" %>s %b %D";
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::AccessLog::Timed is a subclass of
  L<Plack::Middleware::AccessLog> but uses a wrapped body handle to get the
  actual response body size C<%b> (even if it's not a chunk of array or
  a real filehandle) and the time taken to serve the request: C<%T> or
  C<%D>.
  
  This wraps the response body output stream to capture the time taken
  for the PSGI server to read the whole response body.
  
  This would mean, if the middleware is in use, it will prevent some
  server-side optimizations like sendfile(2) from working, as well as
  middleware like L<Plack::Middleware::ContentLength> can't guess the
  body size out of the file handle.
  
  If all you want is to capture the time taken in your PSGI application
  and do not want the wrapped body behavior described above, consider instead
  applying L<Plack::Middleware::Runtime> and using L<Plack::Middleware::AccessLog>
  to log the C<X-Runtime> header.
  
  =head1 CONFIGURATION
  
  Same as L<Plack::Middleware::AccessLog>.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Middleware::AccessLog>
  
  L<Plack::Middleware::Runtime>
  
  =cut
PLACK_MIDDLEWARE_ACCESSLOG_TIMED

$fatpacked{"Plack/Middleware/Auth/Basic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_AUTH_BASIC';
  package Plack::Middleware::Auth::Basic;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util::Accessor qw( realm authenticator );
  use Scalar::Util;
  use MIME::Base64;
  
  sub prepare_app {
      my $self = shift;
  
      my $auth = $self->authenticator or die 'authenticator is not set';
      if (Scalar::Util::blessed($auth) && $auth->can('authenticate')) {
          $self->authenticator(sub { $auth->authenticate(@_[0,1]) }); # because Authen::Simple barfs on 3 params
      } elsif (ref $auth ne 'CODE') {
          die 'authenticator should be a code reference or an object that responds to authenticate()';
      }
  }
  
  sub call {
      my($self, $env) = @_;
  
      my $auth = $env->{HTTP_AUTHORIZATION}
          or return $self->unauthorized;
  
      # note the 'i' on the regex, as, according to RFC2617 this is a 
      # "case-insensitive token to identify the authentication scheme"
      if ($auth =~ /^Basic (.*)$/i) {
          my($user, $pass) = split /:/, (MIME::Base64::decode($1) || ":"), 2;
          $pass = '' unless defined $pass;
          if ($self->authenticator->($user, $pass, $env)) {
              $env->{REMOTE_USER} = $user;
              return $self->app->($env);
          }
      }
  
      return $self->unauthorized;
  }
  
  sub unauthorized {
      my $self = shift;
      my $body = 'Authorization required';
      return [
          401,
          [ 'Content-Type' => 'text/plain',
            'Content-Length' => length $body,
            'WWW-Authenticate' => 'Basic realm="' . ($self->realm || "restricted area") . '"' ],
          [ $body ],
      ];
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Auth::Basic - Simple basic authentication middleware
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
    my $app = sub { ... };
  
    builder {
        enable "Auth::Basic", authenticator => \&authen_cb;
        $app;
    };
  
    sub authen_cb {
        my($username, $password, $env) = @_;
        return $username eq 'admin' && $password eq 's3cr3t';
    }
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Auth::Basic is a basic authentication handler for Plack.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item authenticator
  
  A callback function that takes username, password and PSGI environment
  supplied and returns whether the authentication succeeds. Required.
  
  Authenticator can also be an object that responds to C<authenticate>
  method that takes username and password and returns boolean, so
  backends for L<Authen::Simple> is perfect to use:
  
    use Authen::Simple::LDAP;
    enable "Auth::Basic", authenticator => Authen::Simple::LDAP->new(...);
  
  =item realm
  
  Realm name to display in the basic authentication dialog. Defaults to I<restricted area>.
  
  =back
  
  =head1 LIMITATIONS
  
  This middleware expects that the application has a full access to the
  headers sent by clients in PSGI environment. That is normally the case
  with standalone Perl PSGI web servers such as L<Starman> or
  L<HTTP::Server::Simple::PSGI>.
  
  However, in a web server configuration where you can't achieve this
  (i.e. using your application via Apache's mod_cgi), this middleware
  does not work since your application can't know the value of
  C<Authorization:> header.
  
  If you use Apache as a web server and CGI to run your PSGI
  application, you can either a) compile Apache with
  C<-DSECURITY_HOLE_PASS_AUTHORIZATION> option, or b) use mod_rewrite to
  pass the Authorization header to the application with the rewrite rule
  like following.
  
    RewriteEngine on
    RewriteRule .* - [E=HTTP_AUTHORIZATION:%{HTTP:Authorization},L]
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
PLACK_MIDDLEWARE_AUTH_BASIC

$fatpacked{"Plack/Middleware/BufferedStreaming.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_BUFFEREDSTREAMING';
  package Plack::Middleware::BufferedStreaming;
  use strict;
  no warnings;
  use Carp;
  use Plack::Util;
  use Plack::Util::Accessor qw(force);
  use Scalar::Util qw(weaken);
  use parent qw(Plack::Middleware);
  
  sub call {
      my ( $self, $env ) = @_;
  
      my $caller_supports_streaming = $env->{'psgi.streaming'};
      $env->{'psgi.streaming'} = Plack::Util::TRUE;
  
      my $res = $self->app->($env);
      return $res if $caller_supports_streaming && !$self->force;
  
      if ( ref($res) eq 'CODE' ) {
          my $ret;
  
          $res->(sub {
              my $write = shift;
  
              if ( @$write == 2 ) {
                  my @body;
  
                  $ret = [ @$write, \@body ];
  
                  return Plack::Util::inline_object(
                      write => sub { push @body, $_[0] },
                      close => sub { },
                  );
              } else {
                  $ret = $write;
                  return;
              }
          });
  
          return $ret;
      } else {
          return $res;
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::BufferedStreaming - Enable buffering for non-streaming aware servers
  
  =head1 SYNOPSIS
  
    enable "BufferedStreaming";
  
  =head1 DESCRIPTION
  
  Plack::Middleware::BufferedStreaming is a PSGI middleware component
  that wraps the application that uses C<psgi.streaming> interface to
  run on the servers that do not support the interface, by buffering the
  writer output to a temporary buffer.
  
  This middleware doesn't do anything and bypass the application if the
  server supports C<psgi.streaming> interface, unless you set C<force>
  option (see below).
  
  =head1 OPTIONS
  
  =over 4
  
  =item force
  
  Force enable this middleware only if the container supports C<psgi.streaming>.
  
  =back
  
  =head1 AUTHOR
  
  Yuval Kogman
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_MIDDLEWARE_BUFFEREDSTREAMING

$fatpacked{"Plack/Middleware/Chunked.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CHUNKED';
  package Plack::Middleware::Chunked;
  use strict;
  use parent qw(Plack::Middleware);
  
  use Plack::Util;
  
  sub call {
      my($self, $env) = @_;
      my $res = $self->app->($env);
      $self->response_cb($res, sub {
          my $res = shift;
          my $h = Plack::Util::headers($res->[1]);
          if ($env->{'SERVER_PROTOCOL'} ne 'HTTP/1.0' and
              ! Plack::Util::status_with_no_entity_body($res->[0]) and
              ! $h->exists('Content-Length') and
              ! $h->exists('Transfer-Encoding')
          ) {
              $h->set('Transfer-Encoding' => 'chunked');
              my $done;
              return sub {
                  my $chunk = shift;
                  return if $done;
                  unless (defined $chunk) {
                      $done = 1;
                      return "0\015\012\015\012";
                  }
                  return '' unless length $chunk;
                  return sprintf('%x', length $chunk) . "\015\012$chunk\015\012";
              };
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Chunked - Applies chunked encoding to the response body
  
  =head1 SYNOPSIS
  
    # Mostly from server implemenations
    $app = Plack::Middeware::Chunked->wrap($app);
  
  =head1 DESCRIPTION
  
  Plack::Middeware::Chunked is a middleware, or rather a library for
  PSGI server to automatically add chunked encoding to the response body
  when Content-Length is not set in the response header.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  Rack::Chunked
  
  =cut
PLACK_MIDDLEWARE_CHUNKED

$fatpacked{"Plack/Middleware/Conditional.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CONDITIONAL';
  package Plack::Middleware::Conditional;
  use strict;
  use parent qw(Plack::Middleware);
  
  use Plack::Util::Accessor qw( condition middleware builder );
  
  sub prepare_app {
      my $self = shift;
      $self->middleware( $self->builder->($self->app) );
  }
  
  sub call {
      my($self, $env) = @_;
  
      my $app = $self->condition->($env) ? $self->middleware : $self->app;
      return $app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Conditional - Conditional wrapper for Plack middleware
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    builder {
        enable_if { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' } 'StackTrace', force => 1;
        $app;
    };
  
    # or using the OO interface:
    $app = Plack::Middleware::Conditional->wrap(
        $app,
        condition  => sub { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' },
        builder => sub { Plack::Middleware::StackTrace->wrap($_[0], force => 1) },
    );
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Conditional is a piece of meta-middleware, to run a
  specific middleware component under runtime conditions. The goal of
  this middleware is to avoid baking runtime configuration options in
  individual middleware components, and rather share them as another
  middleware component.
  
  =head1 EXAMPLES
  
  Note that some of the middleware component names are just made up for
  the explanation and might not exist.
  
    # Minify JavaScript if the browser is Firefox
    enable_if { $_[0]->{HTTP_USER_AGENT} =~ /Firefox/ } 'JavaScriptMinifier';
  
    # Enable Stacktrace when being accessed from the local network
    enable_if { $_[0]->{REMOTE_ADDR} =~ /^10\.0\.1\.*/ } 'StackTrace';
  
    # Work with other conditional setter middleware:
    # Transcode Jpeg on the fly for mobile clients
    builder {
        enable 'MobileDetector';
        enable_if { $_[0]->{'plack.mobile_detected'} }
          'TranscodeJpeg', max_size => 30_000;
        $app;
    };
  
  Note that in the last example I<MobileDetector> should come first
  because the conditional check runs in I<pre-run> conditions, which is
  from outer to inner: that is, from the top to the bottom in the
  Builder DSL code.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  Steve Cook
  
  =head1 SEE ALSO
  
  L<Plack::Builder>
  
  =cut
PLACK_MIDDLEWARE_CONDITIONAL

$fatpacked{"Plack/Middleware/ConditionalGET.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CONDITIONALGET';
  package Plack::Middleware::ConditionalGET;
  use strict;
  use parent qw( Plack::Middleware );
  use Plack::Util;
  
  sub call {
      my $self = shift;
      my $env  = shift;
  
      my $res = $self->app->($env);
      return $res unless $env->{REQUEST_METHOD} =~ /^(GET|HEAD)$/;
  
      $self->response_cb($res, sub {
          my $res = shift;
  
          my $h = Plack::Util::headers($res->[1]);
          if ( $self->etag_matches($h, $env) || $self->not_modified_since($h, $env) ) {
              $res->[0] = 304;
              $h->remove($_) for qw( Content-Type Content-Length Content-Disposition );
              if ($res->[2]) {
                  $res->[2] = [];
              } else {
                  return sub {
                      return defined $_[0] ? '' : undef;
                  };
              }
          }
      });
  }
  
  no warnings 'uninitialized';
  
  # RFC 2616 14.25 says it's OK and expected to use 'eq' :)
  # > Note: When handling an If-Modified-Since header field, some
  # > servers will use an exact date comparison function, rather than a
  # > less-than function, for deciding whether to send a 304 ...
  
  sub etag_matches {
      my($self, $h, $env) = @_;
      $h->exists('ETag') && $h->get('ETag') eq _value($env->{HTTP_IF_NONE_MATCH});
  }
  
  sub not_modified_since {
      my($self, $h, $env) = @_;
      $h->exists('Last-Modified') && $h->get('Last-Modified') eq _value($env->{HTTP_IF_MODIFIED_SINCE});
  }
  
  sub _value {
      my $str = shift;
      # IE sends wrong formatted value(i.e. "Thu, 03 Dec 2009 01:46:32 GMT; length=17936")
      $str =~ s/;.*$//;
      return $str;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::ConditionalGET - Middleware to enable conditional GET
  
  =head1 SYNOPSIS
  
    builder {
        enable "ConditionalGET";
        ....
    };
  
  =head1 DESCRIPTION
  
  This middleware enables conditional GET and HEAD using
  C<If-None-Match> and C<If-Modified-Since> header. The application
  should set either or both of C<Last-Modified> or C<ETag> response
  headers per RFC 2616. When either of the conditions is met, the
  response body is set to be zero length and the status is set to 304
  Not Modified.
  
  =head1 SEE ALSO
  
  Rack::ConditionalGet
  
  =cut
PLACK_MIDDLEWARE_CONDITIONALGET

$fatpacked{"Plack/Middleware/ContentLength.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CONTENTLENGTH';
  package Plack::Middleware::ContentLength;
  use strict;
  use warnings;
  use parent qw( Plack::Middleware );
  
  use Plack::Util;
  
  sub call {
      my $self = shift;
      my $res  = $self->app->(@_);
  
      return $self->response_cb($res, sub {
          my $res = shift;
          my $h = Plack::Util::headers($res->[1]);
          if (!Plack::Util::status_with_no_entity_body($res->[0]) &&
              !$h->exists('Content-Length') &&
              !$h->exists('Transfer-Encoding') &&
              defined(my $content_length = Plack::Util::content_length($res->[2]))) {
              $h->push('Content-Length' => $content_length);
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::ContentLength - Adds Content-Length header automatically
  
  =head1 SYNOPSIS
  
    # in app.psgi
  
    builder {
        enable "Plack::Middleware::ContentLength";
        $app;
    }
  
    # Or in Plack::Handler::*
    $app = Plack::Middleware::ContentLength->wrap($app);
  
  =head1 DESCRIPTION
  
  Plack::Middleware::ContentLength is a middleware that automatically
  adds C<Content-Length> header when it's appropriate i.e. the response
  has a content body with calculable size (array of chunks or a real
  filehandle).
  
  This middleware can also be used as a library from PSGI server
  implementations to automatically set C<Content-Length> rather than in
  the end user level.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  Rack::ContentLength
  
  =cut
  
PLACK_MIDDLEWARE_CONTENTLENGTH

$fatpacked{"Plack/Middleware/ContentMD5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_CONTENTMD5';
  package Plack::Middleware::ContentMD5;
  
  use strict;
  use warnings;
  use parent qw( Plack::Middleware );
  
  use Plack::Util;
  use Digest::MD5 qw/md5_hex/;
  
  sub call {
      my $self = shift;
      my $res  = $self->app->(@_);
      
      $self->response_cb($res, sub {
          my $res = shift;
  
          return unless defined $res->[2];
          return if (Plack::Util::status_with_no_entity_body($res->[0]));
          
          my $h = Plack::Util::headers($res->[1]);
          return if ( $h->exists('Content-MD5') );
          
          my $body = $res->[2];
          if (ref $body eq 'ARRAY') {
              $h->set('Content-MD5', md5_hex(@$body));
          }
          # Do we need support $fh?
  
          return;
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::ContentMD5 - Automatically sets the Content-MD5 header on all String bodies
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    my $app = sub {
        return [ 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello Foo' ] ];
    };
  
    builder {
        enable "Plack::Middleware::ContentMD5";
        $app;
    };
  
  =head1 DESCRIPTION
  
  Automatically sets the Content-MD5 header on all String bodies
  
  =head1 AUTHOR
  
  Fayland Lam
  
  =cut
PLACK_MIDDLEWARE_CONTENTMD5

$fatpacked{"Plack/Middleware/ErrorDocument.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_ERRORDOCUMENT';
  package Plack::Middleware::ErrorDocument;
  use strict;
  use warnings;
  use parent qw(Plack::Middleware);
  use Plack::MIME;
  use Plack::Util;
  use Plack::Util::Accessor qw( subrequest );
  
  use HTTP::Status qw(is_error);
  
  sub call {
      my $self = shift;
      my $env  = shift;
  
      my $r = $self->app->($env);
  
      $self->response_cb($r, sub {
          my $r = shift;
          unless (is_error($r->[0]) && exists $self->{$r->[0]}) {
              return;
          }
  
          my $path = $self->{$r->[0]};
          if ($self->subrequest) {
              for my $key (keys %$env) {
                  unless ($key =~ /^psgi/) {
                      $env->{'psgix.errordocument.' . $key} = $env->{$key};
                  }
              }
  
              # TODO: What if SCRIPT_NAME is not empty?
              $env->{REQUEST_METHOD} = 'GET';
              $env->{REQUEST_URI}    = $path;
              $env->{PATH_INFO}      = $path;
              $env->{QUERY_STRING}   = '';
              delete $env->{CONTENT_LENGTH};
  
              my $sub_r = $self->app->($env);
              if ($sub_r->[0] == 200) {
                  $r->[1] = $sub_r->[1];
                  if (@$r == 3) {
                      $r->[2] = $sub_r->[2];
                  }
                  else {
                      my $full_sub_response = '';
                      Plack::Util::foreach($sub_r->[2], sub {
                          $full_sub_response .= $_[0];
                      });
  
                      my $returned;
                      return sub {
                          if ($returned) {
                              return defined($_[0]) ? '' : undef;
                          }
                          $returned = 1;
                          return $full_sub_response;
                      }
                  }
              }
              # TODO: allow 302 here?
          } else {
              my $h = Plack::Util::headers($r->[1]);
              $h->remove('Content-Length');
              $h->remove('Content-Encoding');
              $h->remove('Transfer-Encoding');
              $h->set('Content-Type', Plack::MIME->mime_type($path));
  
              open my $fh, "<", $path or die "$path: $!";
              if ($r->[2]) {
                  $r->[2] = $fh;
              } else {
                  my $done;
                  return sub {
                      unless ($done) {
                          $done = 1;
                          return join '', <$fh>;
                      }
                      return defined $_[0] ? '' : undef;
                  };
              };
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::ErrorDocument - Set Error Document based on HTTP status code
  
  =head1 SYNOPSIS
  
    # in app.psgi
    use Plack::Builder;
  
    builder {
        enable "Plack::Middleware::ErrorDocument",
            500 => '/uri/errors/500.html', 404 => '/uri/errors/404.html',
            subrequest => 1;
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::ErrorDocument allows you to customize error screen
  by setting paths (file system path or URI path) of error pages per
  status code.
  
  =head1 CONFIGURATIONS
  
  =over 4
  
  =item subrequest
  
  A boolean flag to serve error pages using a new GET sub request.
  Defaults to false, which means it serves error pages using file
  system path.
  
    builder {
        enable "Plack::Middleware::ErrorDocument",
            502 => '/home/www/htdocs/errors/maint.html';
        enable "Plack::Middleware::ErrorDocument",
            404 => '/static/404.html', 403 => '/static/403.html', subrequest => 1;
        $app;
    };
  
  This configuration serves 502 error pages from file system directly
  assuming that's when you probably maintain database etc. but serves
  404 and 403 pages using a sub request so your application can do some
  logic there like logging or doing suggestions.
  
  When using a subrequest, the subrequest should return a regular '200' response.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  =cut
PLACK_MIDDLEWARE_ERRORDOCUMENT

$fatpacked{"Plack/Middleware/HTTPExceptions.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_HTTPEXCEPTIONS';
  package Plack::Middleware::HTTPExceptions;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util::Accessor qw(rethrow);
  
  use Carp ();
  use Try::Tiny;
  use Scalar::Util 'blessed';
  use HTTP::Status ();
  
  sub prepare_app {
      my $self = shift;
      $self->rethrow(1) if ($ENV{PLACK_ENV} || '') eq 'development';
  }
  
  sub call {
      my($self, $env) = @_;
  
      my $res = try {
          $self->app->($env);
      } catch {
          $self->transform_error($_, $env);
      };
  
      return $res if ref $res eq 'ARRAY';
  
      return sub {
          my $respond = shift;
  
          my $writer;
          try {
              $res->(sub { return $writer = $respond->(@_) });
          } catch {
              if ($writer) {
                  Carp::cluck $_;
                  $writer->close;
              } else {
                  my $res = $self->transform_error($_, $env);
                  $respond->($res);
              }
          };
      };
  }
  
  sub transform_error {
      my($self, $e, $env) = @_;
  
      my($code, $message);
      if (blessed $e && $e->can('as_psgi')) {
          return $e->as_psgi;
      }
      if (blessed $e && $e->can('code')) {
          $code = $e->code;
          $message =
              $e->can('as_string')       ? $e->as_string :
              overload::Method($e, '""') ? "$e"          : undef;
      } else {
          if ($self->rethrow) {
              die $e;
          }
          else {
              $code = 500;
              $env->{'psgi.errors'}->print($e);
          }
      }
  
      if ($code !~ /^[3-5]\d\d$/) {
          die $e; # rethrow
      }
  
      $message ||= HTTP::Status::status_message($code);
  
      my @headers = (
           'Content-Type'   => 'text/plain',
           'Content-Length' => length($message),
      );
  
      if ($code =~ /^3/ && (my $loc = eval { $e->location })) {
          push(@headers, Location => $loc);
      }
  
      return [ $code, \@headers, [ $message ] ];
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::HTTPExceptions - Catch HTTP exceptions
  
  =head1 SYNOPSIS
  
    use HTTP::Exception;
  
    my $app = sub {
        # ...
        HTTP::Exception::500->throw;
    };
  
    builder {
        enable "HTTPExceptions", rethrow => 1;
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::HTTPExceptions is a PSGI middleware component to
  catch exceptions from applications that can be translated into HTTP
  status codes.
  
  Your application is supposed to throw an object that implements a
  C<code> method which returns the HTTP status code, such as 501 or
  404. This middleware catches them and creates a valid response out of
  the code. If the C<code> method returns a code that is not an HTTP
  redirect or error code (3xx, 4xx, or 5xx), the exception will be
  rethrown.
  
  The exception object may also implement C<as_string> or overload
  stringification to represent the text of the error. The text defaults to
  the status message of the error code, such as I<Service Unavailable> for
  C<503>.
  
  Finally, the exception object may implement C<as_psgi>, and the result
  of this will be returned directly as the PSGI response.
  
  If the code is in the 3xx range and the exception implements the 'location'
  method (HTTP::Exception::3xx does), the Location header will be set in the
  response, so you can do redirects this way.
  
  There are CPAN modules L<HTTP::Exception> and L<HTTP::Throwable>, and
  they are perfect to throw from your application to let this middleware
  catch and display, but you can also implement your own exception class
  to throw.
  
  If the thrown exception is not an object that implements either a
  C<code> or an C<as_psgi> method, a 500 error will be returned, and the
  exception is printed to the psgi.errors stream.
  Alternatively, you can pass a true value for the C<rethrow> parameter
  for this middleware, and the exception will instead be rethrown. This is
  enabled by default when C<PLACK_ENV> is set to C<development>, so that
  the L<StackTrace|Plack::Middleware::StackTrace> middleware can catch it
  instead.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  paste.httpexceptions L<HTTP::Exception> L<HTTP::Throwable>
  
  =cut
PLACK_MIDDLEWARE_HTTPEXCEPTIONS

$fatpacked{"Plack/Middleware/Head.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_HEAD';
  package Plack::Middleware::Head;
  use strict;
  use warnings;
  use parent qw(Plack::Middleware);
  
  sub call {
      my($self, $env) = @_;
  
      return $self->app->($env)
          unless $env->{REQUEST_METHOD} eq 'HEAD';
  
      $self->response_cb($self->app->($env), sub {
          my $res = shift;
          if ($res->[2]) {
              $res->[2] = [];
          } else {
              return sub {
                  return defined $_[0] ? '': undef;
              };
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Head - auto delete response body in HEAD requests
  
  =head1 SYNOPSIS
  
    enable "Head";
  
  =head1 DESCRIPTION
  
  This middleware deletes response body in HEAD requests.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  Rack::Head
  
  =cut
  
PLACK_MIDDLEWARE_HEAD

$fatpacked{"Plack/Middleware/IIS6ScriptNameFix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_IIS6SCRIPTNAMEFIX';
  package Plack::Middleware::IIS6ScriptNameFix;
  
  use strict;
  use parent 'Plack::Middleware';
  
  sub call {
      my($self, $env) = @_;
  
      if ($env->{SERVER_SOFTWARE} && $env->{SERVER_SOFTWARE} =~ /IIS\/[6-9]\.[0-9]/) {
          my @script_name = split(m!/!, $env->{PATH_INFO});
          my @path_translated = split(m!/|\\\\?!, $env->{PATH_TRANSLATED});
          my @path_info;
  
          while ($script_name[$#script_name] eq $path_translated[$#path_translated]) {
              pop(@path_translated);
              unshift(@path_info, pop(@script_name));
          }
  
          unshift(@path_info, '', '');
  
          $env->{PATH_INFO} = join('/', @path_info);
          $env->{SCRIPT_NAME} = join('/', @script_name);
      }
  
      return $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::IIS6ScriptNameFix - fixes wrong SCRIPT_NAME and PATH_INFO that IIS6 sets
  
  =head1 SYNOPSIS
  
    # in your app.psgi
    use Plack::Builder;
  
    builder {
      enable "IIS6ScriptNameFix";
      $app;
    };
  
    # Or from the command line
    plackup -s FCGI -e 'enable "IIS6ScriptNameFix"' /path/to/app.psgi
  
  =head1 DESCRIPTION
  
  This middleware fixes wrong C<SCRIPT_NAME> and C<PATH_INFO> set by IIS6.
  
  =head1 AUTHORS
  
  Florian Ragwitz
  
  =cut
PLACK_MIDDLEWARE_IIS6SCRIPTNAMEFIX

$fatpacked{"Plack/Middleware/IIS7KeepAliveFix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_IIS7KEEPALIVEFIX';
  package Plack::Middleware::IIS7KeepAliveFix;
  
  use strict;
  use parent 'Plack::Middleware';
  use Plack::Util;
  
  sub call {
      my($self, $env) = @_;
          # Fixes buffer being cut off on redirect when keep-alive is active
          my $res  = $self->app->($env);
  
          Plack::Util::response_cb($res, sub {
              my $res = shift;
              if ($res->[0] =~ m!^30[123]$! ) {
                  Plack::Util::header_remove($res->[1], 'Content-Length');
                  Plack::Util::header_remove($res->[1], 'Content-Type');
                 return sub{ my $chunk; return unless defined $chunk; return ''; };
              }
  
              return;
          });
  
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Middleware::IIS7KeepAliveFix - fixes buffer being cut off on redirect when keep-alive is active on IIS.
  
  =head1 SYNOPSIS
  
    # in your app.psgi
    use Plack::Builder;
  
    builder {
      enable "IIS7KeepAliveFix";
      $app;
    };
  
    # Or from the command line
    plackup -s FCGI -e 'enable "IIS7KeepAliveFix"' /path/to/app.psgi
  
  =head1 DESCRIPTION
  
  This middleware fixes buffer being cut off on redirect when keep-alive is active on IIS7.
  
  =head1 AUTHORS
  
  KnowZeroX
  
  =cut
  
PLACK_MIDDLEWARE_IIS7KEEPALIVEFIX

$fatpacked{"Plack/Middleware/JSONP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_JSONP';
  package Plack::Middleware::JSONP;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util;
  use URI::Escape ();
  
  use Plack::Util::Accessor qw/callback_key/;
  
  sub prepare_app {
      my $self = shift;
      unless (defined $self->callback_key) {
          $self->callback_key('callback');
      }
  }
  
  sub call {
      my($self, $env) = @_;
      my $res = $self->app->($env);
      $self->response_cb($res, sub {
          my $res = shift;
          if (defined $res->[2]) {
              my $h = Plack::Util::headers($res->[1]);
              my $callback_key = $self->callback_key;
              if ($h->get('Content-Type') =~ m!/(?:json|javascript)! &&
                  $env->{QUERY_STRING} =~ /(?:^|&)$callback_key=([^&]+)/) {
                  my $cb = URI::Escape::uri_unescape($1);
                  if ($cb =~ /^[\w\.\[\]]+$/) {
                      my $body;
                      Plack::Util::foreach($res->[2], sub { $body .= $_[0] });
                      my $jsonp = "/**/$cb($body)";
                      $res->[2] = [ $jsonp ];
                      $h->set('Content-Length', length $jsonp);
                      $h->set('Content-Type', 'text/javascript');
                  }
              }
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::JSONP - Wraps JSON response in JSONP if callback parameter is specified
  
  =head1 SYNOPSIS
  
      enable "JSONP", callback_key => 'jsonp';
  
  =head1 DESCRIPTION
  
  Plack::Middleware::JSONP wraps JSON response, which has Content-Type
  value either C<text/javascript> or C<application/json> as a JSONP
  response which is specified with the C<callback> query parameter. The
  name of the parameter can be set while enabling the middleware.
  
  This middleware only works with a non-streaming response, and doesn't
  touch the response otherwise.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
  
PLACK_MIDDLEWARE_JSONP

$fatpacked{"Plack/Middleware/LighttpdScriptNameFix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_LIGHTTPDSCRIPTNAMEFIX';
  package Plack::Middleware::LighttpdScriptNameFix;
  use strict;
  use parent qw/Plack::Middleware/;
  use Plack::Util::Accessor qw(script_name);
  
  sub prepare_app {
      my $self = shift;
  
      my $script_name = $self->script_name;
      $script_name = '' unless defined($script_name);
      $script_name =~ s!/$!!;
      $self->script_name($script_name);
  }
  
  sub call {
      my($self, $env) = @_;
  
      if ($env->{SERVER_SOFTWARE} && $env->{SERVER_SOFTWARE} =~ /lighttpd/) {
          $env->{PATH_INFO}   = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
          $env->{SCRIPT_NAME} = $self->script_name;
          $env->{PATH_INFO}  =~ s/^\Q$env->{SCRIPT_NAME}\E//;
      }
  
      return $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::LighttpdScriptNameFix - fixes wrong SCRIPT_NAME and PATH_INFO that lighttpd sets
  
  =head1 SYNOPSIS
  
    # in your app.psgi
    use Plack::Builder;
  
    builder {
      enable "LighttpdScriptNameFix";
      $app;
    };
  
    # Or from the command line
    plackup -s FCGI -e 'enable "LighttpdScriptNameFix"' /path/to/app.psgi
  
  =head1 DESCRIPTION
  
  This middleware fixes wrong C<SCRIPT_NAME> and C<PATH_INFO> set by
  lighttpd when you mount your app under the root path ("/"). If you use
  lighttpd 1.4.23 or later you can instead enable C<fix-root-scriptname>
  flag inside C<fastcgi.server> instead of using this middleware.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item script_name
  
  Even with C<fix-root-scriptname>, lighttpd I<still> sets weird
  C<SCRIPT_NAME> and C<PATH_INFO> if you mount your application at C<"">
  or something that ends with C</>. Setting C<script_name> option tells
  the middleware how to reconstruct the new correct C<SCRIPT_NAME> and
  C<PATH_INFO>.
  
  If you mount the app under C</something/>, you should set:
  
    enable "LighttpdScriptNameFix", script_name => "/something";
  
  and when a request for C</something/a/b?param=1> comes, C<SCRIPT_NAME>
  becomes C</something> and C<PATH_INFO> becomes C</a/b>.
  
  C<script_name> option is set to empty by default, which means all the
  request path is set to C<PATH_INFO> and it behaves like your fastcgi
  application is mounted in the root path.
  
  =back
  
  =head1 AUTHORS
  
  Yury Zavarin
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Handler::FCGI>
  L<http://github.com/plack/Plack/issues#issue/68>
  L<https://redmine.lighttpd.net/issues/729>
  
  =cut
  
PLACK_MIDDLEWARE_LIGHTTPDSCRIPTNAMEFIX

$fatpacked{"Plack/Middleware/Lint.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_LINT';
  package Plack::Middleware::Lint;
  use strict;
  no warnings;
  use Carp ();
  use parent qw(Plack::Middleware);
  use Scalar::Util qw(blessed);
  use Plack::Util;
  
  sub wrap {
      my($self, $app) = @_;
  
      unless (ref $app eq 'CODE' or overload::Method($app, '&{}')) {
          die("PSGI app should be a code reference: ", (defined $app ? $app : "undef"));
      }
  
      $self->SUPER::wrap($app);
  }
  
  sub call {
      my $self = shift;
      my $env = shift;
  
      $self->validate_env($env);
      my $res = $self->app->($env);
      return $self->validate_res($res);
  }
  
  sub validate_env {
      my ($self, $env) = @_;
      unless ($env->{REQUEST_METHOD}) {
          die('Missing env param: REQUEST_METHOD');
      }
      unless ($env->{REQUEST_METHOD} =~ /^[A-Z]+$/) {
          die("Invalid env param: REQUEST_METHOD($env->{REQUEST_METHOD})");
      }
      unless (defined($env->{SCRIPT_NAME})) { # allows empty string
          die('Missing mandatory env param: SCRIPT_NAME');
      }
      if ($env->{SCRIPT_NAME} eq '/') {
          die('SCRIPT_NAME must not be /');
      }
      unless (defined($env->{PATH_INFO})) { # allows empty string
          die('Missing mandatory env param: PATH_INFO');
      }
      if ($env->{PATH_INFO} ne '' && $env->{PATH_INFO} !~ m!^/!) {
          die('PATH_INFO must begin with / ($env->{PATH_INFO})');
      }
      unless (defined($env->{SERVER_NAME})) {
          die('Missing mandatory env param: SERVER_NAME');
      }
      if ($env->{SERVER_NAME} eq '') {
          die('SERVER_NAME must not be empty string');
      }
      unless (defined($env->{SERVER_PORT})) {
          die('Missing mandatory env param: SERVER_PORT');
      }
      if ($env->{SERVER_PORT} eq '') {
          die('SERVER_PORT must not be empty string');
      }
      if (defined($env->{SERVER_PROTOCOL}) and $env->{SERVER_PROTOCOL} !~ m{^HTTP/1.\d$}) {
          die("Invalid SERVER_PROTOCOL: $env->{SERVER_PROTOCOL}");
      }
      for my $param (qw/version url_scheme input errors multithread multiprocess/) {
          unless (exists $env->{"psgi.$param"}) {
              die("Missing psgi.$param");
          }
      }
      unless (ref($env->{'psgi.version'}) eq 'ARRAY') {
          die("psgi.version should be ArrayRef: $env->{'psgi.version'}");
      }
      unless (scalar(@{$env->{'psgi.version'}}) == 2) {
          die('psgi.version should contain 2 elements, not ', scalar(@{$env->{'psgi.version'}}));
      }
      unless ($env->{'psgi.url_scheme'} =~ /^https?$/) {
          die("psgi.url_scheme should be 'http' or 'https': ", $env->{'psgi.url_scheme'});
      }
      if ($env->{"psgi.version"}->[1] == 1) { # 1.1
          for my $param (qw(streaming nonblocking run_once)) {
              unless (exists $env->{"psgi.$param"}) {
                  die("Missing psgi.$param");
              }
          }
      }
      if ($env->{HTTP_CONTENT_TYPE}) {
          die('HTTP_CONTENT_TYPE should not exist');
      }
      if ($env->{HTTP_CONTENT_LENGTH}) {
          die('HTTP_CONTENT_LENGTH should not exist');
      }
  }
  
  sub is_possibly_fh {
      my $fh = shift;
  
      ref $fh eq 'GLOB' &&
      *{$fh}{IO} &&
      *{$fh}{IO}->can('getline');
  }
  
  sub validate_res {
      my ($self, $res, $streaming) = @_;
  
      unless (ref($res) eq 'ARRAY' or ref($res) eq 'CODE') {
          die("Response should be array ref or code ref: $res");
      }
  
      if (ref $res eq 'CODE') {
          return $self->response_cb($res, sub { $self->validate_res(@_, 1) });
      }
  
      unless (@$res == 3 || ($streaming && @$res == 2)) {
          die('Response needs to be 3 element array, or 2 element in streaming');
      }
  
      unless ($res->[0] =~ /^\d+$/ && $res->[0] >= 100) {
          die("Status code needs to be an integer greater than or equal to 100: $res->[0]");
      }
  
      unless (ref $res->[1] eq 'ARRAY') {
          die("Headers needs to be an array ref: $res->[1]");
      }
  
      my @copy = @{$res->[1]};
      unless (@copy % 2 == 0) {
          die('The number of response headers needs to be even, not odd(', scalar(@copy), ')');
      }
  
      while(my($key, $val) = splice(@copy, 0, 2)) {
          if (lc $key eq 'status') {
              die('Response headers MUST NOT contain a key named Status');
          }
          if ($key =~ /[:\r\n]|[-_]$/) {
              die("Response headers MUST NOT contain a key with : or newlines, or that end in - or _: $key");
          }
          unless ($key =~ /^[a-zA-Z][0-9a-zA-Z\-_]*$/) {
              die("Response headers MUST consist only of letters, digits, _ or - and MUST start with a letter: $key");
          }
          if ($val =~ /[\000-\037]/) {
              die("Response headers MUST NOT contain characters below octal \037: $val");
          }
          if (!defined $val) {
              die("Response headers MUST be a defined string");
          }
      }
  
      # @$res == 2 is only right in psgi.streaming, and it's already checked.
      unless (@$res == 2 ||
              ref $res->[2] eq 'ARRAY' ||
              Plack::Util::is_real_fh($res->[2]) ||
              is_possibly_fh($res->[2]) ||
              (blessed($res->[2]) && $res->[2]->can('getline'))) {
          die("Body should be an array ref or filehandle: $res->[2]");
      }
  
      if (ref $res->[2] eq 'ARRAY' && grep _has_wide_char($_), @{$res->[2]}) {
          die("Body must be bytes and should not contain wide characters (UTF-8 strings)");
      }
  
      return $res;
  }
  
  # NOTE: Some modules like HTML:: or XML:: could possibly generate
  # ASCII/Latin-1 strings with utf8 flags on. They're actually safe to
  # print, so there's no need to give warnings about it.
  sub _has_wide_char {
      my $str = shift;
      utf8::is_utf8($str) && $str =~ /[^\x00-\xff]/;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Lint - Validate request and response
  
  =head1 SYNOPSIS
  
    use Plack::Middleware::Lint;
  
    my $app = sub { ... }; # your app or middleware
    $app = Plack::Middleware::Lint->wrap($app);
  
    # Or from plackup
    plackup -e 'enable "Lint"' myapp.psgi
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Lint is a middleware component to validate request
  and response environment formats. You are strongly suggested to use
  this middleware when you develop a new framework adapter or a new PSGI
  web server that implements the PSGI interface.
  
  This middleware is enabled by default when you run plackup or other
  launcher tools with the default environment I<development> value.
  
  =head1 DEBUGGING
  
  Because of how this middleware works, it may not be easy to debug Lint
  errors when you encounter one, unless you're writing a PSGI web server
  or a framework.
  
  For example, when you're an application developer (user of some
  framework) and see errors like:
  
    Body should be an array ref or filehandle at lib/Plack/Middleware/Lint.pm line XXXX
  
  there's no clue about which line of I<your application> produces that
  error.
  
  We're aware of the issue, and have a plan to spit out more helpful
  errors to diagnose the issue. But until then, currently there are some
  workarounds to make this easier. For now, the easiest one would be to
  enable L<Plack::Middleware::REPL> outside of the Lint middleware,
  like:
  
    plackup -e 'enable "REPL"; enable "Lint"' app.psgi
  
  so that the Lint errors are caught by the REPL shell, where you can
  inspect all the variables in the response.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  Tokuhiro Matsuno
  
  =head1 SEE ALSO
  
  L<Plack>
  
  =cut
  
PLACK_MIDDLEWARE_LINT

$fatpacked{"Plack/Middleware/Log4perl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_LOG4PERL';
  package Plack::Middleware::Log4perl;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util::Accessor qw(category logger conf);
  use Carp ();
  
  sub prepare_app {
      my $self = shift;
  
      if ($self->conf) {
          require Log::Log4perl;
          Log::Log4perl::init($self->conf);
      }
  
      $self->logger( Log::Log4perl->get_logger($self->category || '') );
  }
  
  sub call {
      my($self, $env) = @_;
  
      $env->{'psgix.logger'} = sub {
          my $args = shift;
          my $level = $args->{level};
          local $Log::Log4perl::caller_depth
              = $Log::Log4perl::caller_depth + 1;
          $self->logger->$level($args->{message});
      };
  
      $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Log4perl - Uses Log::Log4perl to configure logger
  
  =head1 SYNOPSIS
  
    use Log::Log4perl;
  
    Log::Log4perl::init('/path/to/log4perl.conf');
  
    builder {
        enable "Log4perl", category => "plack";
        $app;
    }
  
    # in log4perl.conf
    log4perl.logger.plack = INFO, Logfile
    log4perl.appender.Logfile = Log::Log4perl::Appender::File
    log4perl.appender.Logfile.filename = /path/to/logfile.log
    log4perl.appender.Logfile.layout   = Log::Log4perl::Layout::SimpleLayout
  
    # Or let middleware to configure log4perl
    enable "Log4perl", category => "plack", conf => '/path/to/log.conf';
  
  =head1 DESCRIPTION
  
  Log4perl is a L<Plack::Middleware> component that allows you to use
  L<Log::Log4perl> to configure the logging object, C<psgix.logger>.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item category
  
  The C<log4perl> category to send logs to. Defaults to C<''> which means
  it send to the root logger.
  
  =item conf
  
  The configuration file path (or a scalar ref containing the config
  string) for L<Log::Log4perl> to automatically configure.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Log::Log4perl>
  
  L<Plack::Middleware::LogDispatch>
  
  =cut
  
PLACK_MIDDLEWARE_LOG4PERL

$fatpacked{"Plack/Middleware/LogDispatch.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_LOGDISPATCH';
  package Plack::Middleware::LogDispatch;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util::Accessor qw(logger);
  use Carp ();
  
  sub prepare_app {
      my $self = shift;
      unless ($self->logger) {
          Carp::croak "logger is not defined";
      }
  }
  
  sub call {
      my($self, $env) = @_;
  
      $env->{'psgix.logger'} = sub {
          my $args = shift;
          $args->{level} = 'critical' if $args->{level} eq 'fatal';
  
          if ( ref $args->{message} && ref $args->{message} ne 'CODE' ) {
              $args->{message} .= q{};
          }
  
          $self->logger->log(%$args);
      };
  
      $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::LogDispatch - Uses Log::Dispatch to configure logger
  
  =head1 SYNOPSIS
  
    use Log::Dispatch;
  
    my $logger = Log::Dispatch->new;
    $logger->add( Log::Dispatch::File->new(...) );
    $logger->add( Log::Dispatch::DesktopNotification->new(...) );
  
    builder {
        enable "LogDispatch", logger => $logger;
        $app;
    }
  
    # use with Log::Dispatch::Config
    use Log::Dispatch::Config;
    Log::Dispatch::Config->configure('/path/to/log.conf');
  
    builder {
        enable "LogDispatch", logger => Log::Dispatch::Config->instance;
        ...
    }
  
  =head1 DESCRIPTION
  
  LogDispatch is a L<Plack::Middleware> component that allows you to use
  L<Log::Dispatch> to configure the logging object, C<psgix.logger>.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item logger
  
  L<Log::Dispatch> object to send logs to. Required.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Log::Dispatch>
  
  L<Plack::Middleware::Log4perl>
  
  =cut
  
PLACK_MIDDLEWARE_LOGDISPATCH

$fatpacked{"Plack/Middleware/NullLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_NULLLOGGER';
  package Plack::Middleware::NullLogger;
  use strict;
  use parent qw/Plack::Middleware/;
  
  sub call {
      my($self, $env) = @_;
      $env->{'psgix.logger'} = sub { };
      $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::NullLogger - Send logs to /dev/null
  
  =head1 SYNOPSIS
  
    enable "NullLogger";
  
  =head1 DESCRIPTION
  
  NullLogger is a middleware component that receives logs and does
  nothing but discarding them. Might be useful to shut up all the logs
  from frameworks in one shot.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_MIDDLEWARE_NULLLOGGER

$fatpacked{"Plack/Middleware/Proxy/AddVia.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_ADDVIA';
  package Plack::Middleware::Proxy::AddVia;
  use strict;
  use parent 'Plack::Middleware';
  
  use Plack::Util;
  
  our $VERSION = '0.01';
  
  sub add_via {
      my ( $self, $via, $protocol, $recieved_by ) = @_;
  
      $protocol =~ s|^HTTP/||;
      return join ', ', $via || (), "$protocol $recieved_by";
  }
  
  sub make_recieved_by_from_env {
      my ( $self, $env ) = @_;
      my $host = $env->{SERVER_NAME} . (
          $env->{SERVER_PORT} == 80 ? '' : ":$env->{SERVER_PORT}"
      ) ;
      return  $host . " (" . __PACKAGE__ . "/$VERSION)";
  }
  
  sub call {
      my($self, $env) = @_;
  
      my $recieved_by = $self->make_recieved_by_from_env( $env );
  
      $env->{HTTP_VIA} = $self->add_via( 
          $env->{HTTP_VIA}, $env->{SERVER_PROTOCOL}, $recieved_by
      );
  
      return sub {
          my $orig_respond = shift;
  
          my $respond = sub {
              my $res = shift;
              my $via = Plack::Util::header_get($res->[1], 'Via');
              Plack::Util::header_set(
                  $res->[1], 'Via' => $self->add_via(
                      $via, $env->{'plack.proxy.last_protocol'}, $recieved_by
                  )
              );
              return $orig_respond->( $res );
          };
  
          my $res = $self->app->($env);
          ref $res eq 'CODE' ? $res->( $respond ) : $respond->( $res );
      };
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Proxy::AddVia - Adds the Via header for the current host.
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
        enable "Proxy::AddVia";
        Plack::App::Proxy->new(host => "http://10.0.1.2:8080/")->to_app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Proxy::AddVia adds the C<Via> header to the request and 
  response, like mod_proxy's C<ProxyVia> option.
  
  =head1 AUTHOR
  
  Masahiro Honma E<lt>hiratara@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Plack::App::Proxy>
  
  =cut
PLACK_MIDDLEWARE_PROXY_ADDVIA

$fatpacked{"Plack/Middleware/Proxy/Connect.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_CONNECT';
  package Plack::Middleware::Proxy::Connect;
  use strict;
  use warnings;
  use parent 'Plack::Middleware';
  
  use AnyEvent::Socket;
  use AnyEvent::Handle;
  
  our $VERSION = '0.01';
  
  sub call {
      my($self, $env) = @_;
      return $self->app->( $env ) unless $env->{ REQUEST_METHOD } eq 'CONNECT';
  
      my $client_fh = $env->{'psgix.io'}
                        or return [ 501, [], ['Not implemented CONNECT method']];
      my ( $host, $port ) =
                       ( $env->{REQUEST_URI} =~ m{^(?:.+\@)?(.+?)(?::(\d+))?$} );
  
      sub {
          my $respond = shift;
  
          # Run the loop by myself when psgi.nonblocking is turend off.
          my $cv = $env->{'psgi.nonblocking'} ? undef : AE::cv;
  
          tcp_connect $host, $port, sub {
              my ( $origin_fh ) = @_;
              unless( $origin_fh ){
                  $respond->( [ 502, [], ['Bad Gateway'] ] );
                  $cv->send if $cv;
                  return;
              }
  
              my $writer = $respond->( [ 200, [] ] );
  
              my $client_hdl = AnyEvent::Handle->new( fh => $client_fh );
              my $origin_hdl = AnyEvent::Handle->new( fh => $origin_fh );
  
              # Join 2 handles by a tunnel
              $client_hdl->on_read(sub {
                  my $hdl = shift;
                  my $rbuf = delete $hdl->{rbuf};
                  $origin_hdl->push_write( $rbuf );
              } );
              $client_hdl->on_error( sub {
                  my ( $hdl, $fatal, $message ) = @_;
                  $! and warn "error($fatal): $message\n";
                  $origin_hdl->push_shutdown;
                  # Finish this request.
                  $writer->close;
                  $cv->send if $cv;
                  # Use $client_hdl to keep the handle by a cyclical reference.
                  $client_hdl->destroy;
              } );
  
              $origin_hdl->on_read(sub {
                  my $hdl = shift;
                  my $rbuf = delete $hdl->{rbuf};
                  $client_hdl->push_write( $rbuf );
              } );
              $origin_hdl->on_error( sub {
                  my ( $hdl, $fatal, $message ) = @_;
                  $! and warn "error($fatal): $message\n";
                  $client_hdl->push_shutdown;
                  # Use $origin_hdl to keep the handle by a cyclical reference.
                  $origin_hdl->destroy;
              } );
          };
  
          $cv->recv if $cv;
      };
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Proxy::Connect - Handles the CONNECT method.
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
        enable "Proxy::Connect";
        enable sub {
            my $app = shift;
            return sub {
                my $env = shift;
                ($env->{'plack.proxy.url'} = $env->{REQUEST_URI}) =~ s|^/||;
                $app->( $env );
            };
        };
        Plack::App::Proxy->new->to_app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Proxy::Connect handles the C<CONNECT> method,
  like mod_proxy's C<AllowCONNECT> option.
  
  Plack::Middleware::Proxy::Connect runs on servers supporting I<psgix.io>;
  Twiggy, Plack::Server::Coro, and so on.
  
  =head1 AUTHOR
  
  Masahiro Honma E<lt>hiratara@cpan.orgE<gt>
  
  =head1 SEE ALSO
  
  L<Plack::App::Proxy>
  
  =cut
  
PLACK_MIDDLEWARE_PROXY_CONNECT

$fatpacked{"Plack/Middleware/Proxy/Connect/IO.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_CONNECT_IO';
  package Plack::Middleware::Proxy::Connect::IO;
  
  =head1 NAME
  
  Plack::Middleware::Proxy::Connect::IO - CONNECT method
  
  =head1 SYNOPSIS
  
    # In app.psgi
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
        enable "Proxy::Connect::IO";
        enable "Proxy::Requests";
        Plack::App::Proxy->new->to_app;
    };
  
  =head1 DESCRIPTION
  
  This middleware handles the C<CONNECT> method. It allows to connect to
  C<https> addresses.
  
  The middleware runs on servers supporting C<psgix.io> and provides own
  event loop so does not work correctly with C<psgi.nonblocking> servers.
  
  The middleware uses only Perl's core modules: L<IO::Socket::INET> and
  L<IO::Select>.
  
  =for readme stop
  
  =cut
  
  
  use 5.006;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0100';
  
  
  use parent qw(Plack::Middleware);
  
  use IO::Socket::INET;
  use IO::Select;
  
  
  use constant CHUNKSIZE => 64 * 1024;
  
  
  sub call {
      my ($self, $env) = @_;
  
      return $self->app->($env) unless $env->{REQUEST_METHOD} eq 'CONNECT';
  
      my $client = $env->{'psgix.io'}
          or return [501, [], ['Not implemented CONNECT method']];
  
      my ($host, $port) = $env->{REQUEST_URI} =~ m{^(?:.+\@)?(.+?)(?::(\d+))?$};
  
      my $ioset = IO::Select->new;
  
      sub {
          my ($respond) = @_;
  
          my $remote = IO::Socket::INET->new(
              PeerAddr => $host,
              PeerPort => $port
          ) or return $respond->([502, [], ['Bad Gateway']]);
  
          my $writer = $respond->([200, []]);
  
          $ioset->add($client);
          $ioset->add($remote);
  
          while (1) {
              for my $socket ($ioset->can_read) {
                  my $buffer;
  
                  my $socket2 = do {
                      if ($socket == $remote) {
                          $client;
                      } elsif ($socket == $client) {
                          $remote;
                      }
                  } or return $respond->([502, [], ['Bad Gateway']]);
  
                  my $read = $socket->sysread($buffer, CHUNKSIZE);
  
                  if ($read) {
                      $socket2->syswrite($buffer);
                  } else {
                      $remote->close;
                      $client->close;
                      return;
                  }
              }
          }
  
      };
  }
  
  
  1;
  
  
  =for readme continue
  
  =head1 SEE ALSO
  
  L<Plack>, L<Plack::App::Proxy>, L<Plack::Middleware::Proxy::Connect>.
  
  =head1 BUGS
  
  If you find the bug or want to implement new features, please report it at
  L<https://github.com/dex4er/perl-Plack-Middleware-Proxy-Connect-IO/issues>
  
  The code repository is available at
  L<http://github.com/dex4er/perl-Plack-Middleware-Proxy-Connect-IO>
  
  =head1 AUTHOR
  
  Piotr Roszatycki <dexter@cpan.org>
  
  =head1 LICENSE
  
  Copyright (c) 2014 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
PLACK_MIDDLEWARE_PROXY_CONNECT_IO

$fatpacked{"Plack/Middleware/Proxy/LoadBalancer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_LOADBALANCER';
  package Plack::Middleware::Proxy::LoadBalancer;
  use strict;
  use warnings;
  use parent 'Plack::Middleware';
  
  use Plack::Util::Accessor qw/backends/;
  
  our $VERSION = '0.01';
  
  sub new {
      my $class = shift;
      my %param = ref $_[0] ? %{ $_[0] } : @_;
  
      my $backends = delete $param{backends};
  
      my $self = $class->SUPER::new( \%param );
      $self->_set_backends( $backends );
  
      $self;
  }
  
  sub _set_backends{
      my $self = shift;
      my ( $backends ) = @_;
  
      # A total of 'weight' should be 1.0
      if( ref $backends eq 'ARRAY'){
          my $weight = 1 / @$backends;
          $self->backends([
              map { {remote => $_, weight => $weight} } @$backends
          ]);
      }elsif( ref $backends eq 'HASH'){
          my $total = 0;
          $total += $_ for values %$backends;
          $self->backends([ map { 
              {remote => $_, weight => $backends->{$_} / $total}
          } keys %$backends ]);
      }else{
          $self->backends([ { remote => $backends, weight => 1 } ]);
      }
  }
  
  sub select_backend {
      my $self = shift;
      my $rand = rand;
  
      my $choice = undef;
      for( @{ $self->backends } ){
          $choice = $_->{remote};
          ($rand -= $_->{weight}) <= 0 and last;
      }
  
      return $choice;
  }
  
  sub call {
      my ( $self, $env ) = @_;
      $env->{'plack.proxy.remote'} = $self->select_backend;
      $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Proxy::LoadBalancer - Simple load balancer
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
      enable "Proxy::LoadBalancer", backends => ['http://10.0.0.1:8080', 'http://10.0.0.1:8081'];
      Plack::App::Proxy->new()->to_app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Proxy::LoadBalancer allow you to define several backends.
  
  =head1 OPTIONS
  
  =over 4
  
  =item backends
  
    enable "Proxy::LoadBalancer", backends => 'http://10.0.0.1:8080';
  
  Or
  
    enable "Proxy::LoadBalancer", backends => ['http://10.0.0.1:8080', 'http://10.0.0.1:8081'];
  
  Or
  
    enable "Proxy::LoadBalancer", backends => {'http://10.0.0.1:8080' => 0.4, 'http://10.0.0.1:8081' => 0.5, 'http://10.0.0.1:8002' => 0.3};
  
  More than one backend can be defined. Weight can be given to backends.
  
  =back
  
  =head1 AUTHOR
  
  Franck Cuny
  
  =head1 SEE ALSO
  
  L<Plack::App::Proxy>
  
  =cut
  
  
PLACK_MIDDLEWARE_PROXY_LOADBALANCER

$fatpacked{"Plack/Middleware/Proxy/Requests.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_REQUESTS';
  package Plack::Middleware::Proxy::Requests;
  
  =head1 NAME
  
  Plack::Middleware::Proxy::Requests - Forward proxy server
  
  =head1 SYNOPSIS
  
    # In app.psgi
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
        enable "Proxy::Connect";
        enable "Proxy::AddVia";
        enable "Proxy::Requests";
        Plack::App::Proxy->new->to_app;
    };
  
    # From shell
    plackup -s Twiggy -E Proxy -e 'enable q{AccessLog}' app.psgi
  
    # or
    twiggy -MPlack::App::Proxy \
           -e 'enable q{AccessLog}; enable q{Proxy::Connect}; \
               enable q{Proxy::AddVia}; enable q{Proxy::Requests}; \
               Plack::App::Proxy->new->to_app'
  
  =head1 DESCRIPTION
  
  This module handles HTTP requests as a forward proxy server.
  
  Its job is to set a C<plack.proxy.url> environment variable based on
  C<REQUEST_URI> variable.
  
  The HTTP responses from the Internet might be invalid. In that case it
  is required to run the server without L<Plack::Middleware::Lint> module.
  This module is started by default and disabled if C<-E> or
  C<--no-default-middleware> option is used when starting L<plackup>
  script. Note that this disable also L<Plack::Middleware::AccessLog> so
  it have to be enabled explicitly if needed.
  
  The default server L<Plack::Server::PSGI> alias C<Standalone> can hang
  up on stalled connection. It is better to run proxy server with
  L<Starlet>, L<Starman> or L<Twiggy>.
  
  =for readme stop
  
  =cut
  
  
  use 5.006;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0102';
  
  
  use parent qw(Plack::Middleware);
  
  
  sub call {
      my ($self, $env) = @_;
  
      $env->{'plack.proxy.url'} = $env->{REQUEST_URI};
  
      return $self->app->($env);
  };
  
  
  1;
  
  
  =for readme continue
  
  =head1 SEE ALSO
  
  L<Plack>, L<Plack::App::Proxy>, L<Plack::Middleware::Proxy::Connect>,
  L<Plack::Middleware::Proxy::AddVia>, L<Starlet>, L<Starman>, L<Twiggy>.
  
  =head1 BUGS
  
  If you find the bug or want to implement new features, please report it at
  L<https://github.com/dex4er/perl-Plack-Middleware-Proxy-Requests/issues>
  
  The code repository is available at
  L<http://github.com/dex4er/perl-Plack-Middleware-Proxy-Requests>
  
  =head1 AUTHOR
  
  Piotr Roszatycki <dexter@cpan.org>
  
  =head1 LICENSE
  
  Copyright (c) 2012-2013 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
PLACK_MIDDLEWARE_PROXY_REQUESTS

$fatpacked{"Plack/Middleware/Proxy/RewriteLocation.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_PROXY_REWRITELOCATION';
  package Plack::Middleware::Proxy::RewriteLocation;
  use strict;
  use parent 'Plack::Middleware';
  
  use Plack::Util;
  use Plack::Util::Accessor 'url_map';
  use URI;
  
  sub _different_part($$) {
      my ($from, $to) = @_;
  
      while ($from =~ m{[^/]+(?:\://$|/$|$)}g) {
          my $last_part = $&;
          last unless $to =~ /\Q$last_part\E$/;
  
          $from =~ s!\Q$last_part\E$!!;
          $to   =~ s!\Q$last_part\E$!!;
      }
  
      $from => $to;
  }
  
  sub new {
      my $self = shift->SUPER::new( @_ );
  
      # regularize the remote URLs in the URL map
      if( my $m = $self->url_map ) {
          for( my $i = 1; $i < @$m; $i += 2 ) {
              $m->[$i] = $self->_regularize_url( $m->[$i] );
          }
      }
  
      return $self;
  }
  
  sub call {
      my($self, $env) = @_;
  
      return sub {
          my $respond = shift;
  
          my $cb = $self->app->($env);
          return $respond->( $cb ) unless ref $cb eq 'CODE';
  
          $cb->(sub {
              my $res = shift;
  
              if ( $env->{HTTP_HOST} and my $location = Plack::Util::header_get($res->[1], 'Location') ) {
  
                  my @map;
                  if ($self->url_map) {
                      # regularize the format of the location so we can
                      # compare it correctly (some apps print this
                      # non-canonically)
                      $location = $self->_regularize_url( $location );
  
                      my $proxy = "$env->{'psgi.url_scheme'}://$env->{HTTP_HOST}";
                      my @url_map = @{$self->url_map};
  
                      while(my ($proxy_path, $remote) = splice @url_map, 0, 2) {
                          push @map, "$proxy$proxy_path" => $remote;
                      }
                  } else {
                      # Auto-guessing url_map
                      my $original_url = "$env->{'psgi.url_scheme'}://" . 
                                         $env->{HTTP_HOST} .
                                         $env->{SCRIPT_NAME} .
                                         $env->{PATH_INFO};
                      $original_url .= '?' . $env->{QUERY_STRING}
                          if defined $env->{QUERY_STRING} && $env->{QUERY_STRING};
                      @map = _different_part(
                          $original_url => $env->{'plack.proxy.last_url'}
                      );
                  }
  
                  while(my ($proxy_url, $remote) = splice @map, 0, 2) {
                      last if $location =~ s!^$remote!$proxy_url!;
                  }
  
                  $location =~ s!//$!/!; #< avoid double slashes
  
                  Plack::Util::header_set( $res->[1], 'Location' => $location );
              }
  
              return $respond->( $res );
          });
      };
  }
  
  sub _regularize_url {
      '' . URI->new( $_[1] )->canonical
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Proxy::RewriteLocation - Rewrites redirect headers
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
    use Plack::App::Proxy;
  
    builder {
        enable "Proxy::RewriteLocation";
        Plack::App::Proxy->new(remote => "http://10.0.1.2:8080/")->to_app;
    };
  
    ### or, if mounting (i.e. URLMap) the proxied site at /foo
  
    builder {
        enable "Proxy::RewriteLocation", url_map => [ '/foo' => http://10.0.1.2:8080' ];
        mount '/foo' => Plack::App::Proxy->new(remote => "http://10.0.1.2:8080/")->to_app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Proxy::RewriteLocation rewrites the C<Location>
  header in the response when the remote host redirects using its own
  headers, like mod_proxy's C<ProxyPassReverse> option.
  
  =head1 OPTIONS
  
  =over 4
  
  =item url_map (arrayref)
  
  If given, will account for mounted (URLMapped) Proxy apps when
  rewriting C<Location> headers.  Will be applied in order, stopping at the
  first successful match with the remote C<Location>.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  Robert Buels
  
  =head1 SEE ALSO
  
  L<Plack::App::Proxy>
  
  =cut
PLACK_MIDDLEWARE_PROXY_REWRITELOCATION

$fatpacked{"Plack/Middleware/RearrangeHeaders.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_REARRANGEHEADERS';
  package Plack::Middleware::RearrangeHeaders;
  use strict;
  use warnings;
  use parent qw( Plack::Middleware );
  
  use HTTP::Headers;
  
  sub call {
      my $self = shift;
  
      my $res = $self->app->(@_);
      $self->response_cb($res, sub {
          my $res = shift;
  
          my $h = HTTP::Headers->new(@{$res->[1]});
          my @new_headers;
          $h->scan(sub { push @new_headers, @_ });
  
          $res->[1] = \@new_headers;
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::RearrangeHeaders - Reorder HTTP headers for buggy clients
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    my $app = sub {
        return [ 200, [
            'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT',
            'Content-Type' => 'text/plain',
            'ETag' => 'foo bar',
        ], [ 'Hello Foo' ] ];
    };
  
    builder {
        enable "Plack::Middleware::RearrangeHeaders";
        $app;
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::RearrangeHeaders sorts HTTP headers based on "Good Practice" i.e.:
  
    # "Good Practice" order of HTTP message headers:
    #    - Response-Headers
    #    - Entity-Headers
  
  to work around buggy clients like very old MSIE or broken HTTP proxy
  servers. Most clients today don't (and shouldn't) care about HTTP
  header order but if you're too pedantic or have some environments
  where you need to deal with buggy clients like above, this might be
  useful.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<HTTP::Headers>
  
  =cut
PLACK_MIDDLEWARE_REARRANGEHEADERS

$fatpacked{"Plack/Middleware/Recursive.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_RECURSIVE';
  package Plack::Middleware::Recursive;
  use strict;
  use parent qw(Plack::Middleware);
  
  use Try::Tiny;
  use Scalar::Util qw(blessed);
  
  open my $null_io, "<", \"";
  
  sub call {
      my($self, $env) = @_;
  
      $env->{'plack.recursive.include'} = $self->recurse_callback($env, 1);
  
      my $res = try {
          $self->app->($env);
      } catch {
          if (blessed $_ && $_->isa('Plack::Recursive::ForwardRequest')) {
              return $self->recurse_callback($env)->($_->path);
          } else {
              die $_; # rethrow
          }
      };
  
      return $res if ref $res eq 'ARRAY';
  
      return sub {
          my $respond = shift;
  
          my $writer;
          try {
              $res->(sub { return $writer = $respond->(@_) });
          } catch {
              if (!$writer && blessed $_ && $_->isa('Plack::Recursive::ForwardRequest')) {
                  $res = $self->recurse_callback($env)->($_->path);
                  return ref $res eq 'CODE' ? $res->($respond) : $respond->($res);
              } else {
                  die $_;
              }
          };
      };
  }
  
  sub recurse_callback {
      my($self, $env, $include) = @_;
  
      my $old_path_info = $env->{PATH_INFO};
  
      return sub {
          my $new_path_info = shift;
          my($path, $query) = split /\?/, $new_path_info, 2;
  
          Scalar::Util::weaken($env);
  
          $env->{PATH_INFO}      = $path;
          $env->{QUERY_STRING}   = $query;
          $env->{REQUEST_METHOD} = 'GET';
          $env->{CONTENT_LENGTH} = 0;
          $env->{CONTENT_TYPE}   = '';
          $env->{'psgi.input'}   = $null_io;
          push @{$env->{'plack.recursive.old_path_info'}}, $old_path_info;
  
          $include ? $self->app->($env) : $self->call($env);
      };
  }
  
  package Plack::Recursive::ForwardRequest;
  use overload q("") => \&as_string, fallback => 1;
  
  sub new {
      my($class, $path) = @_;
      bless { path => $path }, $class;
  }
  
  sub path { $_[0]->{path} }
  
  sub throw {
      my($class, @args) = @_;
      die $class->new(@args);
  }
  
  sub as_string {
      my $self = shift;
      return "Forwarding to $self->{path}: Your application should be wrapped with Plack::Middleware::Recursive.";
  }
  
  package Plack::Middleware::Recursive;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Recursive - Allows PSGI apps to include or forward requests recursively
  
  =head1 SYNOPSIS
  
    # with Builder
    enable "Recursive";
  
    # in apps
    my $res = $env->{'plack.recursive.include'}->("/new_path");
  
    # Or, use exceptions
    my $app = sub {
        # ...
        Plack::Recursive::ForwardRequest->throw("/new_path");
    };
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Recursive allows PSGI applications to recursively
  include or forward requests to other paths. Applications can make use
  of callbacks stored in C<< $env->{'plack.recursive.include'} >> to
  I<include> another path to get the response (whether it's an array ref
  or a code ref depending on your application), or throw an exception
  Plack::Recursive::ForwardRequest anywhere in the code to I<forward>
  the current request (i.e. abort the current and redo the request).
  
  =head1 EXCEPTIONS
  
  This middleware passes through unknown exceptions to the outside
  middleware stack, so if you use this middleware with other exception
  handlers such as L<Plack::Middleware::StackTrace> or
  L<Plack::Middleware::HTTPExceptions>, be sure to wrap this so
  L<Plack::Middleware::Recursive> gets as inner as possible.
  
  =head1 AUTHORS
  
  Tatsuhiko Miyagawa
  
  Masahiro Honma
  
  =head1 SEE ALSO
  
  L<Plack> L<Plack::Middleware::HTTPExceptions>
  
  The idea, code and interface are stolen from Rack::Recursive and paste.recursive.
  
  =cut
  
  
PLACK_MIDDLEWARE_RECURSIVE

$fatpacked{"Plack/Middleware/Refresh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_REFRESH';
  package Plack::Middleware::Refresh;
  use strict;
  use parent qw(Plack::Middleware);
  use Module::Refresh;
  use Plack::Util::Accessor qw(last cooldown);
  
  sub prepare_app {
      my $self = shift;
      $self->cooldown(10) unless defined $self->cooldown;
  
      Module::Refresh->new;
      $self->last(time - $self->cooldown);
  }
  
  sub call {
      my($self, $env) = @_;
  
      if (time > $self->last + $self->cooldown) {
          Module::Refresh->refresh;
          $self->last(time);
      }
  
      $self->app->($env);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Refresh - Refresh all modules in %INC
  
  =head1 SYNOPSIS
  
    enable "Refresh", cooldown => 3;
    $app;
  
  =head1 DESCRIPTION
  
  This is I<yet another> approach to refresh modules in C<%INC> during
  the development cycle, without the need to have a forking process to
  watch for filesystem updates. This middleware, in a request time,
  compares the last refresh time and the current time and if the
  difference is bigger than I<cooldown> seconds which defaults to 10,
  call L<Module::Refresh> to reload all Perl modules in C<%INC> if the
  files have been modified.
  
  Note that this only reloads modules and not other files such as
  templates.
  
  This middleware is quite similar to what Rack::Reoader does. If you
  have issues with this reloading technique, for instance when you have
  in-file templates that needs to be recompiled, or Moose classes that
  has C<make_immutable>, take a look at L<plackup>'s default -r option
  or L<Plack::Loader::Shotgun> instead.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Module::Refresh> Rack::Reloader
  
  =cut
  
PLACK_MIDDLEWARE_REFRESH

$fatpacked{"Plack/Middleware/Runtime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_RUNTIME';
  package Plack::Middleware::Runtime;
  use strict;
  use parent qw(Plack::Middleware);
  use Plack::Util;
  use Plack::Util::Accessor qw(header_name);
  use Time::HiRes;
  
  sub call {
      my($self, $env) = @_;
  
      my $start = [ Time::HiRes::gettimeofday ];
      my $res = $self->app->($env);
      my $header = $self->header_name || 'X-Runtime';
  
      $self->response_cb($res, sub {
          my $res = shift;
          my $req_time = sprintf '%.6f', Time::HiRes::tv_interval($start);
          Plack::Util::header_set($res->[1], $header, $req_time);
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Runtime - Sets an X-Runtime response header
  
  =head1 SYNOPSIS
  
    enable "Runtime";
  
  =head1 DESCRIPTION
  
  Plack::Middleware::Runtime is a Plack middleware component that sets
  the application's response time (in seconds) in the I<X-Runtime> HTTP response
  header.
  
  =head1 OPTIONS
  
  =over 4
  
  =item header_name
  
  Name of the header. Defaults to I<X-Runtime>.
  
  =back
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Time::HiRes> Rack::Runtime
  
  =cut
PLACK_MIDDLEWARE_RUNTIME

$fatpacked{"Plack/Middleware/SimpleContentFilter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_SIMPLECONTENTFILTER';
  package Plack::Middleware::SimpleContentFilter;
  use strict;
  use warnings;
  use parent qw( Plack::Middleware );
  
  use Plack::Util;
  use Plack::Util::Accessor qw( filter );
  
  sub call {
      my $self = shift;
  
      my $res = $self->app->(@_);
      $self->response_cb($res, sub {
          my $res = shift;
          my $h = Plack::Util::headers($res->[1]);
          return unless $h->get('Content-Type');
          if ($h->get('Content-Type') =~ m!^text/!) {
              return sub {
                  my $chunk = shift;
                  return unless defined $chunk;
                  local $_ = $chunk;
                  $self->filter->();
                  return $_;
              };
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::SimpleContentFilter - Filters response content
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    my $app = sub {
        return [ 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello Foo' ] ];
    };
  
    builder {
        enable "Plack::Middleware::SimpleContentFilter",
            filter => sub { s/Foo/Bar/g; };
        $app;
    };
  
  =head1 DESCRIPTION
  
  B<This middleware should be considered as a demo. Running this against
  your application might break your HTML unless you code the filter
  callback carefully>.
  
  Plack::Middleware::SimpleContentFilter is a simple content text filter
  to run against response body. This middleware is only enabled against
  responses with C<text/*> Content-Type.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_MIDDLEWARE_SIMPLECONTENTFILTER

$fatpacked{"Plack/Middleware/SimpleLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_SIMPLELOGGER';
  package Plack::Middleware::SimpleLogger;
  use strict;
  use parent qw(Plack::Middleware);
  use Config ();
  use Plack::Util::Accessor qw(level);
  use POSIX ();
  use Scalar::Util ();
  
  # Should this be in Plack::Util?
  my $i = 0;
  my %level_numbers = map { $_ => $i++ } qw(debug info warn error fatal);
  
  sub call {
      my($self, $env) = @_;
  
      my $min = $level_numbers{ $self->level || "debug" };
  
      my $env_ref = $env;
      Scalar::Util::weaken($env_ref);
  
      $env->{'psgix.logger'} = sub {
          my $args = shift;
  
          if ($level_numbers{$args->{level}} >= $min) {
              $env_ref->{'psgi.errors'}->print($self->format_message($args->{level}, $args->{message}));
          }
      };
  
      $self->app->($env);
  }
  
  sub format_time {
      my $old_locale;
      if ( $Config::config{d_setlocale} ) {
          $old_locale = POSIX::setlocale(&POSIX::LC_ALL);
          POSIX::setlocale(&POSIX::LC_ALL, 'C');
      }
      my $out = POSIX::strftime(@_);
      if ( $Config::config{d_setlocale} ) {
          POSIX::setlocale(&POSIX::LC_ALL, $old_locale);
      };
      return $out;
  }
  
  sub format_message {
      my($self, $level, $message) = @_;
  
      my $time = format_time("%Y-%m-%dT%H:%M:%S", localtime);
      sprintf "%s [%s #%d] %s: %s\n", uc substr($level, 0, 1), $time, $$, uc $level, $message;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::SimpleLogger - Simple logger that prints to psgi.errors
  
  =head1 SYNOPSIS
  
    enable "SimpleLogger", level => "warn";
  
  =head1 DESCRIPTION
  
  SimpleLogger is a middleware component that formats the log message
  with information such as the time and PID and prints them to
  I<psgi.errors> stream, which is mostly STDERR or server log output.
  
  =head1 SEE ALSO
  
  L<Plack::Middleware::LogErrors>, essentially the opposite of this module
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_MIDDLEWARE_SIMPLELOGGER

$fatpacked{"Plack/Middleware/StackTrace.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_STACKTRACE';
  package Plack::Middleware::StackTrace;
  use strict;
  use warnings;
  use parent qw/Plack::Middleware/;
  use Devel::StackTrace;
  use Devel::StackTrace::AsHTML;
  use Scalar::Util qw( refaddr );
  use Try::Tiny;
  use Plack::Util::Accessor qw( force no_print_errors );
  
  our $StackTraceClass = "Devel::StackTrace";
  
  # Optional since it needs PadWalker
  if (try { require Devel::StackTrace::WithLexicals; Devel::StackTrace::WithLexicals->VERSION(0.08); 1 }) {
      $StackTraceClass = "Devel::StackTrace::WithLexicals";
  }
  
  sub call {
      my($self, $env) = @_;
  
      my ($trace, %string_traces, %ref_traces);
      local $SIG{__DIE__} = sub {
          $trace = $StackTraceClass->new(
              indent => 1, message => munge_error($_[0], [ caller ]),
              ignore_package => __PACKAGE__, no_refs => 1,
          );
          if (ref $_[0]) {
              $ref_traces{refaddr($_[0])} ||= $trace;
          }
          else {
              $string_traces{$_[0]} ||= $trace;
          }
          die @_;
      };
  
      my $caught;
      my $res = try {
          $self->app->($env);
      } catch {
          $caught = $_;
          [ 500, [ "Content-Type", "text/plain; charset=utf-8" ], [ no_trace_error(utf8_safe($caught)) ] ];
      };
  
      if ($caught) {
          # Try to find the correct trace for the caught exception
          my $caught_trace;
          if (ref $caught) {
              $caught_trace = $ref_traces{refaddr($caught)};
          }
          else {
              # This is not guaranteed to work if multiple exceptions with
              # the same message are thrown.
              $caught_trace = $string_traces{$caught};
          }
          $trace = $caught_trace if $caught_trace;
      }
  
      if ($trace && ($caught || ($self->force && ref $res eq 'ARRAY' && $res->[0] == 500)) ) {
          my $text = $trace->as_string;
          my $html = $trace->as_html;
          $env->{'plack.stacktrace.text'} = $text;
          $env->{'plack.stacktrace.html'} = $html;
          $env->{'psgi.errors'}->print($text) unless $self->no_print_errors;
          if (($env->{HTTP_ACCEPT} || '*/*') =~ /html/) {
              $res = [500, ['Content-Type' => 'text/html; charset=utf-8'], [ utf8_safe($html) ]];
          } else {
              $res = [500, ['Content-Type' => 'text/plain; charset=utf-8'], [ utf8_safe($text) ]];
          }
      }
  
      # break $trace here since $SIG{__DIE__} holds the ref to it, and
      # $trace has refs to Standalone.pm's args ($conn etc.) and
      # prevents garbage collection to be happening.
      undef $trace;
  
      return $res;
  }
  
  sub no_trace_error {
      my $msg = shift;
      chomp($msg);
  
      return <<EOF;
  The application raised the following error:
  
    $msg
  
  and the StackTrace middleware couldn't catch its stack trace, possibly because your application overrides \$SIG{__DIE__} by itself, preventing the middleware from working correctly. Remove the offending code or module that does it: known examples are CGI::Carp and Carp::Always.
  EOF
  }
  
  sub munge_error {
      my($err, $caller) = @_;
      return $err if ref $err;
  
      # Ugly hack to remove " at ... line ..." automatically appended by perl
      # If there's a proper way to do this, please let me know.
      $err =~ s/ at \Q$caller->[1]\E line $caller->[2]\.\n$//;
  
      return $err;
  }
  
  sub utf8_safe {
      my $str = shift;
  
      # NOTE: I know messing with utf8:: in the code is WRONG, but
      # because we're running someone else's code that we can't
      # guarantee which encoding an exception is encoded, there's no
      # better way than doing this. The latest Devel::StackTrace::AsHTML
      # (0.08 or later) encodes high-bit chars as HTML entities, so this
      # path won't be executed.
      if (utf8::is_utf8($str)) {
          utf8::encode($str);
      }
  
      $str;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::StackTrace - Displays stack trace when your app dies
  
  =head1 SYNOPSIS
  
    enable "StackTrace";
  
  =head1 DESCRIPTION
  
  This middleware uses C<$SIG{__DIE__}> to intercept I<all> exceptions
  (run-time errors) happening in your application, even those that are caught.
  For each exception it builds a detailed stack trace.
  
  If the applications aborts by throwing an exception it will be caught and matched
  against the saved stack traces. If a match is found it will be displayed as a nice
  stack trace screen, if not then the exception will be reported without a stack trace.
  
  The stack trace is also stored in the environment as a plaintext and HTML under the key
  C<plack.stacktrace.text> and C<plack.stacktrace.html> respectively, so
  that middleware further up the stack can reference it.
  
  This middleware is enabled by default when you run L<plackup> in the
  default I<development> mode.
  
  You're recommended to use this middleware during the development and
  use L<Plack::Middleware::HTTPExceptions> in the deployment mode as a
  replacement, so that all the exceptions thrown from your application
  still get caught and rendered as a 500 error response, rather than
  crashing the web server.
  
  Catching errors in streaming response is not supported.
  
  =head2 Stack Trace Module
  
  The L<Devel::StackTrace::WithLexicals> module will be used to capture the stack trace
  if the installed version is 0.08 or later. Otherwise L<Devel::StackTrace> is used.
  
  =head2 Performance
  
  Gathering the information for a stack trace via L<Devel::StackTrace> is slow,
  and L<Devel::StackTrace::WithLexicals> is significantly slower still.
  This is not usually a concern in development and when exceptions are rare.
  However, your application may include code that's throwing and catching exceptions
  that you're not aware of. Such code will run I<significantly> slower with this module.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item force
  
    enable "StackTrace", force => 1;
  
  Force display the stack trace when an error occurs within your
  application and the response code from your application is
  500. Defaults to off.
  
  The use case of this option is that when your framework catches all
  the exceptions in the main handler and returns all failures in your
  code as a normal 500 PSGI error response. In such cases, this
  middleware would never have a chance to display errors because it
  can't tell if it's an application error or just random C<eval> in your
  code. This option enforces the middleware to display stack trace even
  if it's not the direct error thrown by the application.
  
  =item no_print_errors
  
    enable "StackTrace", no_print_errors => 1;
  
  Skips printing the text stacktrace to console
  (C<psgi.errors>). Defaults to 0, which means the text version of the
  stack trace error is printed to the errors handle, which usually is a
  standard error.
  
  =back
  
  =head1 AUTHOR
  
  Tokuhiro Matsuno
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Devel::StackTrace::AsHTML> L<Plack::Middleware> L<Plack::Middleware::HTTPExceptions>
  
  =cut
  
PLACK_MIDDLEWARE_STACKTRACE

$fatpacked{"Plack/Middleware/Static.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_STATIC';
  package Plack::Middleware::Static;
  use strict;
  use warnings;
  use parent qw/Plack::Middleware/;
  use Plack::App::File;
  
  use Plack::Util::Accessor qw( path root encoding pass_through content_type );
  
  sub call {
      my $self = shift;
      my $env  = shift;
  
      my $res = $self->_handle_static($env);
      if ($res && not ($self->pass_through and $res->[0] == 404)) {
          return $res;
      }
  
      return $self->app->($env);
  }
  
  sub _handle_static {
      my($self, $env) = @_;
  
      my $path_match = $self->path or return;
      my $path = $env->{PATH_INFO};
  
      for ($path) {
          my $matched = 'CODE' eq ref $path_match ? $path_match->($_, $env) : $_ =~ $path_match;
          return unless $matched;
      }
  
      $self->{file} ||= Plack::App::File->new({ root => $self->root || '.', encoding => $self->encoding, content_type => $self->content_type });
      local $env->{PATH_INFO} = $path; # rewrite PATH
      return $self->{file}->call($env);
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Middleware::Static - serve static files with Plack
  
  =head1 SYNOPSIS
  
    use Plack::Builder;
  
    builder {
        enable "Plack::Middleware::Static",
            path => qr{^/(images|js|css)/}, root => './htdocs/';
        $app;
    };
  
  =head1 DESCRIPTION
  
  This middleware allows your Plack-based application to serve static files.
  
  Note that if you are building an app using L<Plack::App::URLMap>, you should
  consider using L<Plack::App::File> to serve static files instead. This makes
  the overall routing of your application simpler to understand.
  
  With this middleware, if a static file exists for the requested path, it will
  be served. If it does not exist, by default this middleware returns a 404, but
  you can set the C<pass_through> option to change this behavior.
  
  If the requested document is not within the C<root> or the file is there but
  not readable, this middleware will return a 403 Forbidden response.
  
  The content type returned will be determined from the file extension by using
  L<Plack::MIME> or using C<content_type>.
  
  =head1 CONFIGURATIONS
  
  =over 4
  
  =item path, root
  
    enable "Plack::Middleware::Static",
        path => qr{^/static/}, root => 'htdocs/';
  
  The C<path> option specifies the URL pattern (regular expression) or a
  callback to match against requests. If the <path> option matches, the
  middleware looks in C<root> to find the static files to serve. The default
  value of C<root> is the current directory.
  
  This example configuration serves C</static/foo.jpg> from
  C<htdocs/static/foo.jpg>. Note that the matched portion of the path,
  C</static/>, still appears in the locally mapped path under C<root>. If you
  don't want this to happen, you can use a callback to munge the path as you
  match it:
  
    enable "Plack::Middleware::Static",
        path => sub { s!^/static/!! }, root => 'static-files/';
  
  The callback should operate on C<$_> and return a true or false value. Any
  changes it makes to C<$_> are used when looking for the static file in the
  C<root>.
  
  The configuration above serves C</static/foo.png> from
  C<static-files/foo.png>, not C<static-files/static/foo.png>. The callback
  specified in the C<path> option matches against C<$_> munges this value using
  C<s///>. The substitution operator returns the number of matches it made, so it
  will return true when the path matches C<^/static>.
  
  For more complex static handling in the C<path> callback, in addition
  to C<$_> being set the callback receives two arguments, C<PATH_INFO>
  (same as C<$_>) and C<$env>.
  
  If you want to map multiple static directories from different roots, simply
  add this middleware multiple times with different configuration options.
  
  =item pass_through
  
  When this option is set to a true value, then this middleware will never
  return a 404 if it cannot find a matching file. Instead, it will simply pass
  the request on to the application it is wrapping.
  
  =item content_type
  
  The C<content_type> option can be used to provide access to a different MIME 
  database than L<Plack::MIME>.
  L<Plack::MIME> works fast and good for a list of well known file endings, 
  but if you need a more accurate content based checking you can use modules
  like L<File::MimeInfo> or L<File::MMagic> for example.
  The callback should work on $_[0] which is the filename of the file.
  
  =back
  
  =head1 AUTHOR
  
  Tokuhiro Matsuno, Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Middleware> L<Plack::Builder>
  
  =cut
  
  
PLACK_MIDDLEWARE_STATIC

$fatpacked{"Plack/Middleware/TrafficLog.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_TRAFFICLOG';
  package Plack::Middleware::TrafficLog;
  
  =head1 NAME
  
  Plack::Middleware::TrafficLog - Log headers and body of HTTP traffic
  
  =head1 SYNOPSIS
  
    # In app.psgi
    use Plack::Builder;
  
    builder {
        enable "TrafficLog", with_body => 1;
    };
  
  =head1 DESCRIPTION
  
  This middleware logs the request and response messages with detailed
  information about headers and body.
  
  The example log:
  
    [08/Aug/2012:16:59:47 +0200] [164836368] [127.0.0.1 -> 0:5000] [Request ]
    |GET / HTTP/1.1|Connection: TE, close|Host: localhost:5000|TE: deflate,gzi
    p;q=0.3|User-Agent: lwp-request/6.03 libwww-perl/6.03||
    [08/Aug/2012:16:59:47 +0200] [164836368] [127.0.0.1 <- 0:5000] [Response]
    |HTTP/1.0 200 OK|Content-Type: text/plain||Hello World
  
  This module works also with applications which have delayed response. In that
  case each chunk is logged separately and shares the same unique ID number and
  headers.
  
  The body of request and response is not logged by default. For streaming
  responses only first chunk is logged by default.
  
  =for readme stop
  
  =cut
  
  
  use 5.008;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0400';
  
  
  use parent 'Plack::Middleware';
  
  use Plack::Util::Accessor qw(
      with_request with_response with_date with_body with_all_chunks eol body_eol logger
      _counter _call_id _strftime
  );
  
  
  use Plack::Util;
  
  use Plack::Request;
  use Plack::Response;
  
  use POSIX ();
  use POSIX::strftime::Compiler ();
  use Scalar::Util ();
  
  
  sub prepare_app {
      my ($self) = @_;
  
      # the default values
      $self->with_request(Plack::Util::TRUE)     unless defined $self->with_request;
      $self->with_response(Plack::Util::TRUE)    unless defined $self->with_response;
      $self->with_date(Plack::Util::TRUE)        unless defined $self->with_date;
      $self->with_body(Plack::Util::FALSE)       unless defined $self->with_body;
      $self->with_all_chunks(Plack::Util::FALSE) unless defined $self->with_all_chunks;
      $self->body_eol(defined $self->eol ? $self->eol : ' ') unless defined $self->body_eol;
      $self->eol('|')         unless defined $self->eol;
  
      $self->_strftime(POSIX::strftime::Compiler->new('%d/%b/%Y:%H:%M:%S %z'));
  
      $self->_counter(0);
  };
  
  
  sub _log_message {
      my ($self, $type, $env, $status, $headers, $body) = @_;
  
      my $logger = $self->logger || sub { $env->{'psgi.errors'}->print(@_) };
  
      my $server_addr = sprintf '%s:%s', $env->{SERVER_NAME}, $env->{SERVER_PORT};
      my $remote_addr = defined $env->{REMOTE_PORT}
          ? sprintf '%s:%s', $env->{REMOTE_ADDR}, $env->{REMOTE_PORT}
          : $env->{REMOTE_ADDR};
  
      my $eol = $self->eol;
      my $body_eol = $self->body_eol;
      $body =~ s/\015?\012/$body_eol/gs if defined $body_eol;
  
      my $date = $self->with_date
          ? ('['. $self->_strftime->to_string(localtime) . '] ')
          : '';
  
      $logger->( sprintf "%s[%s] [%s %s %s] [%s] %s%s%s%s%s%s\n",
          $date,
          $self->_call_id,
  
          $remote_addr,
          $type eq 'Request ' ? '->' : $type eq 'Response' ? '<-' : '--',
          $server_addr,
  
          $type,
  
          $eol,
          $status,
          $eol,
          $headers->as_string($eol),
          $eol,
          $body,
      );
  };
  
  
  sub _log_request {
      my ($self, $env) = @_;
  
      my $req = Plack::Request->new($env);
  
      my $status = sprintf '%s %s %s', $req->method, $req->request_uri, $req->protocol,
      my $headers = $req->headers;
      my $body = $self->with_body ? $req->content : '';
  
      $self->_log_message('Request ', $env, $status, $headers, $body);
  };
  
  
  sub _log_response {
      my ($self, $env, $ret) = @_;
  
      my $res = Plack::Response->new(@$ret);
  
      my $status_code = $res->status;
      my $status_message = HTTP::Status::status_message($status_code);
  
      my $status = sprintf 'HTTP/1.0 %s %s', $status_code, defined $status_message ? $status_message : '';
      my $headers = $res->headers;
      my $body = '';
      if ($self->with_body) {
          $body = $res->content;
          $body = '' unless defined $body;
          $body = join '', grep { defined $_ } @$body if ref $body eq 'ARRAY';
      }
  
      $self->_log_message('Response', $env, $status, $headers, $body);
  };
  
  
  sub call {
      my ($self, $env) = @_;
  
      $self->_call_id(sprintf '%015d',
          time % 2**16 * 2**32 +
          (Scalar::Util::looks_like_number $env->{REMOTE_PORT} ? $env->{REMOTE_PORT} : int rand 2**16) % 2**16 * 2**16 +
          $self->_counter % 2**16);
      $self->_counter($self->_counter + 1);
  
      # Preprocessing
      $self->_log_request($env) if $self->with_request;
  
      # $self->app is the original app
      my $res = $self->app->($env);
  
      # Postprocessing
      return $self->with_response ? $self->response_cb($res, sub {
          my ($ret) = @_;
          my $seen;
          return sub {
              my ($chunk) = @_;
              return if $seen and not defined $chunk;
              return $chunk if $seen and not $self->with_all_chunks;
              $self->_log_response($env, [ $ret->[0], $ret->[1], [$chunk] ]);
              $seen = Plack::Util::TRUE;
              return $chunk;
          };
      }) : $res;
  };
  
  
  1;
  
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item logger
  
    # traffic.l4p
    log4perl.logger.traffic = DEBUG, LogfileTraffic
    log4perl.appender.LogfileTraffic = Log::Log4perl::Appender::File
    log4perl.appender.LogfileTraffic.filename = traffic.log
    log4perl.appender.LogfileTraffic.layout = PatternLayout
    log4perl.appender.LogfileTraffic.layout.ConversionPattern = %m{chomp}%n
  
    # app.psgi
    use Log::Log4perl qw(:levels get_logger);
    Log::Log4perl->init('traffic.l4p');
    my $logger = get_logger('traffic');
  
    enable "Plack::Middleware::TrafficLog",
        logger => sub { $logger->log($INFO, join '', @_) };
  
  Sets a callback to print log message to. It prints to C<psgi.errors> output
  stream by default.
  
  =item with_request
  
  The false value disables logging of request message.
  
  =item with_response
  
  The false value disables logging of response message.
  
  =item with_date
  
  The false value disables logging of current date.
  
  =item with_body
  
  The true value enables logging of message's body.
  
  =item with_all_chunks
  
  The true value enables logging of every chunk for streaming responses.
  
  =item eol
  
  Sets the line separator for message's headers and body. The default value is
  the pipe character C<|>.
  
  =item body_eol
  
  Sets the line separator for message's body only. The default is the space
  character C< >. The default value is used only if B<eol> is also undefined.
  
  =back
  
  =for readme continue
  
  =head1 SEE ALSO
  
  L<Plack>, L<Plack::Middleware::AccessLog>.
  
  =head1 BUGS
  
  This module has unstable API and it can be changed in future.
  
  The log file can contain the binary data if the PSGI server provides binary
  files.
  
  If you find the bug or want to implement new features, please report it at
  L<http://github.com/dex4er/perl-Plack-Middleware-TrafficLog/issues>
  
  The code repository is available at
  L<http://github.com/dex4er/perl-Plack-Middleware-TrafficLog>
  
  =head1 AUTHOR
  
  Piotr Roszatycki <dexter@cpan.org>
  
  =head1 LICENSE
  
  Copyright (c) 2012, 2014 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
PLACK_MIDDLEWARE_TRAFFICLOG

$fatpacked{"Plack/Middleware/XFramework.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_XFRAMEWORK';
  package Plack::Middleware::XFramework;
  use strict;
  use warnings;
  use parent qw/Plack::Middleware/;
  
  use Plack::Util;
  use Plack::Util::Accessor qw( framework );
  
  sub call {
      my $self = shift;
  
      my $res = $self->app->( @_ );
      $self->response_cb($res, sub {
          my $res = shift;
          if ($self->framework) {
              Plack::Util::header_set $res->[1], 'X-Framework' => $self->framework;
          }
      });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::XFramework - Sample middleware to add X-Framework
  
  =head1 SYNOPSIS
  
    enable "Plack::Middleware::XFramework", framework => "Catalyst";
  
  =head1 DESCRIPTION
  
  This middleware adds C<X-Framework> header to the HTTP response.
  
  =head1 CONFIGURATION
  
  =over 4
  
  =item framework
  
  Sets the string value of C<X-Framework> header. If not set, the header is not set to the response.
  
  =back
  
  =head1 SEE ALSO
  
  L<Plack::Middleware>
  
  =cut
  
PLACK_MIDDLEWARE_XFRAMEWORK

$fatpacked{"Plack/Middleware/XSendfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_MIDDLEWARE_XSENDFILE';
  package Plack::Middleware::XSendfile;
  use strict;
  use warnings;
  use parent qw(Plack::Middleware);
  
  use Plack::Util;
  use Scalar::Util;
  use Plack::Util::Accessor qw( variation );
  
  sub call {
      my $self = shift;
      my $env  = shift;
  
      my $res = $self->app->($env);
      $self->response_cb($res, sub {
          my $res = shift;
          my($status, $headers, $body) = @$res;
          return unless defined $body;
  
          if (Scalar::Util::blessed($body) && $body->can('path')) {
              my $type = $self->_variation($env) || '';
              my $h = Plack::Util::headers($headers);
              if ($type && !$h->exists($type)) {
                  if ($type eq 'X-Accel-Redirect') {
                      my $path = $body->path;
                      my $url = $self->map_accel_path($env, $path);
                      $h->set($type => $url) if $url;
                      $body = [];
                  } elsif ($type eq 'X-Sendfile' or $type eq 'X-Lighttpd-Send-File') {
                      my $path = $body->path;
                      $h->set($type => $path) if defined $path;
                      $body = [];
                  } else {
                      $env->{'psgi.errors'}->print("Unknown x-sendfile variation: $type");
                  }
              }
          }
  
          @$res = ( $status, $headers, $body );
      });
  }
  
  sub map_accel_path {
      my($self, $env, $path) = @_;
  
      if (my $mapping = $env->{HTTP_X_ACCEL_MAPPING}) {
          my($internal, $external) = split /=/, $mapping, 2;
          $path =~ s!^\Q$internal\E!$external!i;
      }
  
      return $path;
  }
  
  sub _variation {
      my($self, $env) = @_;
      $self->variation || $env->{'plack.xsendfile.type'} || $env->{HTTP_X_SENDFILE_TYPE};
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Middleware::XSendfile - Sets X-Sendfile (or a like) header for frontends
  
  =head1 SYNOPSIS
  
    enable "Plack::Middleware::XSendfile";
  
  =head1 DESCRIPTION
  
  You should use L<IO::File::WithPath> or L<Plack::Util>'s
  C<set_io_path> to add C<path> method to an IO object in the body.
  
  See L<http://github.com/rack/rack-contrib/blob/master/lib/rack/contrib/sendfile.rb>
  for the frontend configuration.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_MIDDLEWARE_XSENDFILE

$fatpacked{"Plack/Request.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_REQUEST';
  package Plack::Request;
  use strict;
  use warnings;
  use 5.008_001;
  our $VERSION = '1.0034';
  
  use HTTP::Headers;
  use Carp ();
  use Hash::MultiValue;
  use HTTP::Body;
  
  use Plack::Request::Upload;
  use Stream::Buffered;
  use URI;
  use URI::Escape ();
  
  sub new {
      my($class, $env) = @_;
      Carp::croak(q{$env is required})
          unless defined $env && ref($env) eq 'HASH';
  
      bless { env => $env }, $class;
  }
  
  sub env { $_[0]->{env} }
  
  sub address     { $_[0]->env->{REMOTE_ADDR} }
  sub remote_host { $_[0]->env->{REMOTE_HOST} }
  sub protocol    { $_[0]->env->{SERVER_PROTOCOL} }
  sub method      { $_[0]->env->{REQUEST_METHOD} }
  sub port        { $_[0]->env->{SERVER_PORT} }
  sub user        { $_[0]->env->{REMOTE_USER} }
  sub request_uri { $_[0]->env->{REQUEST_URI} }
  sub path_info   { $_[0]->env->{PATH_INFO} }
  sub path        { $_[0]->env->{PATH_INFO} || '/' }
  sub query_string{ $_[0]->env->{QUERY_STRING} }
  sub script_name { $_[0]->env->{SCRIPT_NAME} }
  sub scheme      { $_[0]->env->{'psgi.url_scheme'} }
  sub secure      { $_[0]->scheme eq 'https' }
  sub body        { $_[0]->env->{'psgi.input'} }
  sub input       { $_[0]->env->{'psgi.input'} }
  
  sub content_length   { $_[0]->env->{CONTENT_LENGTH} }
  sub content_type     { $_[0]->env->{CONTENT_TYPE} }
  
  sub session         { $_[0]->env->{'psgix.session'} }
  sub session_options { $_[0]->env->{'psgix.session.options'} }
  sub logger          { $_[0]->env->{'psgix.logger'} }
  
  sub cookies {
      my $self = shift;
  
      return {} unless $self->env->{HTTP_COOKIE};
  
      # HTTP_COOKIE hasn't changed: reuse the parsed cookie
      if (   $self->env->{'plack.cookie.parsed'}
          && $self->env->{'plack.cookie.string'} eq $self->env->{HTTP_COOKIE}) {
          return $self->env->{'plack.cookie.parsed'};
      }
  
      $self->env->{'plack.cookie.string'} = $self->env->{HTTP_COOKIE};
  
      my %results;
      my @pairs = grep m/=/, split "[;,] ?", $self->env->{'plack.cookie.string'};
      for my $pair ( @pairs ) {
          # trim leading trailing whitespace
          $pair =~ s/^\s+//; $pair =~ s/\s+$//;
  
          my ($key, $value) = map URI::Escape::uri_unescape($_), split( "=", $pair, 2 );
  
          # Take the first one like CGI.pm or rack do
          $results{$key} = $value unless exists $results{$key};
      }
  
      $self->env->{'plack.cookie.parsed'} = \%results;
  }
  
  sub query_parameters {
      my $self = shift;
      $self->env->{'plack.request.query'} ||= $self->_parse_query;
  }
  
  sub _parse_query {
      my $self = shift;
  
      my @query;
      my $query_string = $self->env->{QUERY_STRING};
      if (defined $query_string) {
          @query =
              map { s/\+/ /g; URI::Escape::uri_unescape($_) }
              map { /=/ ? split(/=/, $_, 2) : ($_ => '')}
              split(/[&;]/, $query_string);
      }
  
      Hash::MultiValue->new(@query);
  }
  
  sub content {
      my $self = shift;
  
      unless ($self->env->{'psgix.input.buffered'}) {
          $self->_parse_request_body;
      }
  
      my $fh = $self->input                 or return '';
      my $cl = $self->env->{CONTENT_LENGTH} or return '';
  
      $fh->seek(0, 0); # just in case middleware/apps read it without seeking back
      $fh->read(my($content), $cl, 0);
      $fh->seek(0, 0);
  
      return $content;
  }
  
  sub raw_body { $_[0]->content }
  
  # XXX you can mutate headers with ->headers but it's not written through to the env
  
  sub headers {
      my $self = shift;
      if (!defined $self->{headers}) {
          my $env = $self->env;
          $self->{headers} = HTTP::Headers->new(
              map {
                  (my $field = $_) =~ s/^HTTPS?_//;
                  ( $field => $env->{$_} );
              }
                  grep { /^(?:HTTP|CONTENT)/i } keys %$env
              );
      }
      $self->{headers};
  }
  
  sub content_encoding { shift->headers->content_encoding(@_) }
  sub header           { shift->headers->header(@_) }
  sub referer          { shift->headers->referer(@_) }
  sub user_agent       { shift->headers->user_agent(@_) }
  
  sub body_parameters {
      my $self = shift;
  
      unless ($self->env->{'plack.request.body'}) {
          $self->_parse_request_body;
      }
  
      return $self->env->{'plack.request.body'};
  }
  
  # contains body + query
  sub parameters {
      my $self = shift;
  
      $self->env->{'plack.request.merged'} ||= do {
          my $query = $self->query_parameters;
          my $body  = $self->body_parameters;
          Hash::MultiValue->new($query->flatten, $body->flatten);
      };
  }
  
  sub uploads {
      my $self = shift;
  
      if ($self->env->{'plack.request.upload'}) {
          return $self->env->{'plack.request.upload'};
      }
  
      $self->_parse_request_body;
      return $self->env->{'plack.request.upload'};
  }
  
  sub param {
      my $self = shift;
  
      return keys %{ $self->parameters } if @_ == 0;
  
      my $key = shift;
      return $self->parameters->{$key} unless wantarray;
      return $self->parameters->get_all($key);
  }
  
  sub upload {
      my $self = shift;
  
      return keys %{ $self->uploads } if @_ == 0;
  
      my $key = shift;
      return $self->uploads->{$key} unless wantarray;
      return $self->uploads->get_all($key);
  }
  
  sub uri {
      my $self = shift;
  
      my $base = $self->_uri_base;
  
      # We have to escape back PATH_INFO in case they include stuff like
      # ? or # so that the URI parser won't be tricked. However we should
      # preserve '/' since encoding them into %2f doesn't make sense.
      # This means when a request like /foo%2fbar comes in, we recognize
      # it as /foo/bar which is not ideal, but that's how the PSGI PATH_INFO
      # spec goes and we can't do anything about it. See PSGI::FAQ for details.
  
      # See RFC 3986 before modifying.
      my $path_escape_class = q{^/;:@&=A-Za-z0-9\$_.+!*'(),-};
  
      my $path = URI::Escape::uri_escape($self->env->{PATH_INFO} || '', $path_escape_class);
      $path .= '?' . $self->env->{QUERY_STRING}
          if defined $self->env->{QUERY_STRING} && $self->env->{QUERY_STRING} ne '';
  
      $base =~ s!/$!! if $path =~ m!^/!;
  
      return URI->new($base . $path)->canonical;
  }
  
  sub base {
      my $self = shift;
      URI->new($self->_uri_base)->canonical;
  }
  
  sub _uri_base {
      my $self = shift;
  
      my $env = $self->env;
  
      my $uri = ($env->{'psgi.url_scheme'} || "http") .
          "://" .
          ($env->{HTTP_HOST} || (($env->{SERVER_NAME} || "") . ":" . ($env->{SERVER_PORT} || 80))) .
          ($env->{SCRIPT_NAME} || '/');
  
      return $uri;
  }
  
  sub new_response {
      my $self = shift;
      require Plack::Response;
      Plack::Response->new(@_);
  }
  
  sub _parse_request_body {
      my $self = shift;
  
      my $ct = $self->env->{CONTENT_TYPE};
      my $cl = $self->env->{CONTENT_LENGTH};
      if (!$ct && !$cl) {
          # No Content-Type nor Content-Length -> GET/HEAD
          $self->env->{'plack.request.body'}   = Hash::MultiValue->new;
          $self->env->{'plack.request.upload'} = Hash::MultiValue->new;
          return;
      }
  
      my $body = HTTP::Body->new($ct, $cl);
  
      # HTTP::Body will create temporary files in case there was an
      # upload.  Those temporary files can be cleaned up by telling
      # HTTP::Body to do so. It will run the cleanup when the request
      # env is destroyed. That the object will not go out of scope by
      # the end of this sub we will store a reference here.
      $self->env->{'plack.request.http.body'} = $body;
      $body->cleanup(1);
  
      my $input = $self->input;
  
      my $buffer;
      if ($self->env->{'psgix.input.buffered'}) {
          # Just in case if input is read by middleware/apps beforehand
          $input->seek(0, 0);
      } else {
          $buffer = Stream::Buffered->new($cl);
      }
  
      my $spin = 0;
      while ($cl) {
          $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
          my $read = length $chunk;
          $cl -= $read;
          $body->add($chunk);
          $buffer->print($chunk) if $buffer;
  
          if ($read == 0 && $spin++ > 2000) {
              Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
          }
      }
  
      if ($buffer) {
          $self->env->{'psgix.input.buffered'} = 1;
          $self->env->{'psgi.input'} = $buffer->rewind;
      } else {
          $input->seek(0, 0);
      }
  
      $self->env->{'plack.request.body'}   = Hash::MultiValue->from_mixed($body->param);
  
      my @uploads = Hash::MultiValue->from_mixed($body->upload)->flatten;
      my @obj;
      while (my($k, $v) = splice @uploads, 0, 2) {
          push @obj, $k, $self->_make_upload($v);
      }
  
      $self->env->{'plack.request.upload'} = Hash::MultiValue->new(@obj);
  
      1;
  }
  
  sub _make_upload {
      my($self, $upload) = @_;
      my %copy = %$upload;
      $copy{headers} = HTTP::Headers->new(%{$upload->{headers}});
      Plack::Request::Upload->new(%copy);
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Request - Portable HTTP request object from PSGI env hash
  
  =head1 SYNOPSIS
  
    use Plack::Request;
  
    my $app_or_middleware = sub {
        my $env = shift; # PSGI env
  
        my $req = Plack::Request->new($env);
  
        my $path_info = $req->path_info;
        my $query     = $req->parameters->{query};
  
        my $res = $req->new_response(200); # new Plack::Response
        $res->finalize;
    };
  
  =head1 DESCRIPTION
  
  L<Plack::Request> provides a consistent API for request objects across
  web server environments.
  
  =head1 CAVEAT
  
  Note that this module is intended to be used by Plack middleware
  developers and web application framework developers rather than
  application developers (end users).
  
  Writing your web application directly using Plack::Request is
  certainly possible but not recommended: it's like doing so with
  mod_perl's Apache::Request: yet too low level.
  
  If you're writing a web application, not a framework, then you're
  encouraged to use one of the web application frameworks that support PSGI (L<http://plackperl.org/#frameworks>),
  or see modules like L<HTTP::Engine> to provide higher level
  Request and Response API on top of PSGI.
  
  =head1 METHODS
  
  Some of the methods defined in the earlier versions are deprecated in
  version 0.99. Take a look at L</"INCOMPATIBILITIES">.
  
  Unless otherwise noted, all methods and attributes are B<read-only>,
  and passing values to the method like an accessor doesn't work like
  you expect it to.
  
  =head2 new
  
      Plack::Request->new( $env );
  
  Creates a new request object.
  
  =head1 ATTRIBUTES
  
  =over 4
  
  =item env
  
  Returns the shared PSGI environment hash reference. This is a
  reference, so writing to this environment passes through during the
  whole PSGI request/response cycle.
  
  =item address
  
  Returns the IP address of the client (C<REMOTE_ADDR>).
  
  =item remote_host
  
  Returns the remote host (C<REMOTE_HOST>) of the client. It may be
  empty, in which case you have to get the IP address using C<address>
  method and resolve on your own.
  
  =item method
  
  Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
  
  =item protocol
  
  Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
  
  =item request_uri
  
  Returns the raw, undecoded request URI path. You probably do B<NOT>
  want to use this to dispatch requests.
  
  =item path_info
  
  Returns B<PATH_INFO> in the environment. Use this to get the local
  path for the requests.
  
  =item path
  
  Similar to C<path_info> but returns C</> in case it is empty. In other
  words, it returns the virtual path of the request URI after C<<
  $req->base >>. See L</"DISPATCHING"> for details.
  
  =item query_string
  
  Returns B<QUERY_STRING> in the environment. This is the undecoded
  query string in the request URI.
  
  =item script_name
  
  Returns B<SCRIPT_NAME> in the environment. This is the absolute path
  where your application is hosted.
  
  =item scheme
  
  Returns the scheme (C<http> or C<https>) of the request.
  
  =item secure
  
  Returns true or false, indicating whether the connection is secure (https).
  
  =item body, input
  
  Returns C<psgi.input> handle.
  
  =item session
  
  Returns (optional) C<psgix.session> hash. When it exists, you can
  retrieve and store per-session data from and to this hash.
  
  =item session_options
  
  Returns (optional) C<psgix.session.options> hash.
  
  =item logger
  
  Returns (optional) C<psgix.logger> code reference. When it exists,
  your application is supposed to send the log message to this logger,
  using:
  
    $req->logger->({ level => 'debug', message => "This is a debug message" });
  
  =item cookies
  
  Returns a reference to a hash containing the cookies. Values are
  strings that are sent by clients and are URI decoded.
  
  If there are multiple cookies with the same name in the request, this
  method will ignore the duplicates and return only the first value. If
  that causes issues for you, you may have to use modules like
  CGI::Simple::Cookie to parse C<< $request->header('Cookies') >> by
  yourself.
  
  =item query_parameters
  
  Returns a reference to a hash containing query string (GET)
  parameters. This hash reference is L<Hash::MultiValue> object.
  
  =item body_parameters
  
  Returns a reference to a hash containing posted parameters in the
  request body (POST). As with C<query_parameters>, the hash
  reference is a L<Hash::MultiValue> object.
  
  =item parameters
  
  Returns a L<Hash::MultiValue> hash reference containing (merged) GET
  and POST parameters.
  
  =item content, raw_body
  
  Returns the request content in an undecoded byte string for POST requests.
  
  =item uri
  
  Returns an URI object for the current request. The URI is constructed
  using various environment values such as C<SCRIPT_NAME>, C<PATH_INFO>,
  C<QUERY_STRING>, C<HTTP_HOST>, C<SERVER_NAME> and C<SERVER_PORT>.
  
  Every time this method is called it returns a new, cloned URI object.
  
  =item base
  
  Returns an URI object for the base path of current request. This is
  like C<uri> but only contains up to C<SCRIPT_NAME> where your
  application is hosted at.
  
  Every time this method is called it returns a new, cloned URI object.
  
  =item user
  
  Returns C<REMOTE_USER> if it's set.
  
  =item headers
  
  Returns an L<HTTP::Headers> object containing the headers for the current request.
  
  =item uploads
  
  Returns a reference to a hash containing uploads. The hash reference
  is a L<Hash::MultiValue> object and values are L<Plack::Request::Upload>
  objects.
  
  =item content_encoding
  
  Shortcut to $req->headers->content_encoding.
  
  =item content_length
  
  Shortcut to $req->headers->content_length.
  
  =item content_type
  
  Shortcut to $req->headers->content_type.
  
  =item header
  
  Shortcut to $req->headers->header.
  
  =item referer
  
  Shortcut to $req->headers->referer.
  
  =item user_agent
  
  Shortcut to $req->headers->user_agent.
  
  =item param
  
  Returns GET and POST parameters with a CGI.pm-compatible param
  method. This is an alternative method for accessing parameters in
  $req->parameters just in case you want the compatibility with
  CGI.pm objects.
  
  You are B<not recommended> to use this method since it is easy to
  misuse in a list context such as inside a hash constructor or method
  arguments. Use C<parameters> and Hash::MultiValue instead.
  
  Unlike CGI.pm, it does I<not> allow setting or modifying query
  parameters.
  
      $value  = $req->param( 'foo' );
      @values = $req->param( 'foo' );
      @params = $req->param;
  
  =item upload
  
  A convenient method to access $req->uploads.
  
      $upload  = $req->upload('field');
      @uploads = $req->upload('field');
      @fields  = $req->upload;
  
      for my $upload ( $req->upload('field') ) {
          print $upload->filename;
      }
  
  =item new_response
  
    my $res = $req->new_response;
  
  Creates a new L<Plack::Response> object. Handy to remove dependency on
  L<Plack::Response> in your code for easy subclassing and duck typing
  in web application frameworks, as well as overriding Response
  generation in middlewares.
  
  =back
  
  =head2 Hash::MultiValue parameters
  
  Parameters that can take one or multiple values (i.e. C<parameters>,
  C<query_parameters>, C<body_parameters> and C<uploads>) store the
  hash reference as a L<Hash::MultiValue> object. This means you can use
  the hash reference as a plain hash where values are B<always> scalars
  (B<NOT> array references), so you don't need to code ugly and unsafe
  C<< ref ... eq 'ARRAY' >> anymore.
  
  And if you explicitly want to get multiple values of the same key, you
  can call the C<get_all> method on it, such as:
  
    my @foo = $req->query_parameters->get_all('foo');
  
  You can also call C<get_one> to always get one parameter independent
  of the context (unlike C<param>), and even call C<mixed> (with
  Hash::MultiValue 0.05 or later) to get the I<traditional> hash
  reference,
  
    my $params = $req->parameters->mixed;
  
  where values are either a scalar or an array reference depending on
  input, so it might be useful if you already have the code to deal with
  that ugliness.
  
  =head2 PARSING POST BODY and MULTIPLE OBJECTS
  
  The methods to parse request body (C<content>, C<body_parameters> and
  C<uploads>) are carefully coded to save the parsed body in the
  environment hash as well as in the temporary buffer, so you can call
  them multiple times and create Plack::Request objects multiple times
  in a request and they should work safely, and won't parse request body
  more than twice for the efficiency.
  
  =head1 DISPATCHING
  
  If your application or framework wants to dispatch (or route) actions
  based on request paths, be sure to use C<< $req->path_info >> not C<<
  $req->uri->path >>.
  
  This is because C<path_info> gives you the virtual path of the request,
  regardless of how your application is mounted. If your application is
  hosted with mod_perl or CGI scripts, or even multiplexed with tools
  like L<Plack::App::URLMap>, request's C<path_info> always gives you
  the action path.
  
  Note that C<path_info> might give you an empty string, in which case
  you should assume that the path is C</>.
  
  You will also want to use C<< $req->base >> as a base prefix when
  building URLs in your templates or in redirections. It's a good idea
  for you to subclass Plack::Request and define methods such as:
  
    sub uri_for {
        my($self, $path, $args) = @_;
        my $uri = $self->base;
        $uri->path($uri->path . $path);
        $uri->query_form(@$args) if $args;
        $uri;
    }
  
  So you can say:
  
    my $link = $req->uri_for('/logout', [ signoff => 1 ]);
  
  and if C<< $req->base >> is C</app> you'll get the full URI for
  C</app/logout?signoff=1>.
  
  =head1 INCOMPATIBILITIES
  
  In version 0.99, many utility methods are removed or deprecated, and
  most methods are made read-only. These methods were deleted in version
  1.0001.
  
  All parameter-related methods such as C<parameters>,
  C<body_parameters>, C<query_parameters> and C<uploads> now contains
  L<Hash::MultiValue> objects, rather than I<scalar or an array
  reference depending on the user input> which is insecure. See
  L<Hash::MultiValue> for more about this change.
  
  C<< $req->path >> method had a bug, where the code and the document
  was mismatching. The document was suggesting it returns the sub
  request path after C<< $req->base >> but the code was always returning
  the absolute URI path. The code is now updated to be an alias of C<<
  $req->path_info >> but returns C</> in case it's empty. If you need
  the older behavior, just call C<< $req->uri->path >> instead.
  
  Cookie handling is simplified, and doesn't use L<CGI::Simple::Cookie>
  anymore, which means you B<CAN NOT> set array reference or hash
  reference as a cookie value and expect it be serialized. You're always
  required to set string value, and encoding or decoding them is totally
  up to your application or framework. Also, C<cookies> hash reference
  now returns I<strings> for the cookies rather than CGI::Simple::Cookie
  objects, which means you no longer have to write a wacky code such as:
  
    $v = $req->cookie->{foo} ? $req->cookie->{foo}->value : undef;
  
  and instead, simply do:
  
    $v = $req->cookie->{foo};
  
  =head1 AUTHORS
  
  Tatsuhiko Miyagawa
  
  Kazuhiro Osawa
  
  Tokuhiro Matsuno
  
  =head1 SEE ALSO
  
  L<Plack::Response> L<HTTP::Request>, L<Catalyst::Request>
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK_REQUEST

$fatpacked{"Plack/Request/Upload.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_REQUEST_UPLOAD';
  package Plack::Request::Upload;
  use strict;
  use warnings;
  use Carp ();
  
  sub new {
      my($class, %args) = @_;
  
      bless {
          headers  => $args{headers},
          tempname => $args{tempname},
          size     => $args{size},
          filename => $args{filename},
      }, $class;
  }
  
  sub filename { $_[0]->{filename} }
  sub headers  { $_[0]->{headers} }
  sub size     { $_[0]->{size} }
  sub tempname { $_[0]->{tempname} }
  sub path     { $_[0]->{tempname} }
  
  sub content_type {
      my $self = shift;
      $self->{headers}->content_type(@_);
  }
  
  sub type { shift->content_type(@_) }
  
  sub basename {
      my $self = shift;
      unless (defined $self->{basename}) {
          require File::Spec::Unix;
          my $basename = $self->{filename};
          $basename =~ s|\\|/|g;
          $basename = ( File::Spec::Unix->splitpath($basename) )[2];
          $basename =~ s|[^\w\.-]+|_|g;
          $self->{basename} = $basename;
      }
      $self->{basename};
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Request::Upload - handles file upload requests
  
  =head1 SYNOPSIS
  
    # $req is Plack::Request
    my $upload = $req->uploads->{field};
  
    $upload->size;
    $upload->path;
    $upload->content_type;
    $upload->basename;
  
  =head1 METHODS
  
  =over 4
  
  =item size
  
  Returns the size of Uploaded file.
  
  =item path
  
  Returns the path to the temporary file where uploaded file is saved.
  
  =item content_type
  
  Returns the content type of the uploaded file.
  
  =item filename
  
  Returns the original filename in the client.
  
  =item basename
  
  Returns basename for "filename".
  
  =back
  
  =head1 AUTHORS
  
  Kazuhiro Osawa
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Request>, L<Catalyst::Request::Upload>
  
  =cut
PLACK_REQUEST_UPLOAD

$fatpacked{"Plack/Response.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_RESPONSE';
  package Plack::Response;
  use strict;
  use warnings;
  our $VERSION = '1.0034';
  
  use Plack::Util::Accessor qw(body status);
  use Carp ();
  use Scalar::Util ();
  use HTTP::Headers;
  use URI::Escape ();
  
  sub code    { shift->status(@_) }
  sub content { shift->body(@_)   }
  
  sub new {
      my($class, $rc, $headers, $content) = @_;
  
      my $self = bless {}, $class;
      $self->status($rc)       if defined $rc;
      $self->headers($headers) if defined $headers;
      $self->body($content)    if defined $content;
  
      $self;
  }
  
  sub headers {
      my $self = shift;
  
      if (@_) {
          my $headers = shift;
          if (ref $headers eq 'ARRAY') {
              Carp::carp("Odd number of headers") if @$headers % 2 != 0;
              $headers = HTTP::Headers->new(@$headers);
          } elsif (ref $headers eq 'HASH') {
              $headers = HTTP::Headers->new(%$headers);
          }
          return $self->{headers} = $headers;
      } else {
          return $self->{headers} ||= HTTP::Headers->new();
      }
  }
  
  sub cookies {
      my $self = shift;
      if (@_) {
          $self->{cookies} = shift;
      } else {
          return $self->{cookies} ||= +{ };
      }
  }
  
  sub header { shift->headers->header(@_) } # shortcut
  
  sub content_length {
      shift->headers->content_length(@_);
  }
  
  sub content_type {
      shift->headers->content_type(@_);
  }
  
  sub content_encoding {
      shift->headers->content_encoding(@_);
  }
  
  sub location {
      my $self = shift;
      return $self->headers->header('Location' => @_);
  }
  
  sub redirect {
      my $self = shift;
  
      if (@_) {
          my $url = shift;
          my $status = shift || 302;
          $self->location($url);
          $self->status($status);
      }
  
      return $self->location;
  }
  
  sub finalize {
      my $self = shift;
      Carp::croak "missing status" unless $self->status();
  
      my $headers = $self->headers;
      my @headers;
      $headers->scan(sub{
          my ($k,$v) = @_;
          $v =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP
          $v =~ s/\015|\012//g; # remove CR and LF since the char is invalid here
          push @headers, $k, $v;
      });
  
      $self->_finalize_cookies(\@headers);
  
      return [
          $self->status,
          \@headers,
          $self->_body,
      ];
  }
  
  sub to_app {
      my $self = shift;
      return sub { $self->finalize };
  }
  
  
  sub _body {
      my $self = shift;
      my $body = $self->body;
         $body = [] unless defined $body;
      if (!ref $body or Scalar::Util::blessed($body) && overload::Method($body, q("")) && !$body->can('getline')) {
          return [ $body ];
      } else {
          return $body;
      }
  }
  
  sub _finalize_cookies {
      my($self, $headers) = @_;
  
      while (my($name, $val) = each %{$self->cookies}) {
          my $cookie = $self->_bake_cookie($name, $val);
          push @$headers, 'Set-Cookie' => $cookie;
      }
  }
  
  sub _bake_cookie {
      my($self, $name, $val) = @_;
  
      return '' unless defined $val;
      $val = { value => $val } unless ref $val eq 'HASH';
  
      my @cookie = ( URI::Escape::uri_escape($name) . "=" . URI::Escape::uri_escape($val->{value}) );
      push @cookie, "domain=" . $val->{domain}   if $val->{domain};
      push @cookie, "path=" . $val->{path}       if $val->{path};
      push @cookie, "expires=" . $self->_date($val->{expires}) if $val->{expires};
      push @cookie, "max-age=" . $val->{"max-age"} if $val->{"max-age"};
      push @cookie, "secure"                     if $val->{secure};
      push @cookie, "HttpOnly"                   if $val->{httponly};
  
      return join "; ", @cookie;
  }
  
  my @MON  = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
  my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
  
  sub _date {
      my($self, $expires) = @_;
  
      if ($expires =~ /^\d+$/) {
          # all numbers -> epoch date
          # (cookies use '-' as date separator, HTTP uses ' ')
          my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires);
          $year += 1900;
  
          return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
                         $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
  
      }
  
      return $expires;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Response - Portable HTTP Response object for PSGI response
  
  =head1 SYNOPSIS
  
    use Plack::Response;
  
    sub psgi_handler {
        my $env = shift;
  
        my $res = Plack::Response->new(200);
        $res->content_type('text/html');
        $res->body("Hello World");
  
        return $res->finalize;
    }
  
  =head1 DESCRIPTION
  
  Plack::Response allows you a way to create PSGI response array ref through a simple API.
  
  =head1 METHODS
  
  =over 4
  
  =item new
  
    $res = Plack::Response->new;
    $res = Plack::Response->new($status);
    $res = Plack::Response->new($status, $headers);
    $res = Plack::Response->new($status, $headers, $body);
  
  Creates a new Plack::Response object.
  
  =item status
  
    $res->status(200);
    $status = $res->status;
  
  Sets and gets HTTP status code. C<code> is an alias.
  
  =item headers
  
    $headers = $res->headers;
    $res->headers([ 'Content-Type' => 'text/html' ]);
    $res->headers({ 'Content-Type' => 'text/html' });
    $res->headers( HTTP::Headers->new );
  
  Sets and gets HTTP headers of the response. Setter can take either an
  array ref, a hash ref or L<HTTP::Headers> object containing a list of
  headers.
  
  =item body
  
    $res->body($body_str);
    $res->body([ "Hello", "World" ]);
    $res->body($io);
  
  Gets and sets HTTP response body. Setter can take either a string, an
  array ref, or an IO::Handle-like object. C<content> is an alias.
  
  Note that this method doesn't automatically set I<Content-Length> for
  the response. You have to set it manually if you want, with the
  C<content_length> method (see below).
  
  =item header
  
    $res->header('X-Foo' => 'bar');
    my $val = $res->header('X-Foo');
  
  Shortcut for C<< $res->headers->header >>.
  
  =item content_type, content_length, content_encoding
  
    $res->content_type('text/plain');
    $res->content_length(123);
    $res->content_encoding('gzip');
  
  Shortcut for the equivalent get/set methods in C<< $res->headers >>.
  
  =item redirect
  
    $res->redirect($url);
    $res->redirect($url, 301);
  
  Sets redirect URL with an optional status code, which defaults to 302.
  
  Note that this method doesn't normalize the given URI string. Users of
  this module have to be responsible about properly encoding URI paths
  and parameters.
  
  =item location
  
  Gets and sets C<Location> header.
  
  Note that this method doesn't normalize the given URI string in the
  setter. See above in C<redirect> for details.
  
  =item cookies
  
    $res->cookies->{foo} = 123;
    $res->cookies->{foo} = { value => '123' };
  
  Returns a hash reference containing cookies to be set in the
  response. The keys of the hash are the cookies' names, and their
  corresponding values are a plain string (for C<value> with everything
  else defaults) or a hash reference that can contain keys such as
  C<value>, C<domain>, C<expires>, C<path>, C<httponly>, C<secure>,
  C<max-age>.
  
  C<expires> can take a string or an integer (as an epoch time) and
  B<does not> convert string formats such as C<+3M>.
  
    $res->cookies->{foo} = {
        value => 'test',
        path  => "/",
        domain => '.example.com',
        expires => time + 24 * 60 * 60,
    };
  
  =item finalize
  
    $res->finalize;
  
  Returns the status code, headers, and body of this response as a PSGI
  response array reference.
  
  =item to_app
  
    $app = $res->to_app;
  
  A helper shortcut for C<< sub { $res->finalize } >>.
  
  
  =back
  
  =head1 AUTHOR
  
  Tokuhiro Matsuno
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Request>
  
  =cut
PLACK_RESPONSE

$fatpacked{"Plack/Runner.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_RUNNER';
  package Plack::Runner;
  use strict;
  use warnings;
  use Carp ();
  use Plack::Util;
  use Try::Tiny;
  
  sub new {
      my $class = shift;
      bless {
          env      => $ENV{PLACK_ENV},
          loader   => 'Plack::Loader',
          includes => [],
          modules  => [],
          default_middleware => 1,
          @_,
      }, $class;
  }
  
  # delay the build process for reloader
  sub build(&;$) {
      my $block = shift;
      my $app   = shift || sub { };
      return sub { $block->($app->()) };
  }
  
  sub parse_options {
      my $self = shift;
  
      local @ARGV = @_;
  
      # From 'prove': Allow cuddling the paths with -I, -M and -e
      @ARGV = map { /^(-[IMe])(.+)/ ? ($1,$2) : $_ } @ARGV;
  
      my($host, $port, $socket, @listen);
  
      require Getopt::Long;
      my $parser = Getopt::Long::Parser->new(
          config => [ "no_auto_abbrev", "no_ignore_case", "pass_through" ],
      );
  
      $parser->getoptions(
          "a|app=s"      => \$self->{app},
          "o|host=s"     => \$host,
          "p|port=i"     => \$port,
          "s|server=s"   => \$self->{server},
          "S|socket=s"   => \$socket,
          'l|listen=s@'  => \@listen,
          'D|daemonize'  => \$self->{daemonize},
          "E|env=s"      => \$self->{env},
          "e=s"          => \$self->{eval},
          'I=s@'         => $self->{includes},
          'M=s@'         => $self->{modules},
          'r|reload'     => sub { $self->{loader} = "Restarter" },
          'R|Reload=s'   => sub { $self->{loader} = "Restarter"; $self->loader->watch(split ",", $_[1]) },
          'L|loader=s'   => \$self->{loader},
          "access-log=s" => \$self->{access_log},
          "path=s"       => \$self->{path},
          "h|help"       => \$self->{help},
          "v|version"    => \$self->{version},
          "default-middleware!" => \$self->{default_middleware},
      );
  
      my(@options, @argv);
      while (defined(my $arg = shift @ARGV)) {
          if ($arg =~ s/^--?//) {
              my @v = split '=', $arg, 2;
              $v[0] =~ tr/-/_/;
              if (@v == 2) {
                  push @options, @v;
              } elsif ($v[0] =~ s/^(disable|enable)_//) {
                  push @options, $v[0], $1 eq 'enable';
              } else {
                  push @options, $v[0], shift @ARGV;
              }
          } else {
              push @argv, $arg;
          }
      }
  
      push @options, $self->mangle_host_port_socket($host, $port, $socket, @listen);
      push @options, daemonize => 1 if $self->{daemonize};
  
      $self->{options} = \@options;
      $self->{argv}    = \@argv;
  }
  
  sub set_options {
      my $self = shift;
      push @{$self->{options}}, @_;
  }
  
  sub mangle_host_port_socket {
      my($self, $host, $port, $socket, @listen) = @_;
  
      for my $listen (reverse @listen) {
          if ($listen =~ /:\d+$/) {
              ($host, $port) = split /:/, $listen, 2;
              $host = undef if $host eq '';
          } else {
              $socket ||= $listen;
          }
      }
  
      unless (@listen) {
          if ($socket) {
              @listen = ($socket);
          } else {
              $port ||= 5000;
              @listen = ($host ? "$host:$port" : ":$port");
          }
      }
  
      return host => $host, port => $port, listen => \@listen, socket => $socket;
  }
  
  sub version_cb {
      my $self = shift;
      $self->{version_cb} || sub {
          require Plack;
          print "Plack $Plack::VERSION\n";
      };
  }
  
  sub setup {
      my $self = shift;
  
      if ($self->{help}) {
          require Pod::Usage;
          Pod::Usage::pod2usage(0);
      }
  
      if ($self->{version}) {
          $self->version_cb->();
          exit;
      }
  
      if (@{$self->{includes}}) {
          require lib;
          lib->import(@{$self->{includes}});
      }
  
      if ($self->{eval}) {
          push @{$self->{modules}}, 'Plack::Builder';
      }
  
      for (@{$self->{modules}}) {
          my($module, @import) = split /[=,]/;
          eval "require $module" or die $@;
          $module->import(@import);
      }
  }
  
  sub locate_app {
      my($self, @args) = @_;
  
      my $psgi = $self->{app} || $args[0];
  
      if (ref $psgi eq 'CODE') {
          return sub { $psgi };
      }
  
      if ($self->{eval}) {
          $self->loader->watch("lib");
          return build {
              no strict;
              no warnings;
              my $eval = "builder { $self->{eval};";
              $eval .= "Plack::Util::load_psgi(\$psgi);" if $psgi;
              $eval .= "}";
              eval $eval or die $@;
          };
      }
  
      $psgi ||= "app.psgi";
  
      require File::Basename;
      $self->loader->watch( File::Basename::dirname($psgi) . "/lib", $psgi );
      build { Plack::Util::load_psgi $psgi };
  }
  
  sub watch {
      my($self, @dir) = @_;
  
      push @{$self->{watch}}, @dir
          if $self->{loader} eq 'Restarter';
  }
  
  sub apply_middleware {
      my($self, $app, $class, @args) = @_;
  
      my $mw_class = Plack::Util::load_class($class, 'Plack::Middleware');
      build { $mw_class->wrap($_[0], @args) } $app;
  }
  
  sub prepare_devel {
      my($self, $app) = @_;
  
      if ($self->{default_middleware}) {
          $app = $self->apply_middleware($app, 'Lint');
          $app = $self->apply_middleware($app, 'StackTrace');
          if (!$ENV{GATEWAY_INTERFACE} and !$self->{access_log}) {
              $app = $self->apply_middleware($app, 'AccessLog');
          }
      }
  
      push @{$self->{options}}, server_ready => sub {
          my($args) = @_;
          my $name  = $args->{server_software} || ref($args); # $args is $server
          my $host  = $args->{host} || 0;
          my $proto = $args->{proto} || 'http';
          print STDERR "$name: Accepting connections at $proto://$host:$args->{port}/\n";
      };
  
      $app;
  }
  
  sub loader {
      my $self = shift;
      $self->{_loader} ||= Plack::Util::load_class($self->{loader}, 'Plack::Loader')->new;
  }
  
  sub load_server {
      my($self, $loader) = @_;
  
      if ($self->{server}) {
          return $loader->load($self->{server}, @{$self->{options}});
      } else {
          return $loader->auto(@{$self->{options}});
      }
  }
  
  sub run {
      my $self = shift;
  
      unless (ref $self) {
          $self = $self->new;
          $self->parse_options(@_);
          return $self->run;
      }
  
      unless ($self->{options}) {
          $self->parse_options();
      }
  
      my @args = @_ ? @_ : @{$self->{argv}};
  
      $self->setup;
  
      my $app = $self->locate_app(@args);
  
      if ($self->{path}) {
          require Plack::App::URLMap;
          $app = build {
              my $urlmap = Plack::App::URLMap->new;
              $urlmap->mount($self->{path} => $_[0]);
              $urlmap->to_app;
          } $app;
      }
  
      $ENV{PLACK_ENV} ||= $self->{env} || 'development';
      if ($ENV{PLACK_ENV} eq 'development') {
          $app = $self->prepare_devel($app);
      }
  
      if ($self->{access_log}) {
          open my $logfh, ">>", $self->{access_log}
              or die "open($self->{access_log}): $!";
          $logfh->autoflush(1);
          $app = $self->apply_middleware($app, 'AccessLog', logger => sub { $logfh->print( @_ ) });
      }
  
      my $loader = $self->loader;
      $loader->preload_app($app);
  
      my $server = $self->load_server($loader);
      $loader->run($server);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Runner - plackup core
  
  =head1 SYNOPSIS
  
    # Your bootstrap script
    use Plack::Runner;
    my $app = sub { ... };
  
    my $runner = Plack::Runner->new;
    $runner->parse_options(@ARGV);
    $runner->run($app);
  
  =head1 DESCRIPTION
  
  Plack::Runner is the core of L<plackup> runner script. You can create
  your own frontend to run your application or framework, munge command
  line options and pass that to C<run> method of this class.
  
  C<run> method does exactly the same thing as the L<plackup> script
  does, but one notable addition is that you can pass a PSGI application
  code reference directly to the method, rather than via C<.psgi>
  file path or with C<-e> switch. This would be useful if you want to
  make an installable PSGI application.
  
  Also, when C<-h> or C<--help> switch is passed, the usage text is
  automatically extracted from your own script using L<Pod::Usage>.
  
  =head1 NOTES
  
  Do not directly call this module from your C<.psgi>, since that makes
  your PSGI application unnecessarily depend on L<plackup> and won't run
  other backends like L<Plack::Handler::Apache2> or mod_psgi.
  
  If you I<really> want to make your C<.psgi> runnable as a standalone
  script, you can do this:
  
    my $app = sub { ... };
  
    unless (caller) {
        require Plack::Runner;
        my $runner = Plack::Runner->new;
        $runner->parse_options(@ARGV);
        return $runner->run($app);
    }
  
    return $app;
  
  B<WARNING>: this section used to recommend C<if (__FILE__ eq $0)> but
  it's known to be broken since Plack 0.9971, since C<$0> is now
  I<always> set to the .psgi file path even when you run it from
  plackup.
  
  =head1 SEE ALSO
  
  L<plackup>
  
  =cut
  
  
PLACK_RUNNER

$fatpacked{"Plack/TempBuffer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEMPBUFFER';
  package Plack::TempBuffer;
  use strict;
  use warnings;
  
  use parent 'Stream::Buffered';
  
  sub new {
      my $class = shift;
  
      if (defined $Plack::TempBuffer::MaxMemoryBufferSize) {
          warn "Setting \$Plack::TempBuffer::MaxMemoryBufferSize is deprecated. "
             . "You should set \$Stream::Buffered::MaxMemoryBufferSize instead.";
          $Stream::Buffered::MaxMemoryBufferSize = $Plack::TempBuffer::MaxMemoryBufferSize;
      }
  
      return $class->SUPER::new(@_);
  }
  
  1;
PLACK_TEMPBUFFER

$fatpacked{"Plack/Test.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST';
  package Plack::Test;
  use strict;
  use warnings;
  use Carp;
  use parent qw(Exporter);
  our @EXPORT = qw(test_psgi);
  
  our $Impl;
  $Impl ||= $ENV{PLACK_TEST_IMPL} || "MockHTTP";
  
  sub create {
      my($class, $app, @args) = @_;
  
      my $subclass = "Plack::Test::$Impl";
      eval "require $subclass";
      die $@ if $@;
  
      no strict 'refs';
      if (defined &{"Plack::Test::$Impl\::test_psgi"}) {
          return \&{"Plack::Test::$Impl\::test_psgi"};
      }
  
      $subclass->new($app, @args);
  }
  
  sub test_psgi {
      if (ref $_[0] && @_ == 2) {
          @_ = (app => $_[0], client => $_[1]);
      }
      my %args = @_;
  
      my $app    = delete $args{app}; # Backward compat: some implementations don't need app
      my $client = delete $args{client} or Carp::croak "client test code needed";
  
      my $tester = Plack::Test->create($app, %args);
      return $tester->(@_) if ref $tester eq 'CODE'; # compatibility
  
      $client->(sub { $tester->request(@_) });
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Test - Test PSGI applications with various backends
  
  =head1 SYNOPSIS
  
    use Plack::Test;
    use HTTP::Request::Common;
  
    # Simple OO interface
    my $app = sub { return [ 200, [], [ "Hello "] ] };
    my $test = Plack::Test->create($app);
  
    my $res = $test->request(GET "/");
    is $res->content, "Hello";
  
    # traditional - named params
    test_psgi
        app => sub {
            my $env = shift;
            return [ 200, [ 'Content-Type' => 'text/plain' ], [ "Hello World" ] ],
        },
        client => sub {
            my $cb  = shift;
            my $req = HTTP::Request->new(GET => "http://localhost/hello");
            my $res = $cb->($req);
            like $res->content, qr/Hello World/;
        };
  
    # positional params (app, client)
    my $app = sub { return [ 200, [], [ "Hello "] ] };
    test_psgi $app, sub {
        my $cb  = shift;
        my $res = $cb->(GET "/");
        is $res->content, "Hello";
    };
  
  =head1 DESCRIPTION
  
  Plack::Test is a unified interface to test PSGI applications using
  L<HTTP::Request> and L<HTTP::Response> objects. It also allows you to run PSGI
  applications in various ways. The default backend is C<Plack::Test::MockHTTP>,
  but you may also use any L<Plack::Handler> implementation to run live HTTP
  requests against a web server.
  
  =head1 METHODS
  
  =over 4
  
  =item create
  
    $test = Plack::Test->create($app, %options);
  
  creates an instance of Plack::Test implementation class. C<$app> has
  to be a valid PSGI application code reference.
  
  =item request
  
    $res = $test->request($request);
  
  takes an HTTP::Request object, runs it through the PSGI application to
  test and returns an HTTP::Response object.
  
  =back
  
  =head1 FUNCTIONS
  
  Plack::Test also provides a functional interface that takes two
  callbacks, each of which represents PSGI application and HTTP client
  code that tests the application.
  
  =over 4
  
  =item test_psgi
  
    test_psgi $app, $client;
    test_psgi app => $app, client => $client;
  
  Runs the client test code C<$client> against a PSGI application
  C<$app>. The client callback gets one argument C<$cb>, a
  callback that accepts an C<HTTP::Request> object and returns an
  C<HTTP::Response> object.
  
  Use L<HTTP::Request::Common> to import shortcuts for creating requests for
  C<GET>, C<POST>, C<DELETE>, and C<PUT> operations.
  
  For your convenience, the C<HTTP::Request> given to the callback automatically
  uses the HTTP protocol and the localhost (I<127.0.0.1> by default), so the
  following code just works:
  
    use HTTP::Request::Common;
    test_psgi $app, sub {
        my $cb  = shift;
        my $res = $cb->(GET "/hello");
    };
  
  Note that however, it is not a good idea to pass an arbitrary
  (i.e. user-input) string to C<GET> or even C<<
  HTTP::Request->new >> by assuming that it always represents a path,
  because:
  
    my $req = GET "//foo/bar";
  
  would represent a request for a URL that has no scheme, has a hostname
  I<foo> and a path I</bar>, instead of a path I<//foo/bar> which you
  might actually want.
  
  =back
  
  =head1 OPTIONS
  
  Specify the L<Plack::Test> backend using the environment
  variable C<PLACK_TEST_IMPL> or C<$Plack::Test::Impl> package variable.
  
  The available values for the backend are:
  
  =over 4
  
  =item MockHTTP
  
  (Default) Creates a PSGI env hash out of HTTP::Request object, runs
  the PSGI application in-process and returns HTTP::Response.
  
  =item Server
  
  Runs one of Plack::Handler backends (C<Standalone> by default) and
  sends live HTTP requests to test.
  
  =item ExternalServer
  
  Runs tests against an external server specified in the
  C<PLACK_TEST_EXTERNALSERVER_URI> environment variable instead of spawning the
  application in a server locally.
  
  =back
  
  For instance, test your application with the C<HTTP::Server::ServerSimple>
  server backend with:
  
    > env PLACK_TEST_IMPL=Server PLACK_SERVER=HTTP::Server::ServerSimple \
      prove -l t/test.t
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =cut
PLACK_TEST

$fatpacked{"Plack/Test/MockHTTP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_MOCKHTTP';
  package Plack::Test::MockHTTP;
  use strict;
  use warnings;
  
  use Carp;
  use HTTP::Request;
  use HTTP::Response;
  use HTTP::Message::PSGI;
  use Try::Tiny;
  
  sub new {
      my($class, $app) = @_;
      bless { app => $app }, $class;
  }
  
  sub request {
      my($self, $req) = @_;
  
      $req->uri->scheme('http')    unless defined $req->uri->scheme;
      $req->uri->host('localhost') unless defined $req->uri->host;
      my $env = $req->to_psgi;
  
      my $res = try {
          HTTP::Response->from_psgi($self->{app}->($env));
      } catch {
          HTTP::Response->from_psgi([ 500, [ 'Content-Type' => 'text/plain' ], [ $_ ] ]);
      };
  
      $res->request($req);
      return $res;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Test::MockHTTP - Run mocked HTTP tests through PSGI applications
  
  =head1 DESCRIPTION
  
  Plack::Test::MockHTTP is a utility to run PSGI application given
  HTTP::Request objects and return HTTP::Response object out of PSGI
  application response. See L<Plack::Test> how to use this module.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  =head1 SEE ALSO
  
  L<Plack::Test>
  
  =cut
  
  
PLACK_TEST_MOCKHTTP

$fatpacked{"Plack/Test/Server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_SERVER';
  package Plack::Test::Server;
  use strict;
  use warnings;
  use Carp;
  use HTTP::Request;
  use HTTP::Response;
  use Test::TCP;
  use Plack::Loader;
  use Plack::LWPish;
  
  sub new {
      my($class, $app, %args) = @_;
  
      my $server = Test::TCP->new(
          code => sub {
              my $port = shift;
              my $server = Plack::Loader->auto(port => $port, host => ($args{host} || '127.0.0.1'));
              $server->run($app);
              exit;
          },
      );
  
      bless { server => $server, %args }, $class;
  }
  
  sub port {
      my $self = shift;
      $self->{server}->port;
  }
  
  sub request {
      my($self, $req) = @_;
  
      my $ua = $self->{ua} || Plack::LWPish->new( no_proxy => [qw/127.0.0.1/] );
  
      $req->uri->scheme('http');
      $req->uri->host($self->{host} || '127.0.0.1');
      $req->uri->port($self->port);
  
      return $ua->request($req);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Test::Server - Run HTTP tests through live Plack servers
  
  =head1 DESCRIPTION
  
  Plack::Test::Server is a utility to run PSGI application with Plack
  server implementations, and run the live HTTP tests with the server
  using a callback. See L<Plack::Test> how to use this module.
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  Tokuhiro Matsuno
  
  =head1 SEE ALSO
  
  L<Plack::Loader> L<Test::TCP> L<Plack::Test>
  
  =cut
  
PLACK_TEST_SERVER

$fatpacked{"Plack/Test/Suite.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_TEST_SUITE';
  package Plack::Test::Suite;
  use strict;
  use warnings;
  use Digest::MD5;
  use File::ShareDir;
  use HTTP::Request;
  use HTTP::Request::Common;
  use Test::More;
  use Test::TCP;
  use Plack::Loader;
  use Plack::Middleware::Lint;
  use Plack::Util;
  use Plack::Request;
  use Try::Tiny;
  use Plack::LWPish;
  
  my $share_dir = try { File::ShareDir::dist_dir('Plack') } || 'share';
  
  $ENV{PLACK_TEST_SCRIPT_NAME} = '';
  
  # 0: test name
  # 1: request generator coderef.
  # 2: request handler
  # 3: test case for response
  our @TEST = (
      [
          'SCRIPT_NAME',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is $res->content, "script_name=$ENV{PLACK_TEST_SCRIPT_NAME}";
          },
          sub {
              my $env = shift;
              return [ 200, ["Content-Type", "text/plain"], [ "script_name=$env->{SCRIPT_NAME}" ] ];
          },
      ],
      [
          'GET',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'Hello, name=miyagawa';
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ 'Hello, ' . $env->{QUERY_STRING} ],
              ];
          },
      ],
      [
          'POST',
          sub {
              my $cb = shift;
              my $res = $cb->(POST "http://127.0.0.1/", [name => 'tatsuhiko']);
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('Client-Content-Length'), 14;
              is $res->header('Client-Content-Type'), 'application/x-www-form-urlencoded';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'Hello, name=tatsuhiko';
          },
          sub {
              my $env = shift;
              my $body;
              $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH});
              return [
                  200,
                  [ 'Content-Type' => 'text/plain',
                    'Client-Content-Length' => $env->{CONTENT_LENGTH},
                    'Client-Content-Type' => $env->{CONTENT_TYPE},
                ],
                  [ 'Hello, ' . $body ],
              ];
          },
      ],
      [
          'big POST',
          sub {
              my $cb = shift;
              my $chunk = "abcdefgh" x 12000;
              my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
              $req->content_length(length $chunk);
              $req->content_type('application/octet-stream');
              $req->content($chunk);
  
              my $res = $cb->($req);
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('Client-Content-Length'), length $chunk;
              is length $res->content, length $chunk;
              is Digest::MD5::md5_hex($res->content), Digest::MD5::md5_hex($chunk);
          },
          sub {
              my $env = shift;
              my $len = $env->{CONTENT_LENGTH};
              my $body = '';
              my $spin;
              while ($len > 0) {
                  my $rc = $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}, length $body);
                  $len -= $rc;
                  last if $spin++ > 2000;
              }
              return [
                  200,
                  [ 'Content-Type' => 'text/plain',
                    'Client-Content-Length' => $env->{CONTENT_LENGTH},
                    'Client-Content-Type' => $env->{CONTENT_TYPE},
                ],
                  [ $body ],
              ];
          },
      ],
      [
          'psgi.url_scheme',
          sub {
              my $cb = shift;
              my $res = $cb->(POST "http://127.0.0.1/");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'http';
          },
          sub {
              my $env = $_[0];
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{'psgi.url_scheme'} ],
              ];
          },
      ],
      [
          'return glob',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              like $res->content, qr/^package /;
              like $res->content, qr/END_MARK_FOR_TESTING$/;
          },
          sub {
              my $env = shift;
              open my $fh, '<', __FILE__ or die $!;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  $fh,
              ];
          },
      ],
      [
          'filehandle',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo.jpg");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'image/jpeg';
              is length $res->content, 4745;
          },
          sub {
              my $env = shift;
              open my $fh, '<', "$share_dir/face.jpg";
              return [
                  200,
                  [ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ],
                  $fh
              ];
          },
      ],
      [
          'bigger file',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/baybridge.jpg");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'image/jpeg';
              is length $res->content, 79838;
              is Digest::MD5::md5_hex($res->content), '983726ae0e4ce5081bef5fb2b7216950';
          },
          sub {
              my $env = shift;
              open my $fh, '<', "$share_dir/baybridge.jpg";
              binmode $fh;
              return [
                  200,
                  [ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ],
                  $fh
              ];
          },
      ],
      [
          'handle HTTP-Header',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan", Foo => "Bar");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'Bar';
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$env->{HTTP_FOO}],
              ];
          },
      ],
      [
          'handle HTTP-Cookie',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan", Cookie => "foo");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'foo';
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$env->{HTTP_COOKIE}],
              ];
          },
      ],
      [
          'validate env',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, join("\n",
                  'REQUEST_METHOD:GET',
                  "SCRIPT_NAME:$ENV{PLACK_TEST_SCRIPT_NAME}",
                  'PATH_INFO:/foo/',
                  'QUERY_STRING:dankogai=kogaidan',
                  'SERVER_NAME:127.0.0.1',
                  "SERVER_PORT:" . $res->request->uri->port,
              )."\n";
          },
          sub {
              my $env = shift;
              my $body;
              $body .= $_ . ':' . $env->{$_} . "\n" for qw/REQUEST_METHOD SCRIPT_NAME PATH_INFO QUERY_STRING SERVER_NAME SERVER_PORT/;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$body],
              ];
          },
      ],
      [
          '% encoding in PATH_INFO',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/bar%2cbaz");
              is $res->content, "/foo/bar,baz", "PATH_INFO should be decoded per RFC 3875";
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{PATH_INFO} ],
              ];
          },
      ],
      [
          '% double encoding in PATH_INFO',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/bar%252cbaz");
              is $res->content, "/foo/bar%2cbaz", "PATH_INFO should be decoded only once, per RFC 3875";
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{PATH_INFO} ],
              ];
          },
      ],
      [
          '% encoding in PATH_INFO (outside of URI characters)',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo%E3%81%82");
              is $res->content, "/foo\x{e3}\x{81}\x{82}";
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{PATH_INFO} ],
              ];
          },
      ],
      [
          'SERVER_PROTOCOL is required',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              like $res->content, qr{^HTTP/1\.[01]$};
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$env->{SERVER_PROTOCOL}],
              ];
          },
      ],
      [
          'SCRIPT_NAME should not be undef',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
              is $res->content, 1;
          },
          sub {
              my $env = shift;
              my $cont = defined $env->{'SCRIPT_NAME'};
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$cont],
              ];
          },
      ],
      [
          'call close after read IO::Handle-like',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/call_close");
              is($res->content, '1234');
          },
          sub {
              my $env = shift;
              {
                  our $closed = -1;
                  sub CalledClose::new { $closed = 0; my $i=0; bless \$i, 'CalledClose' }
                  sub CalledClose::getline {
                      my $self = shift;
                      return $$self++ < 4 ? $$self : undef;
                  }
                  sub CalledClose::close { ::ok(1, 'closed') if defined &::ok }
              }
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  CalledClose->new(),
              ];
          },
      ],
      [
          'has errors',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/has_errors");
              is $res->content, 1;
          },
          sub {
              my $env = shift;
              my $err = $env->{'psgi.errors'};
              my $has_errors = defined $err;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [$has_errors]
              ];
          },
      ],
      [
          'status line',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
              is($res->status_line, '200 OK');
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [1]
              ];
          },
      ],
      [
          'Do not crash when the app dies',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is $res->code, 500;
              is $res->message, 'Internal Server Error';
          },
          sub {
              my $env = shift;
              open my $io, '>', \my $error;
              $env->{'psgi.errors'} = $io;
              die "Throwing an exception from app handler. Server shouldn't crash.";
          },
      ],
      [
          'multi headers (request)',
          sub {
              my $cb  = shift;
              my $req = HTTP::Request->new(
                  GET => "http://127.0.0.1/",
              );
              $req->push_header(Foo => "bar");
              $req->push_header(Foo => "baz");
              my $res = $cb->($req);
              like($res->content, qr/^bar,\s*baz$/);
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{HTTP_FOO} ]
              ];
          },
      ],
      [
          'multi headers (response)',
          sub {
              my $cb  = shift;
              my $res = $cb->(HTTP::Request->new(GET => "http://127.0.0.1/"));
              my $foo = $res->header('X-Foo');
              like $foo, qr/foo,\s*bar,\s*baz/;
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', 'X-Foo', 'foo', 'X-Foo', 'bar, baz' ],
                  [ 'hi' ]
              ];
          },
      ],
      [
          'Do not set $env->{COOKIE}',
          sub {
              my $cb  = shift;
              my $req = HTTP::Request->new(
                  GET => "http://127.0.0.1/",
              );
              $req->push_header(Cookie => "foo=bar");
              my $res = $cb->($req);
              is($res->header('X-Cookie'), 0);
              is $res->content, 'foo=bar';
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', 'X-Cookie' => $env->{COOKIE} ? 1 : 0 ],
                  [ $env->{HTTP_COOKIE} ]
              ];
          },
      ],
      [
          'no entity headers on 304',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is $res->code, 304;
              is $res->message, 'Not Modified';
              is $res->content, '';
              ok ! defined $res->header('content_type'), "No Content-Type";
              ok ! defined $res->header('content_length'), "No Content-Length";
              ok ! defined $res->header('transfer_encoding'), "No Transfer-Encoding";
          },
          sub {
              my $env = shift;
              return [ 304, [], [] ];
          },
      ],
      [
          'REQUEST_URI is set',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz%73?x=a");
              is $res->content, $ENV{PLACK_TEST_SCRIPT_NAME} . "/foo/bar%20baz%73?x=a";
          },
          sub {
              my $env = shift;
              return [ 200, [ 'Content-Type' => 'text/plain' ], [ $env->{REQUEST_URI} ] ];
          },
      ],
      [
          'filehandle with path()',
          sub {
              my $cb  = shift;
              my $res = $cb->(GET "http://127.0.0.1/foo.jpg");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'image/jpeg';
              is length $res->content, 4745;
          },
          sub {
              my $env = shift;
              open my $fh, '<', "$share_dir/face.jpg";
              Plack::Util::set_io_path($fh, "$share_dir/face.jpg");
              return [
                  200,
                  [ 'Content-Type' => 'image/jpeg', 'Content-Length' => -s $fh ],
                  $fh
              ];
          },
      ],
      [
          'a big header value > 128 bytes',
          sub {
              my $cb  = shift;
              my $req = GET "http://127.0.0.1/";
              my $v = ("abcdefgh" x 16);
              $req->header('X-Foo' => $v);
              my $res = $cb->($req);
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->content, $v;
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain' ],
                  [ $env->{HTTP_X_FOO} ],
              ];
          },
      ],
      [
          'coderef res',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
              return if $res->code == 501;
  
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'Hello, name=miyagawa';
          },
          sub {
              my $env = shift;
              $env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ];
              return sub {
                  my $respond = shift;
                  $respond->([
                      200,
                      [ 'Content-Type' => 'text/plain', ],
                      [ 'Hello, ' . $env->{QUERY_STRING} ],
                  ]);
              }
          },
      ],
      [
          'coderef streaming',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
              return if $res->code == 501;
  
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, 'Hello, name=miyagawa';
          },
          sub {
              my $env = shift;
              $env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ];
  
              return sub {
                  my $respond = shift;
  
                  my $writer = $respond->([
                      200,
                      [ 'Content-Type' => 'text/plain', ],
                  ]);
  
                  $writer->write("Hello, ");
                  $writer->write($env->{QUERY_STRING});
                  $writer->close();
              }
          },
      ],
      [
          'CRLF output and FCGI parse bug',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
  
              is $res->header("Foo"), undef;
              is $res->content, "Foo: Bar\r\n\r\nHello World";
          },
          sub {
              return [ 200, [ "Content-Type", "text/plain" ], [ "Foo: Bar\r\n\r\nHello World" ] ];
          },
      ],
      [
          'newlines',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is length($res->content), 7;
          },
          sub {
              return [ 200, [ "Content-Type", "text/plain" ], [ "Bar\nBaz" ] ];
          },
      ],
      [
          'test 404',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              is $res->code, 404;
              is $res->message, 'Not Found';
              is $res->content, 'Not Found';
          },
          sub {
              return [ 404, [ "Content-Type", "text/plain" ], [ "Not Found" ] ];
          },
      ],
      [
          'request->input seekable',
          sub {
              my $cb = shift;
              my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
              $req->content("body");
              $req->content_type('text/plain');
              $req->content_length(4);
              my $res = $cb->($req);
              is $res->content, 'body';
          },
          sub {
              my $req = Plack::Request->new(shift);
              return [ 200, [ "Content-Type", "text/plain" ], [ $req->content ] ];
          },
      ],
      [
          'request->content on GET',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1/");
              ok $res->is_success;
          },
          sub {
              my $req = Plack::Request->new(shift);
              $req->content;
              return [ 200, [ "Content-Type", "text/plain" ], [ "OK" ] ];
          },
      ],
      [
          'handle Authorization header',
          sub {
              my $cb  = shift;
              SKIP: {
                  skip "Authorization header is unsupported under CGI", 4 if ($ENV{PLACK_TEST_HANDLER} || "") eq "CGI";
  
                  {
                      my $req = HTTP::Request->new(
                          GET => "http://127.0.0.1/",
                      );
                      $req->push_header(Authorization => 'Basic XXXX');
                      my $res = $cb->($req);
                      is $res->header('X-AUTHORIZATION'), 1;
                      is $res->content, 'Basic XXXX';
                  };
  
                  {
                      my $req = HTTP::Request->new(
                          GET => "http://127.0.0.1/",
                      );
                      my $res = $cb->($req);
                      is $res->header('X-AUTHORIZATION'), 0;
                      is $res->content, 'no_auth';
                  };
              };
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', 'X-AUTHORIZATION' => exists($env->{HTTP_AUTHORIZATION}) ? 1 : 0 ],
                  [ $env->{HTTP_AUTHORIZATION} || 'no_auth' ],
              ];
          },
      ],
      [
          'repeated slashes',
          sub {
              my $cb = shift;
              my $res = $cb->(GET "http://127.0.0.1//foo///bar/baz");
              is $res->code, 200;
              is $res->message, 'OK';
              is $res->header('content_type'), 'text/plain';
              is $res->content, '//foo///bar/baz';
          },
          sub {
              my $env = shift;
              return [
                  200,
                  [ 'Content-Type' => 'text/plain', ],
                  [ $env->{PATH_INFO} ],
              ];
          },
      ],
  );
  
  sub runtests {
      my($class, $runner) = @_;
      for my $test (@TEST) {
          $runner->(@$test);
      }
  }
  
  sub run_server_tests {
      my($class, $server, $server_port, $http_port, %args) = @_;
  
      if (ref $server ne 'CODE') {
          my $server_class = $server;
          $server = sub {
              my($port, $app) = @_;
              my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1", %args);
              $app = Plack::Middleware::Lint->wrap($app);
              $server->run($app);
          }
      }
  
      test_tcp(
          client => sub {
              my $port = shift;
              my $ua = Plack::LWPish->new( no_proxy => [qw/127.0.0.1/] );
              for my $i (0..$#TEST) {
                  my $test = $TEST[$i];
                  note $test->[0];
                  my $cb = sub {
                      my $req = shift;
                      $req->uri->port($http_port || $port);
                      $req->uri->path(($ENV{PLACK_TEST_SCRIPT_NAME}||"") . $req->uri->path);
                      $req->header('X-Plack-Test' => $i);
                      return $ua->request($req);
                  };
  
                  $test->[1]->($cb);
              }
          },
          server => sub {
              my $port = shift;
              my $app  = $class->test_app_handler;
              $server->($port, $app);
              exit(0); # for Test::TCP
          },
          port => $server_port,
      );
  }
  
  sub test_app_handler {
      return sub {
          my $env = shift;
          $TEST[$env->{HTTP_X_PLACK_TEST}][2]->($env);
      };
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Plack::Test::Suite - Test suite for Plack handlers
  
  =head1 SYNOPSIS
  
    use Test::More;
    use Plack::Test::Suite;
    Plack::Test::Suite->run_server_tests('Your::Handler');
    done_testing;
  
  =head1 DESCRIPTION
  
  Plack::Test::Suite is a test suite to test a new PSGI server
  implementation. It automatically loads a new handler environment and
  uses LWP to send HTTP requests to the local server to make sure your
  handler implements the PSGI specification correctly.
  
  Note that the handler name doesn't include the C<Plack::Handler::>
  prefix, i.e. if you have a new Plack handler Plack::Handler::Foo, your
  test script would look like:
  
    Plack::Test::Suite->run_server_tests('Foo');
  
  Developers writing Plack applications should look at C<Plack::Test> for testing,
  as subclassing C<Plack::Handler> is for developing server implementations.
  
  =head1 AUTHOR
  
  Tokuhiro Matsuno
  
  Tatsuhiko Miyagawa
  
  Kazuho Oku
  
  =cut
  
  END_MARK_FOR_TESTING
PLACK_TEST_SUITE

$fatpacked{"Plack/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_UTIL';
  package Plack::Util;
  use strict;
  use Carp ();
  use Scalar::Util;
  use IO::Handle;
  use overload ();
  use File::Spec ();
  
  sub TRUE()  { 1==1 }
  sub FALSE() { !TRUE }
  
  sub load_class {
      my($class, $prefix) = @_;
  
      if ($prefix) {
          unless ($class =~ s/^\+// || $class =~ /^$prefix/) {
              $class = "$prefix\::$class";
          }
      }
  
      my $file = $class;
      $file =~ s!::!/!g;
      require "$file.pm"; ## no critic
  
      return $class;
  }
  
  sub is_real_fh ($) {
      my $fh = shift;
  
      {
          no warnings 'uninitialized';
          return FALSE if -p $fh or -c _ or -b _;
      }
  
      my $reftype = Scalar::Util::reftype($fh) or return;
      if (   $reftype eq 'IO'
          or $reftype eq 'GLOB' && *{$fh}{IO}
      ) {
          # if it's a blessed glob make sure to not break encapsulation with
          # fileno($fh) (e.g. if you are filtering output then file descriptor
          # based operations might no longer be valid).
          # then ensure that the fileno *opcode* agrees too, that there is a
          # valid IO object inside $fh either directly or indirectly and that it
          # corresponds to a real file descriptor.
          my $m_fileno = $fh->fileno;
          return FALSE unless defined $m_fileno;
          return FALSE unless $m_fileno >= 0;
  
          my $f_fileno = fileno($fh);
          return FALSE unless defined $f_fileno;
          return FALSE unless $f_fileno >= 0;
          return TRUE;
      } else {
          # anything else, including GLOBS without IO (even if they are blessed)
          # and non GLOB objects that look like filehandle objects cannot have a
          # valid file descriptor in fileno($fh) context so may break.
          return FALSE;
      }
  }
  
  sub set_io_path {
      my($fh, $path) = @_;
      bless $fh, 'Plack::Util::IOWithPath';
      $fh->path($path);
  }
  
  sub content_length {
      my $body = shift;
  
      return unless defined $body;
  
      if (ref $body eq 'ARRAY') {
          my $cl = 0;
          for my $chunk (@$body) {
              $cl += length $chunk;
          }
          return $cl;
      } elsif ( is_real_fh($body) ) {
          return (-s $body) - tell($body);
      }
  
      return;
  }
  
  sub foreach {
      my($body, $cb) = @_;
  
      if (ref $body eq 'ARRAY') {
          for my $line (@$body) {
              $cb->($line) if length $line;
          }
      } else {
          local $/ = \65536 unless ref $/;
          while (defined(my $line = $body->getline)) {
              $cb->($line) if length $line;
          }
          $body->close;
      }
  }
  
  sub class_to_file {
      my $class = shift;
      $class =~ s!::!/!g;
      $class . ".pm";
  }
  
  sub _load_sandbox {
      my $_file = shift;
  
      my $_package = $_file;
      $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  
      local $0 = $_file; # so FindBin etc. works
      local @ARGV = ();  # Some frameworks might try to parse @ARGV
  
      return eval sprintf <<'END_EVAL', $_package;
  package Plack::Sandbox::%s;
  {
      my $app = do $_file;
      if ( !$app && ( my $error = $@ || $! )) { die $error; }
      $app;
  }
  END_EVAL
  }
  
  sub load_psgi {
      my $stuff = shift;
  
      local $ENV{PLACK_ENV} = $ENV{PLACK_ENV} || 'development';
  
      my $file = $stuff =~ /^[a-zA-Z0-9\_\:]+$/ ? class_to_file($stuff) : File::Spec->rel2abs($stuff);
      my $app = _load_sandbox($file);
      die "Error while loading $file: $@" if $@;
  
      return $app;
  }
  
  sub run_app($$) {
      my($app, $env) = @_;
  
      return eval { $app->($env) } || do {
          my $body = "Internal Server Error";
          $env->{'psgi.errors'}->print($@);
          [ 500, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ], [ $body ] ];
      };
  }
  
  sub headers {
      my $headers = shift;
      inline_object(
          iter   => sub { header_iter($headers, @_) },
          get    => sub { header_get($headers, @_) },
          set    => sub { header_set($headers, @_) },
          push   => sub { header_push($headers, @_) },
          exists => sub { header_exists($headers, @_) },
          remove => sub { header_remove($headers, @_) },
          headers => sub { $headers },
      );
  }
  
  sub header_iter {
      my($headers, $code) = @_;
  
      my @headers = @$headers; # copy
      while (my($key, $val) = splice @headers, 0, 2) {
          $code->($key, $val);
      }
  }
  
  sub header_get {
      my($headers, $key) = (shift, lc shift);
  
      my @val;
      header_iter $headers, sub {
          push @val, $_[1] if lc $_[0] eq $key;
      };
  
      return wantarray ? @val : $val[0];
  }
  
  sub header_set {
      my($headers, $key, $val) = @_;
  
      my($set, @new_headers);
      header_iter $headers, sub {
          if (lc $key eq lc $_[0]) {
              return if $set;
              $_[1] = $val;
              $set++;
          }
          push @new_headers, $_[0], $_[1];
      };
  
      push @new_headers, $key, $val unless $set;
      @$headers = @new_headers;
  }
  
  sub header_push {
      my($headers, $key, $val) = @_;
      push @$headers, $key, $val;
  }
  
  sub header_exists {
      my($headers, $key) = (shift, lc shift);
  
      my $exists;
      header_iter $headers, sub {
          $exists = 1 if lc $_[0] eq $key;
      };
  
      return $exists;
  }
  
  sub header_remove {
      my($headers, $key) = (shift, lc shift);
  
      my @new_headers;
      header_iter $headers, sub {
          push @new_headers, $_[0], $_[1]
              unless lc $_[0] eq $key;
      };
  
      @$headers = @new_headers;
  }
  
  sub status_with_no_entity_body {
      my $status = shift;
      return $status < 200 || $status == 204 || $status == 304;
  }
  
  sub encode_html {
      my $str = shift;
      $str =~ s/&/&amp;/g;
      $str =~ s/>/&gt;/g;
      $str =~ s/</&lt;/g;
      $str =~ s/"/&quot;/g;
      $str =~ s/'/&#39;/g;
      return $str;
  }
  
  sub inline_object {
      my %args = @_;
      bless \%args, 'Plack::Util::Prototype';
  }
  
  sub response_cb {
      my($res, $cb) = @_;
  
      my $body_filter = sub {
          my($cb, $res) = @_;
          my $filter_cb = $cb->($res);
          # If response_cb returns a callback, treat it as a $body filter
          if (defined $filter_cb && ref $filter_cb eq 'CODE') {
              Plack::Util::header_remove($res->[1], 'Content-Length');
              if (defined $res->[2]) {
                  if (ref $res->[2] eq 'ARRAY') {
                      for my $line (@{$res->[2]}) {
                          $line = $filter_cb->($line);
                      }
                      # Send EOF.
                      my $eof = $filter_cb->( undef );
                      push @{ $res->[2] }, $eof if defined $eof;
                  } else {
                      my $body    = $res->[2];
                      my $getline = sub { $body->getline };
                      $res->[2] = Plack::Util::inline_object
                          getline => sub { $filter_cb->($getline->()) },
                          close => sub { $body->close };
                  }
              } else {
                  return $filter_cb;
              }
          }
      };
  
      if (ref $res eq 'ARRAY') {
          $body_filter->($cb, $res);
          return $res;
      } elsif (ref $res eq 'CODE') {
          return sub {
              my $respond = shift;
              my $cb = $cb;  # To avoid the nested closure leak for 5.8.x
              $res->(sub {
                  my $res = shift;
                  my $filter_cb = $body_filter->($cb, $res);
                  if ($filter_cb) {
                      my $writer = $respond->($res);
                      if ($writer) {
                          return Plack::Util::inline_object
                              write => sub { $writer->write($filter_cb->(@_)) },
                              close => sub {
                                  my $chunk = $filter_cb->(undef);
                                  $writer->write($chunk) if defined $chunk;
                                  $writer->close;
                              };
                      }
                  } else {
                      return $respond->($res);
                  }
              });
          };
      }
  
      return $res;
  }
  
  package Plack::Util::Prototype;
  
  our $AUTOLOAD;
  sub can {
      return $_[0]->{$_[1]} if Scalar::Util::blessed($_[0]);
      goto &UNIVERSAL::can;
  }
  
  sub AUTOLOAD {
      my $self = shift;
      my $attr = $AUTOLOAD;
      $attr =~ s/.*://;
      if (ref($self->{$attr}) eq 'CODE') {
          $self->{$attr}->(@_);
      } else {
          Carp::croak(qq/Can't locate object method "$attr" via package "Plack::Util::Prototype"/);
      }
  }
  
  sub DESTROY { }
  
  package Plack::Util::IOWithPath;
  use parent qw(IO::Handle);
  
  sub path {
      my $self = shift;
      if (@_) {
          ${*$self}{+__PACKAGE__} = shift;
      }
      ${*$self}{+__PACKAGE__};
  }
  
  package Plack::Util;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Util - Utility subroutines for Plack server and framework developers
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item TRUE, FALSE
  
    my $true  = Plack::Util::TRUE;
    my $false = Plack::Util::FALSE;
  
  Utility constants to include when you specify boolean variables in C<$env> hash (e.g. C<psgi.multithread>).
  
  =item load_class
  
    my $class = Plack::Util::load_class($class [, $prefix ]);
  
  Constructs a class name and C<require> the class. Throws an exception
  if the .pm file for the class is not found, just with the built-in
  C<require>.
  
  If C<$prefix> is set, the class name is prepended to the C<$class>
  unless C<$class> begins with C<+> sign, which means the class name is
  already fully qualified.
  
    my $class = Plack::Util::load_class("Foo");                   # Foo
    my $class = Plack::Util::load_class("Baz", "Foo::Bar");       # Foo::Bar::Baz
    my $class = Plack::Util::load_class("+XYZ::ZZZ", "Foo::Bar"); # XYZ::ZZZ
  
  Note that this function doesn't validate (or "sanitize") the passed
  string, hence if you pass a user input to this function (which is an
  insecure thing to do in the first place) it might lead to unexpected
  behavior of loading files outside your C<@INC> path. If you want a
  generic module loading function, you should check out CPAN modules
  such as L<Module::Runtime>.
  
  =item is_real_fh
  
    if ( Plack::Util::is_real_fh($fh) ) { }
  
  returns true if a given C<$fh> is a real file handle that has a file
  descriptor. It returns false if C<$fh> is PerlIO handle that is not
  really related to the underlying file etc.
  
  =item content_length
  
    my $cl = Plack::Util::content_length($body);
  
  Returns the length of content from body if it can be calculated. If
  C<$body> is an array ref it's a sum of length of each chunk, if
  C<$body> is a real filehandle it's a remaining size of the filehandle,
  otherwise returns undef.
  
  =item set_io_path
  
    Plack::Util::set_io_path($fh, "/path/to/foobar.txt");
  
  Sets the (absolute) file path to C<$fh> filehandle object, so you can
  call C<< $fh->path >> on it. As a side effect C<$fh> is blessed to an
  internal package but it can still be treated as a normal file
  handle.
  
  This module doesn't normalize or absolutize the given path, and is
  intended to be used from Server or Middleware implementations. See
  also L<IO::File::WithPath>.
  
  =item foreach
  
    Plack::Util::foreach($body, $cb);
  
  Iterate through I<$body> which is an array reference or
  IO::Handle-like object and pass each line (which is NOT really
  guaranteed to be a I<line>) to the callback function.
  
  It internally sets the buffer length C<$/> to 65536 in case it reads
  the binary file, unless otherwise set in the caller's code.
  
  =item load_psgi
  
    my $app = Plack::Util::load_psgi $psgi_file_or_class;
  
  Load C<app.psgi> file or a class name (like C<MyApp::PSGI>) and
  require the file to get PSGI application handler. If the file can't be
  loaded (e.g. file doesn't exist or has a perl syntax error), it will
  throw an exception.
  
  Since version 1.0006, this function would not load PSGI files from
  include paths (C<@INC>) unless it looks like a class name that only
  consists of C<[A-Za-z0-9_:]>. For example:
  
    Plack::Util::load_psgi("app.psgi");          # ./app.psgi
    Plack::Util::load_psgi("/path/to/app.psgi"); # /path/to/app.psgi
    Plack::Util::load_psgi("MyApp::PSGI");       # MyApp/PSGI.pm from @INC
  
  B<Security>: If you give this function a class name or module name
  that is loadable from your system, it will load the module. This could
  lead to a security hole:
  
    my $psgi = ...; # user-input: consider "Moose"
    $app = Plack::Util::load_psgi($psgi); # this would lead to 'require "Moose.pm"'!
  
  Generally speaking, passing an external input to this function is
  considered very insecure. If you really want to do that, validate that
  a given file name contains dots (like C<foo.psgi>) and also turn it
  into a full path in your caller's code.
  
  =item run_app
  
    my $res = Plack::Util::run_app $app, $env;
  
  Runs the I<$app> by wrapping errors with I<eval> and if an error is
  found, logs it to C<< $env->{'psgi.errors'} >> and returns the
  template 500 Error response.
  
  =item header_get, header_exists, header_set, header_push, header_remove
  
    my $hdrs = [ 'Content-Type' => 'text/plain' ];
  
    my $v = Plack::Util::header_get($hdrs, $key); # First found only
    my @v = Plack::Util::header_get($hdrs, $key);
    my $bool = Plack::Util::header_exists($hdrs, $key);
    Plack::Util::header_set($hdrs, $key, $val);   # overwrites existent header
    Plack::Util::header_push($hdrs, $key, $val);
    Plack::Util::header_remove($hdrs, $key);
  
  Utility functions to manipulate PSGI response headers array
  reference. The methods that read existent header value handles header
  name as case insensitive.
  
    my $hdrs = [ 'Content-Type' => 'text/plain' ];
    my $v = Plack::Util::header_get($hdrs, 'content-type'); # 'text/plain'
  
  =item headers
  
    my $headers = [ 'Content-Type' => 'text/plain' ];
  
    my $h = Plack::Util::headers($headers);
    $h->get($key);
    if ($h->exists($key)) { ... }
    $h->set($key => $val);
    $h->push($key => $val);
    $h->remove($key);
    $h->headers; # same reference as $headers
  
  Given a header array reference, returns a convenient object that has
  an instance methods to access C<header_*> functions with an OO
  interface. The object holds a reference to the original given
  C<$headers> argument and updates the reference accordingly when called
  write methods like C<set>, C<push> or C<remove>. It also has C<headers>
  method that would return the same reference.
  
  =item status_with_no_entity_body
  
    if (status_with_no_entity_body($res->[0])) { }
  
  Returns true if the given status code doesn't have any Entity body in
  HTTP response, i.e. it's 100, 101, 204 or 304.
  
  =item inline_object
  
    my $o = Plack::Util::inline_object(
        write => sub { $h->push_write(@_) },
        close => sub { $h->push_shutdown },
    );
    $o->write(@stuff);
    $o->close;
  
  Creates an instant object that can react to methods passed in the
  constructor. Handy to create when you need to create an IO stream
  object for input or errors.
  
  =item encode_html
  
    my $encoded_string = Plack::Util::encode( $string );
  
  Entity encodes C<<>, C<< > >>, C<&>, C<"> and C<'> in the input string
  and returns it.
  
  =item response_cb
  
  See L<Plack::Middleware/RESPONSE CALLBACK> for details.
  
  =back
  
  =cut
  
  
  
PLACK_UTIL

$fatpacked{"Plack/Util/Accessor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PLACK_UTIL_ACCESSOR';
  package Plack::Util::Accessor;
  use strict;
  use warnings;
  
  sub import {
      shift;
      return unless @_;
      my $package = caller();
      mk_accessors( $package, @_ );
  }
  
  sub mk_accessors {
      my $package = shift;
      no strict 'refs';
      foreach my $field ( @_ ) {
          *{ $package . '::' . $field } = sub {
              return $_[0]->{ $field } if scalar( @_ ) == 1;
              return $_[0]->{ $field }  = scalar( @_ ) == 2 ? $_[1] : [ @_[1..$#_] ];
          };
      }
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Plack::Util::Accessor - Accessor generation utility for Plack
  
  =head1 DESCRIPTION
  
  This module is just a simple accessor generator for Plack to replace
  the Class::Accessor::Fast usage and so our classes don't have to inherit
  from their accessor generator.
  
  =head1 SEE ALSO
  
  L<PSGI> L<http://plackperl.org/>
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
PLACK_UTIL_ACCESSOR

$fatpacked{"Starlight.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STARLIGHT';
  package Starlight;
  
  =head1 NAME
  
  Starlight - a light and pure-Perl PSGI/Plack HTTP server with pre-forks
  
  =head1 SYNOPSIS
  
    $ plackup -s Starlight --port=80 [options] your-app.psgi
  
    $ plackup -s Starlight --port=443 --ssl=1 --ssl-key-file=file.key
                           --ssl-cert-file=file.crt [options] your-app.psgi
  
    $ plackup -s Starlight --port=80 --ipv6 [options] your-app.psgi
  
    $ plackup -s Starlight --socket=/tmp/starlight.sock [options] your-app.psgi
  
    $ starlight your-app.psgi
  
  =head1 DESCRIPTION
  
  Starlight is a standalone HTTP/1.1 server with keep-alive support. It uses
  pre-forking. It is pure-Perl implementation which doesn't require any XS
  package.
  
  See L<plackup> and L<starlight> (lower case) for available command line
  options.
  
  =for readme stop
  
  =cut
  
  
  use 5.008_001;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0303';
  
  1;
  
  
  __END__
  
  =head1 SEE ALSO
  
  L<starlight>,
  L<Thrall>,
  L<Starlet>,
  L<Starman>
  
  =head1 AUTHORS
  
  Piotr Roszatycki <dexter@cpan.org>
  
  Based on Thrall by:
  
  Piotr Roszatycki <dexter@cpan.org>
  
  Based on Starlet by:
  
  Kazuho Oku
  
  miyagawa
  
  kazeburo
  
  Some code based on Plack:
  
  Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  Copyright (c) 2013-2014 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
STARLIGHT

$fatpacked{"Starlight/Server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STARLIGHT_SERVER';
  package Starlight::Server;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0303';
  
  use Config;
  
  use English '-no_match_vars';
  use Errno ();
  use File::Spec;
  use Plack;
  use Plack::HTTPParser qw( parse_http_request );
  use IO::Socket::INET;
  use HTTP::Date;
  use HTTP::Status;
  use List::Util qw(max sum);
  use Plack::Util;
  use Plack::TempBuffer;
  use Socket qw(IPPROTO_TCP TCP_NODELAY);
  
  use Try::Tiny;
  
  BEGIN { try { require Time::HiRes; Time::HiRes->import(qw(time)) } }
  
  use constant DEBUG            => $ENV{PERL_STARLIGHT_DEBUG};
  use constant CHUNKSIZE        => 64 * 1024;
  use constant MAX_REQUEST_SIZE => 131072;
  
  use constant HAS_INET6        => eval { AF_INET6 && socket my $ipv6_socket, AF_INET6, SOCK_DGRAM, 0 };
  
  use constant EINTR            => exists &Errno::EINTR ? &Errno::EINTR : -1;
  use constant EAGAIN           => exists &Errno::EAGAIN ? &Errno::EAGAIN : -1;
  use constant EWOULDBLOCK      => exists &Errno::EWOULDBLOCK ? &Errno::EWOULDBLOCK : -1;
  
  
  my $null_io = do { open my $io, "<", \""; $io }; #"
  
  sub new {
      my($class, %args) = @_;
  
      my $self = bless {
          host                 => $args{host},
          port                 => $args{port},
          socket               => $args{socket},
          listen               => $args{listen},
          listen_sock          => $args{listen_sock},
          timeout              => $args{timeout} || 300,
          keepalive_timeout    => $args{keepalive_timeout} || 2,
          max_keepalive_reqs   => $args{max_keepalive_reqs} || 1,
          server_software      => $args{server_software} || "Starlight/$VERSION ($^O)",
          server_ready         => $args{server_ready} || sub {},
          ssl                  => $args{ssl},
          ipv6                 => $args{ipv6},
          ssl_key_file         => $args{ssl_key_file},
          ssl_cert_file        => $args{ssl_cert_file},
          user                 => $args{user},
          group                => $args{group},
          umask                => $args{umask},
          daemonize            => $args{daemonize},
          pid                  => $args{pid},
          error_log            => $args{error_log},
          quiet                => $args{quiet} || $args{q} || $ENV{PLACK_QUIET},
          min_reqs_per_child   => (
              defined $args{min_reqs_per_child}
                  ? $args{min_reqs_per_child} : undef,
          ),
          max_reqs_per_child   => (
              $args{max_reqs_per_child} || $args{max_requests} || 1000,
          ),
          spawn_interval       => $args{spawn_interval} || 0,
          err_respawn_interval => (
              defined $args{err_respawn_interval}
                  ? $args{err_respawn_interval} : undef,
          ),
          main_process_delay   => $args{main_process_delay} || 0.1,
          is_multithread       => Plack::Util::FALSE,
          is_multiprocess      => Plack::Util::FALSE,
          _using_defer_accept  => undef,
          _unlink              => [],
          _sigint              => 'INT',
      }, $class;
  
      # Windows 7 and previous have bad SIGINT handling
      if ($^O eq 'MSWin32') {
          require Win32;
          my @v = Win32::GetOSVersion();
          if ($v[1]*1000 + $v[2] < 6_002) {
              $self->{_sigint} = 'TERM';
          }
      };
  
      if ($args{max_workers} && $args{max_workers} > 1) {
          die(
              "Forking in $class is deprecated. Falling back to the single process mode. ",
              "If you need more workers, use Starlight instead and run like `plackup -s Starlight`\n",
          );
      }
  
      $self;
  }
  
  sub run {
      my($self, $app) = @_;
      $self->setup_listener();
      $self->accept_loop($app);
  }
  
  sub prepare_socket_class {
      my($self, $args) = @_;
  
      if ($self->{socket} and ($self->{port} or $self->{ipv6})) {
          die "UNIX socket and ether IPv4 or IPv6 are not supported at the same time.\n";
      }
  
      if ($self->{ssl} and ($self->{socket} or $self->{ipv6})) {
          die "SSL and either UNIX socket or IPv6 are not supported at the same time.\n";
      }
  
      if ($self->{socket}) {
          try { require IO::Socket::UNIX; 1 }
              or die "UNIX socket suport requires IO::Socket::UNIX\n";
          $args->{Local} =~ s/^@/\0/; # abstract socket address
          return "IO::Socket::UNIX";
      } elsif ($self->{ssl}) {
          try { require IO::Socket::SSL; 1 }
              or die "SSL suport requires IO::Socket::SSL\n";
          $args->{SSL_key_file}  = $self->{ssl_key_file};
          $args->{SSL_cert_file} = $self->{ssl_cert_file};
          return "IO::Socket::SSL";
      } elsif ($self->{ipv6}) {
          try { require IO::Socket::IP; 1 }
              or die "IPv6 support requires IO::Socket::IP\n";
          $self->{host}      ||= '::';
          $args->{LocalAddr} ||= '::';
          return "IO::Socket::IP";
      }
  
      return "IO::Socket::INET";
  }
  
  sub setup_listener {
      my ($self) = @_;
  
      my %args = $self->{socket} ? (
          Listen    => Socket::SOMAXCONN,
          Local     => $self->{socket},
      ) : (
          Listen    => Socket::SOMAXCONN,
          LocalPort => $self->{port} || 5000,
          LocalAddr => $self->{host} || 0,
          Proto     => 'tcp',
          ReuseAddr => 1,
      );
  
      my $proto = $self->{ssl} ? 'https' : 'http';
      my $listening = $self->{socket} ? "socket $self->{socket}" : "port $self->{port}";
  
      my $class = $self->prepare_socket_class(\%args);
      $self->{listen_sock} ||= $class->new(%args)
          or die "failed to listen to $listening: $!\n";
  
      print STDERR "Starting $self->{server_software} $proto server listening at $listening\n"
          unless $self->{quiet};
  
      my $family = Socket::sockaddr_family(getsockname($self->{listen_sock}));
      $self->{_listen_sock_is_unix} = $family == AF_UNIX;
      $self->{_listen_sock_is_tcp}  = $family != AF_UNIX;
  
      # set defer accept
      if ($^O eq 'linux' && $self->{_listen_sock_is_tcp}) {
          setsockopt($self->{listen_sock}, IPPROTO_TCP, 9, 1)
              and $self->{_using_defer_accept} = 1;
      }
  
      if ($self->{_listen_sock_is_unix} && not $args{Local} =~ /^\0/) {
          $self->_add_to_unlink(File::Spec->rel2abs($args{Local}));
      }
  
      $self->{server_ready}->({ %$self, proto => $proto });
  }
  
  sub accept_loop {
      # TODO handle $max_reqs_per_child
      my($self, $app, $max_reqs_per_child) = @_;
      my $proc_req_count = 0;
  
      $self->{can_exit} = 1;
      my $is_keepalive = 0;
      my $sigint = $self->{_sigint};
      local $SIG{$sigint} = local $SIG{TERM} = sub {
          my ($sig) = @_;
          warn "*** SIG$sig received in process $$" if DEBUG;
          exit 0 if $self->{can_exit};
          $self->{term_received}++;
          exit 0
              if ($is_keepalive && $self->{can_exit}) || $self->{term_received} > 1;
          # warn "server termination delayed while handling current HTTP request";
      };
  
      local $SIG{PIPE} = 'IGNORE';
  
      while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
          if (my ($conn,$peer) = $self->{listen_sock}->accept) {
              $self->{_is_deferred_accept} = $self->{_using_defer_accept};
              $conn->blocking(0)
                  or die "failed to set socket to nonblocking mode:$!\n";
              my ($peerport, $peerhost, $peeraddr) = (0, undef, undef);
              if ($self->{_listen_sock_is_tcp}) {
                  $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
                      or die "setsockopt(TCP_NODELAY) failed:$!\n";
                  local $@;
                  if (HAS_INET6 && Socket::sockaddr_family(getsockname($conn)) == AF_INET6) {
                      ($peerport, $peerhost) = Socket::unpack_sockaddr_in6($peer);
                      $peeraddr = Socket::inet_ntop(AF_INET6, $peerhost);
                  } else {
                      ($peerport, $peerhost) = Socket::unpack_sockaddr_in($peer);
                      $peeraddr = Socket::inet_ntoa($peerhost);
                  }
              }
              my $req_count = 0;
              my $pipelined_buf = '';
              while (1) {
                  ++$req_count;
                  ++$proc_req_count;
                  my $env = {
                      SERVER_PORT => $self->{port} || 0,
                      SERVER_NAME => $self->{host} || '*',
                      SCRIPT_NAME => '',
                      REMOTE_ADDR => $peeraddr,
                      REMOTE_PORT => $peerport,
                      'psgi.version' => [ 1, 1 ],
                      'psgi.errors'  => *STDERR,
                      'psgi.url_scheme'   => $self->{ssl} ? 'https' : 'http',
                      'psgi.run_once'     => Plack::Util::FALSE,
                      'psgi.multithread'  => $self->{is_multithread},
                      'psgi.multiprocess' => $self->{is_multiprocess},
                      'psgi.streaming'    => Plack::Util::TRUE,
                      'psgi.nonblocking'  => Plack::Util::FALSE,
                      'psgix.input.buffered' => Plack::Util::TRUE,
                      'psgix.io'          => $conn,
                      'psgix.harakiri'    => Plack::Util::TRUE,
                  };
  
                  my $may_keepalive = $req_count < $self->{max_keepalive_reqs};
                  if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) {
                      $may_keepalive = undef;
                  }
                  $may_keepalive = 1 if length $pipelined_buf;
                  my $keepalive;
                  ($keepalive, $pipelined_buf) = $self->handle_connection($env, $conn, $app,
                                                                          $may_keepalive, $req_count != 1, $pipelined_buf);
  
                  if ($env->{'psgix.harakiri.commit'}) {
                      $conn->close;
                      return;
                  }
                  last unless $keepalive;
                  # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies
              }
              $conn->close;
          }
      }
  }
  
  my $bad_response = [ 400, [ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Bad Request' ] ];
  sub handle_connection {
      my($self, $env, $conn, $app, $use_keepalive, $is_keepalive, $prebuf) = @_;
  
      my $buf = '';
      my $pipelined_buf='';
      my $res = $bad_response;
  
      local $self->{can_exit} = (defined $prebuf) ? 0 : 1;
      while (1) {
          my $rlen;
          if ( $rlen = length $prebuf ) {
              $buf = $prebuf;
              undef $prebuf;
          }
          else {
              $rlen = $self->read_timeout(
                  $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
                  $is_keepalive ? $self->{keepalive_timeout} : $self->{timeout},
              ) or return;
          }
          $self->{can_exit} = 0;
          my $reqlen = parse_http_request($buf, $env);
          if ($reqlen >= 0) {
              # handle request
              my $protocol = $env->{SERVER_PROTOCOL};
              if ($use_keepalive) {
                  if ( $protocol eq 'HTTP/1.1' ) {
                      if (my $c = $env->{HTTP_CONNECTION}) {
                          $use_keepalive = undef
                              if $c =~ /^\s*close\s*/i;
                      }
                  }
                  else {
                      if (my $c = $env->{HTTP_CONNECTION}) {
                          $use_keepalive = undef
                              unless $c =~ /^\s*keep-alive\s*/i;
                      } else {
                          $use_keepalive = undef;
                      }
                  }
              }
              $buf = substr $buf, $reqlen;
              my $chunked = do { no warnings; lc delete $env->{HTTP_TRANSFER_ENCODING} eq 'chunked' };
              if (my $cl = $env->{CONTENT_LENGTH}) {
                  my $buffer = Plack::TempBuffer->new($cl);
                  while ($cl > 0) {
                      my $chunk;
                      if (length $buf) {
                          $chunk = $buf;
                          $buf = '';
                      } else {
                          $self->read_timeout(
                              $conn, \$chunk, $cl, 0, $self->{timeout})
                              or return;
                      }
                      $buffer->print($chunk);
                      $cl -= length $chunk;
                  }
                  $env->{'psgi.input'} = $buffer->rewind;
              }
              elsif ($chunked) {
                  my $buffer = Plack::TempBuffer->new;
                  my $chunk_buffer = '';
                  my $length;
                  DECHUNK: while(1) {
                      my $chunk;
                      if ( length $buf ) {
                          $chunk = $buf;
                          $buf = '';
                      }
                      else {
                          $self->read_timeout($conn, \$chunk, CHUNKSIZE, 0, $self->{timeout})
                              or return;
                      }
  
                      $chunk_buffer .= $chunk;
                      while ( $chunk_buffer =~ s/^(([0-9a-fA-F]+).*\015\012)// ) {
                          my $trailer   = $1;
                          my $chunk_len = hex $2;
                          if ($chunk_len == 0) {
                              last DECHUNK;
                          } elsif (length $chunk_buffer < $chunk_len + 2) {
                              $chunk_buffer = $trailer . $chunk_buffer;
                              last;
                          }
                          $buffer->print(substr $chunk_buffer, 0, $chunk_len, '');
                          $chunk_buffer =~ s/^\015\012//;
                          $length += $chunk_len;
                      }
                  }
                  $env->{CONTENT_LENGTH} = $length;
                  $env->{'psgi.input'} = $buffer->rewind;
              } else {
                  if ( $buf =~ m!^(?:GET|HEAD)! ) { #pipeline
                      $pipelined_buf = $buf;
                      $use_keepalive = 1; #force keepalive
                  } # else clear buffer
                  $env->{'psgi.input'} = $null_io;
              }
  
              if ( $env->{HTTP_EXPECT} ) {
                  if ( $env->{HTTP_EXPECT} eq '100-continue' ) {
                      $self->write_all($conn, "HTTP/1.1 100 Continue\015\012\015\012")
                          or return;
                  } else {
                      $res = [417,[ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Expectation Failed' ] ];
                      last;
                  }
              }
  
              $res = Plack::Util::run_app $app, $env;
              last;
          }
          if ($reqlen == -2) {
              # request is incomplete, do nothing
          } elsif ($reqlen == -1) {
              # error, close conn
              last;
          }
      }
  
      if (ref $res eq 'ARRAY') {
          $self->_handle_response($env->{SERVER_PROTOCOL}, $res, $conn, \$use_keepalive);
      } elsif (ref $res eq 'CODE') {
          $res->(sub {
              $self->_handle_response($env->{SERVER_PROTOCOL}, $_[0], $conn, \$use_keepalive);
          });
      } else {
          die "Bad response $res\n";
      }
      if ($self->{term_received}) {
          exit 0;
      }
  
      return ($use_keepalive, $pipelined_buf);
  }
  
  sub _handle_response {
      my($self, $protocol, $res, $conn, $use_keepalive_r) = @_;
      my $status_code = $res->[0];
      my $headers = $res->[1];
      my $body = $res->[2];
  
      my @lines;
      my %send_headers;
      for (my $i = 0; $i < @$headers; $i += 2) {
          my $k = $headers->[$i];
          my $v = $headers->[$i + 1];
          $v = '' if not defined $v;
          my $lck = lc $k;
          if ($lck eq 'connection') {
              $$use_keepalive_r = undef
                  if $$use_keepalive_r && lc $v ne 'keep-alive';
          } else {
              push @lines, "$k: $v\015\012";
              $send_headers{$lck} = $v;
          }
      }
      if ( ! exists $send_headers{server} ) {
          unshift @lines, "Server: $self->{server_software}\015\012";
      }
      if ( ! exists $send_headers{date} ) {
          unshift @lines, "Date: @{[HTTP::Date::time2str()]}\015\012";
      }
  
      # try to set content-length when keepalive can be used, or disable it
      my $use_chunked;
      if ( $protocol eq 'HTTP/1.0' ) {
          if ($$use_keepalive_r) {
              if (defined $send_headers{'content-length'}
                  || defined $send_headers{'transfer-encoding'}) {
                  # ok
              }
              elsif ( ! Plack::Util::status_with_no_entity_body($status_code)
                      && defined(my $cl = Plack::Util::content_length($body))) {
                  push @lines, "Content-Length: $cl\015\012";
              }
              else {
                  $$use_keepalive_r = undef
              }
          }
          push @lines, "Connection: keep-alive\015\012" if $$use_keepalive_r;
          push @lines, "Connection: close\015\012" if !$$use_keepalive_r; #fmm..
      }
      elsif ( $protocol eq 'HTTP/1.1' ) {
          if (defined $send_headers{'content-length'}
                  || defined $send_headers{'transfer-encoding'}) {
              # ok
          } elsif ( !Plack::Util::status_with_no_entity_body($status_code) ) {
              push @lines, "Transfer-Encoding: chunked\015\012";
              $use_chunked = 1;
          }
          push @lines, "Connection: close\015\012" unless $$use_keepalive_r;
  
      }
  
      unshift @lines, "HTTP/1.1 $status_code @{[ HTTP::Status::status_message($status_code) || 'Unknown' ]}\015\012";
      push @lines, "\015\012";
  
      if (defined $body && ref $body eq 'ARRAY' && @$body == 1
              && defined $body->[0] && length $body->[0] < 8192) {
          # combine response header and small request body
          my $buf = $body->[0];
          if ($use_chunked ) {
              my $len = length $buf;
              $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012" . '0' . "\015\012\015\012";
          }
          $self->write_all(
              $conn, join('', @lines, $buf), $self->{timeout},
          );
          return;
      }
      $self->write_all($conn, join('', @lines), $self->{timeout})
          or return;
  
      if (defined $body) {
          my $failed;
          my $completed;
          my $body_count = (ref $body eq 'ARRAY') ? $#{$body} + 1 : -1;
          Plack::Util::foreach(
              $body,
              sub {
                  unless ($failed) {
                      my $buf = $_[0];
                      --$body_count;
                      if ( $use_chunked ) {
                          my $len = length $buf;
                          return unless $len;
                          $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012";
                          if ( $body_count == 0 ) {
                              $buf .= '0' . "\015\012\015\012";
                              $completed = 1;
                          }
                      }
                      $self->write_all($conn, $buf, $self->{timeout})
                          or $failed = 1;
                  }
              },
          );
          $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked && !$completed;
      } else {
          return Plack::Util::inline_object
              write => sub {
                  my $buf = $_[0];
                  if ( $use_chunked ) {
                      my $len = length $buf;
                      return unless $len;
                      $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012"
                  }
                  $self->write_all($conn, $buf, $self->{timeout})
              },
              close => sub {
                  $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked;
              };
      }
  }
  
  # returns value returned by $cb, or undef on timeout or network error
  sub do_io {
      my ($self, $is_write, $sock, $buf, $len, $off, $timeout) = @_;
      my $ret;
      unless ($is_write || delete $self->{_is_deferred_accept}) {
          goto DO_SELECT;
      }
   DO_READWRITE:
      # try to do the IO
      if ($is_write) {
          $ret = syswrite $sock, $buf, $len, $off
              and return $ret;
      } else {
          $ret = sysread $sock, $$buf, $len, $off
              and return $ret;
      }
      unless ((! defined($ret)
                   && ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK))) {
          return;
      }
      # wait for data
   DO_SELECT:
      while (1) {
          my ($rfd, $wfd);
          my $efd = '';
          vec($efd, fileno($sock), 1) = 1;
          if ($is_write) {
              ($rfd, $wfd) = ('', $efd);
          } else {
              ($rfd, $wfd) = ($efd, '');
          }
          my $start_at = time;
          my $nfound = select($rfd, $wfd, $efd, $timeout);
          $timeout -= (time - $start_at);
          last if $nfound;
          return if $timeout <= 0;
      }
      goto DO_READWRITE;
  }
  
  # returns (positive) number of bytes read, or undef if the socket is to be closed
  sub read_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_io(undef, $sock, $buf, $len, $off, $timeout);
  }
  
  # returns (positive) number of bytes written, or undef if the socket is to be closed
  sub write_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_io(1, $sock, $buf, $len, $off, $timeout);
  }
  
  # writes all data in buf and returns number of bytes written or undef if failed
  sub write_all {
      my ($self, $sock, $buf, $timeout) = @_;
      my $off = 0;
      while (my $len = length($buf) - $off) {
          my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout)
              or return;
          $off += $ret;
      }
      return length $buf;
  }
  
  sub _add_to_unlink {
      my ($self, $filename) = @_;
      push @{$self->{_unlink}}, File::Spec->rel2abs($filename);
  }
  
  sub _daemonize {
      my $self = shift;
  
      if ($^O eq 'MSWin32') {
          foreach my $arg (qw(daemonize pid)) {
              die "$arg parameter is not supported on this platform ($^O)\n" if $self->{$arg};
          }
      }
  
      my ($pidfh, $pidfile);
      if ($self->{pid}) {
          $pidfile = File::Spec->rel2abs($self->{pid});
          if (defined *Fcntl::O_EXCL{CODE}) {
              sysopen $pidfh, $pidfile, Fcntl::O_WRONLY|Fcntl::O_CREAT|Fcntl::O_EXCL
                                                 or die "Cannot open pid file: $self->{pid}: $!\n";
          } else {
              open $pidfh, '>', $pidfile         or die "Cannot open pid file: $self->{pid}: $!\n";
          }
      }
  
      if (defined $self->{error_log}) {
          open STDERR, '>>', $self->{error_log}  or die "Cannot open error log file: $self->{error_log}: $!\n";
      }
  
      if ($self->{daemonize}) {
  
          chdir File::Spec->rootdir              or die "Cannot chdir to root directory: $!\n";
  
          open my $devnull,  '+>', File::Spec->devnull or die "Cannot open null device: $!\n";
  
          open STDIN, '>&', $devnull             or die "Cannot dup null device: $!\n";
          open STDOUT, '>&', $devnull            or die "Cannot dup null device: $!\n";
  
          defined(my $pid = fork)                or die "Cannot fork: $!\n";
          if ($pid) {
              if ($self->{pid} and $pid) {
                  print $pidfh "$pid\n"          or die "Cannot write pidfile $self->{pid}: $!\n";
                  close $pidfh;
                  open STDERR, '>&', $devnull    or die "Cannot dup null device: $!\n";
              }
              exit;
          }
  
          close $pidfh if $pidfh;
  
          if ($Config::Config{d_setsid}) {
              POSIX::setsid()                    or die "Cannot setsid: $!\n";
          }
  
          if (not defined $self->{error_log}) {
              open STDERR, '>&', $devnull        or die "Cannot dup null device: $!\n";
          }
      }
  
      if ($pidfile) {
          $self->_add_to_unlink($pidfile);
      }
  
      return;
  }
  
  sub _setup_privileges {
      my ($self) = @_;
  
      if (defined $self->{group}) {
          if (not $Config::Config{d_setegid}) {
              die "group parameter is not supported on this platform ($^O)\n";
          }
          if ($self->_get_gid($self->{group}) ne $EGID) {
              warn "*** setting group to \"$self->{group}\"" if DEBUG;
              $self->_set_gid($self->{group});
          }
      }
  
      if (defined $self->{user}) {
          if (not $Config::Config{d_seteuid}) {
              die "user parameter is not supported on this platform ($^O)\n";
          }
          if ($self->_get_uid($self->{user}) ne $EUID) {
              warn "*** setting user to \"$self->{user}\"" if DEBUG;
              $self->_set_uid($self->{user});
          }
      }
  
      if (defined $self->{umask}) {
          if (not $Config::Config{d_umask}) {
              die "umask parameter is not supported on this platform ($^O)\n";
          }
          warn "*** setting umask to \"$self->{umask}\"" if DEBUG;
          umask(oct($self->{umask}));
      }
  
      return;
  }
  
  # Taken from Net::Server::Daemonize
  sub _get_uid {
      my ($self, $user) = @_;
      my $uid  = ($user =~ /^(\d+)$/) ? $1 : getpwnam($user);
      die "No such user \"$user\"\n" unless defined $uid;
      return $uid;
  }
  
  # Taken from Net::Server::Daemonize
  sub _get_gid {
      my ($self, @groups) = @_;
      my @gid;
  
      foreach my $group ( split( /[, ]+/, join(" ",@groups) ) ){
          if( $group =~ /^\d+$/ ){
              push @gid, $group;
          }else{
              my $id = getgrnam($group);
              die "No such group \"$group\"\n" unless defined $id;
              push @gid, $id;
          }
      }
  
      die "No group found in arguments.\n" unless @gid;
      return join(" ",$gid[0],@gid);
  }
  
  # Taken from Net::Server::Daemonize
  sub _set_uid {
      my ($self, $user) = @_;
      my $uid = $self->_get_uid($user);
  
      eval { POSIX::setuid($uid) };
      if ($UID != $uid || $EUID != $uid) { # check $> also (rt #21262)
          $UID = $EUID = $uid; # try again - needed by some 5.8.0 linux systems (rt #13450)
          if ($UID != $uid) {
              die "Couldn't become uid \"$uid\": $!\n";
          }
      }
  
      return 1;
  }
  
  # Taken from Net::Server::Daemonize
  sub _set_gid {
      my ($self, @groups) = @_;
      my $gids = $self->_get_gid(@groups);
      my $gid  = (split /\s+/, $gids)[0];
      eval { $) = $gids }; # store all the gids - this is really sort of optional
  
      eval { POSIX::setgid($gid) };
      if (! grep {$gid == $_} split /\s+/, $GID) { # look for any valid id in the list
          die "Couldn't become gid \"$gid\": $!\n";
      }
  
      return 1;
  }
  
  sub _sleep {
      my ($self, $t) = @_;
      select undef, undef, undef, $t if $t;
  }
  
  sub _create_process {
      my ($self, $app) = @_;
      my $pid = fork;
      return warn "cannot fork: $!" unless defined $pid;
  
      if ($pid == 0) {
          warn "*** process $$ starting" if DEBUG;
          eval {
              $self->accept_loop($app, $self->_calc_reqs_per_child());
          };
          warn $@ if $@;
          warn "*** process $$ ending" if DEBUG;
          exit 0;
      } else {
          $self->{processes}->{$pid} = 1;
      }
  }
  
  sub _calc_reqs_per_child {
      my $self = shift;
      my $max = $self->{max_reqs_per_child};
      if (my $min = $self->{min_reqs_per_child}) {
          srand((rand() * 2 ** 30) ^ $$ ^ time);
          return $max - int(($max - $min + 1) * rand);
      } else {
          return $max;
      }
  }
  
  sub DESTROY {
      my ($self) = @_;
      while (my $f = shift @{$self->{_unlink}}) {
          unlink $f;
      }
  }
  
  1;
STARLIGHT_SERVER

$fatpacked{"Stream/Buffered.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STREAM_BUFFERED';
  package Stream::Buffered;
  use strict;
  use warnings;
  
  use FileHandle; # for seek etc.
  use Stream::Buffered::Auto;
  use Stream::Buffered::File;
  use Stream::Buffered::PerlIO;
  
  our $VERSION = 0.03;
  
  our $MaxMemoryBufferSize = 1024 * 1024;
  
  sub new {
      my($class, $length) = @_;
  
      # $MaxMemoryBufferSize = 0  -> Always temp file
      # $MaxMemoryBufferSize = -1 -> Always PerlIO
      my $backend;
      if ($MaxMemoryBufferSize < 0) {
          $backend = "PerlIO";
      } elsif ($MaxMemoryBufferSize == 0) {
          $backend = "File";
      } elsif (!$length) {
          $backend = "Auto";
      } elsif ($length > $MaxMemoryBufferSize) {
          $backend = "File";
      } else {
          $backend = "PerlIO";
      }
  
      $class->create($backend, $length, $MaxMemoryBufferSize);
  }
  
  sub create {
      my($class, $backend, $length, $max) = @_;
      (__PACKAGE__ . "::$backend")->new($length, $max);
  }
  
  sub print;
  sub rewind;
  sub size;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Stream::Buffered - temporary buffer to save bytes
  
  =head1 SYNOPSIS
  
    my $buf = Stream::Buffered->new($length);
    $buf->print($bytes);
  
    my $size = $buf->size;
    my $fh   = $buf->rewind;
  
  =head1 DESCRIPTION
  
  Stream::Buffered is a buffer class to store arbitrary length of byte
  strings and then get a seekable filehandle once everything is
  buffered. It uses PerlIO and/or temporary file to save the buffer
  depending on the length of the size.
  
  =head1 SEE ALSO
  
  L<Plack::Request>
  
  =head1 AUTHOR
  
  Tatsuhiko Miyagawa
  
  This module is part of L<Plack>, released as a separate distribution for easier
  reuse.
  
  =head1 COPYRIGHT
  
  The following copyright notice applies to all the files provided in
  this distribution, including binary files, unless explicitly noted
  otherwise.
  
  Copyright 2009-2011 Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  =cut
STREAM_BUFFERED

$fatpacked{"Stream/Buffered/Auto.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STREAM_BUFFERED_AUTO';
  package Stream::Buffered::Auto;
  use strict;
  use warnings;
  use base 'Stream::Buffered';
  
  sub new {
      my($class, undef, $max_memory_size) = @_;
      bless {
          _buffer => Stream::Buffered->create('PerlIO'),
          _max => $max_memory_size,
      }, $class;
  }
  
  sub print {
      my $self = shift;
      $self->{_buffer}->print(@_);
  
      if ($self->{_max} && $self->{_buffer}->size > $self->{_max}) {
          my $buf = $self->{_buffer}->{buffer};
          $self->{_buffer} = Stream::Buffered->create('File'),
          $self->{_buffer}->print($buf);
          delete $self->{_max};
      }
  }
  
  sub size {
      my $self = shift;
      $self->{_buffer}->size;
  }
  
  sub rewind {
      my $self = shift;
      $self->{_buffer}->rewind;
  }
  
  1;
STREAM_BUFFERED_AUTO

$fatpacked{"Stream/Buffered/File.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STREAM_BUFFERED_FILE';
  package Stream::Buffered::File;
  use strict;
  use warnings;
  use base 'Stream::Buffered';
  
  use IO::File;
  
  sub new {
      my $class = shift;
  
      my $fh = IO::File->new_tmpfile;
      $fh->binmode;
  
      bless { fh => $fh }, $class;
  }
  
  sub print {
      my $self = shift;
      $self->{fh}->print(@_);
  }
  
  sub size {
      my $self = shift;
      $self->{fh}->flush;
      -s $self->{fh};
  }
  
  sub rewind {
      my $self = shift;
      $self->{fh}->seek(0, 0);
      $self->{fh};
  }
  
  1;
STREAM_BUFFERED_FILE

$fatpacked{"Stream/Buffered/PerlIO.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STREAM_BUFFERED_PERLIO';
  package Stream::Buffered::PerlIO;
  use strict;
  use warnings;
  use base 'Stream::Buffered';
  
  sub new {
      my $class = shift;
      bless { buffer => '' }, $class;
  }
  
  sub print {
      my $self = shift;
      $self->{buffer} .= "@_";
  }
  
  sub size {
      my $self = shift;
      length $self->{buffer};
  }
  
  sub rewind {
      my $self = shift;
      my $buffer = $self->{buffer};
      open my $io, "<", \$buffer;
      bless $io, 'FileHandle'; # This makes $io work as FileHandle under 5.8, .10 and .11 :/
      return $io;
  }
  
  1;
STREAM_BUFFERED_PERLIO

$fatpacked{"Thrall.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'THRALL';
  package Thrall;
  
  =head1 NAME
  
  Thrall - a simple PSGI/Plack HTTP server which uses threads
  
  =head1 SYNOPSIS
  
    $ plackup -s Thrall --port=80 [options] your-app.psgi
  
    $ plackup -s Thrall --port=443 --ssl=1 --ssl-key-file=file.key
                        --ssl-cert-file=file.crt [options] your-app.psgi
  
    $ plackup -s Thrall --port=80 --ipv6 [options] your-app.psgi
  
    $ plackup -s Thrall --socket=/tmp/thrall.sock [options] your-app.psgi
  
    $ starlight your-app.psgi
  
  =head1 DESCRIPTION
  
  Thrall is a standalone HTTP/1.1 server with keep-alive support. It uses
  threads instead pre-forking, so it works correctly on Windows. It is pure-Perl
  implementation which doesn't require any XS package.
  
  See L<plackup> and L<thrall> (lower case) for available command line
  options.
  
  =for readme stop
  
  =cut
  
  
  use 5.008_001;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0302';
  
  1;
  
  
  __END__
  
  =head1 SEE ALSO
  
  L<thrall>,
  L<Starlight>,
  L<Starlet>,
  L<Starman>
  
  =head1 AUTHORS
  
  Piotr Roszatycki <dexter@cpan.org>
  
  Based on Starlet by:
  
  Kazuho Oku
  
  miyagawa
  
  kazeburo
  
  Some code based on Plack:
  
  Tatsuhiko Miyagawa
  
  =head1 LICENSE
  
  Copyright (c) 2013-2014 Piotr Roszatycki <dexter@cpan.org>.
  
  This is free software; you can redistribute it and/or modify it under
  the same terms as perl itself.
  
  See L<http://dev.perl.org/licenses/artistic.html>
THRALL

$fatpacked{"Thrall/Server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'THRALL_SERVER';
  package Thrall::Server;
  
  use strict;
  use warnings;
  
  our $VERSION = '0.0302';
  
  use Config;
  
  use if ! $Config{useithreads}, 'forks';
  use threads;
  
  use English '-no_match_vars';
  use Errno ();
  use File::Spec;
  use Plack;
  use Plack::HTTPParser qw( parse_http_request );
  use IO::Socket::INET;
  use HTTP::Date;
  use HTTP::Status;
  use List::Util qw(max sum);
  use Plack::Util;
  use Plack::TempBuffer;
  use Socket qw(IPPROTO_TCP TCP_NODELAY);
  
  use Try::Tiny;
  
  BEGIN { try { require Time::HiRes; Time::HiRes->import(qw(time)) } }
  
  use constant DEBUG            => $ENV{PERL_THRALL_DEBUG};
  use constant CHUNKSIZE        => 64 * 1024;
  use constant MAX_REQUEST_SIZE => 131072;
  
  use constant HAS_INET6        => eval { AF_INET6 && socket my $ipv6_socket, AF_INET6, SOCK_DGRAM, 0 };
  
  use constant EINTR            => exists &Errno::EINTR ? &Errno::EINTR : -1;
  use constant EAGAIN           => exists &Errno::EAGAIN ? &Errno::EAGAIN : -1;
  use constant EWOULDBLOCK      => exists &Errno::EWOULDBLOCK ? &Errno::EWOULDBLOCK : -1;
  
  
  my $null_io = do { open my $io, "<", \""; $io }; #"
  
  sub new {
      my($class, %args) = @_;
  
      my $self = bless {
          host                 => $args{host},
          port                 => $args{port},
          socket               => $args{socket},
          listen               => $args{listen},
          listen_sock          => $args{listen_sock},
          timeout              => $args{timeout} || 300,
          keepalive_timeout    => $args{keepalive_timeout} || 2,
          max_keepalive_reqs   => $args{max_keepalive_reqs} || 1,
          server_software      => $args{server_software} || "Thrall/$VERSION ($^O)",
          server_ready         => $args{server_ready} || sub {},
          ssl                  => $args{ssl},
          ipv6                 => $args{ipv6},
          ssl_key_file         => $args{ssl_key_file},
          ssl_cert_file        => $args{ssl_cert_file},
          user                 => $args{user},
          group                => $args{group},
          umask                => $args{umask},
          daemonize            => $args{daemonize},
          pid                  => $args{pid},
          error_log            => $args{error_log},
          quiet                => $args{quiet} || $args{q} || $ENV{PLACK_QUIET},
          min_reqs_per_child   => (
              defined $args{min_reqs_per_child}
                  ? $args{min_reqs_per_child} : undef,
          ),
          max_reqs_per_child   => (
              $args{max_reqs_per_child} || $args{max_requests} || 1000,
          ),
          spawn_interval       => $args{spawn_interval} || 0,
          err_respawn_interval => (
              defined $args{err_respawn_interval}
                  ? $args{err_respawn_interval} : undef,
          ),
          main_thread_delay    => $args{main_thread_delay} || 0.1,
          thread_stack_size    => (
              defined $args{thread_stack_size}
                  ? $args{thread_stack_size} : undef,
          ),
          is_multithread       => Plack::Util::FALSE,
          is_multiprocess      => Plack::Util::FALSE,
          _using_defer_accept  => undef,
          _unlink              => [],
          _sigint              => 'INT',
      }, $class;
  
      # Windows 7 and previous have bad SIGINT handling
      if ($^O eq 'MSWin32') {
          require Win32;
          my @v = Win32::GetOSVersion();
          if ($v[1]*1000 + $v[2] < 6_002) {
              $self->{_sigint} = 'TERM';
          }
      };
  
      if ($args{max_workers} && $args{max_workers} > 1) {
          die(
              "Threading in $class is deprecated. Falling back to the single thread mode. ",
              "If you need more workers, use Thrall instead and run like `plackup -s Thrall`",
          );
      }
  
      $self;
  }
  
  sub run {
      my($self, $app) = @_;
      $self->setup_listener();
      $self->accept_loop($app);
  }
  
  sub prepare_socket_class {
      my($self, $args) = @_;
  
      if ($self->{socket} and ($self->{port} or $self->{ipv6})) {
          die "UNIX socket and ether IPv4 or IPv6 are not supported at the same time.\n";
      }
  
      if ($self->{ssl} and ($self->{socket} or $self->{ipv6})) {
          die "SSL and either UNIX socket or IPv6 are not supported at the same time.\n";
      }
  
      if ($self->{socket}) {
          try { require IO::Socket::UNIX; 1 }
              or die "UNIX socket suport requires IO::Socket::UNIX\n";
          $args->{Local} =~ s/^@/\0/; # abstract socket address
          return "IO::Socket::UNIX";
      } elsif ($self->{ssl}) {
          try { require IO::Socket::SSL; 1 }
              or die "SSL suport requires IO::Socket::SSL\n";
          $args->{SSL_key_file}  = $self->{ssl_key_file};
          $args->{SSL_cert_file} = $self->{ssl_cert_file};
          return "IO::Socket::SSL";
      } elsif ($self->{ipv6}) {
          try { require IO::Socket::IP; 1 }
              or die "IPv6 support requires IO::Socket::IP\n";
          $self->{host}      ||= '::';
          $args->{LocalAddr} ||= '::';
          return "IO::Socket::IP";
      }
  
      return "IO::Socket::INET";
  }
  
  sub setup_listener {
      my ($self) = @_;
  
      my %args = $self->{socket} ? (
          Listen    => Socket::SOMAXCONN,
          Local     => $self->{socket},
      ) : (
          Listen    => Socket::SOMAXCONN,
          LocalPort => $self->{port} || 5000,
          LocalAddr => $self->{host} || 0,
          Proto     => 'tcp',
          ReuseAddr => 1,
      );
  
      my $proto = $self->{ssl} ? 'https' : 'http';
      my $listening = $self->{socket} ? "socket $self->{socket}" : "port $self->{port}";
  
      my $class = $self->prepare_socket_class(\%args);
      $self->{listen_sock} ||= $class->new(%args)
          or die "failed to listen to $listening: $!\n";
  
      print STDERR "Starting $self->{server_software} $proto server listening at $listening\n"
          unless $self->{quiet};
  
      my $family = Socket::sockaddr_family(getsockname($self->{listen_sock}));
      $self->{_listen_sock_is_unix} = $family == AF_UNIX;
      $self->{_listen_sock_is_tcp}  = $family != AF_UNIX;
  
      # set defer accept
      if ($^O eq 'linux' && $self->{_listen_sock_is_tcp}) {
          setsockopt($self->{listen_sock}, IPPROTO_TCP, 9, 1)
              and $self->{_using_defer_accept} = 1;
      }
  
      if ($self->{_listen_sock_is_unix} && not $args{Local} =~ /^\0/) {
          $self->_add_to_unlink(File::Spec->rel2abs($args{Local}));
      }
  
      $self->{server_ready}->({ %$self, proto => $proto });
  }
  
  sub accept_loop {
      # TODO handle $max_reqs_per_child
      my($self, $app, $max_reqs_per_child) = @_;
      my $proc_req_count = 0;
  
      $self->{can_exit} = 1;
      my $is_keepalive = 0;
      my $sigint = $self->{_sigint};
      local $SIG{$sigint} = local $SIG{TERM} = sub {
          my ($sig) = @_;
          warn "*** SIG$sig received thread ", threads->tid if DEBUG;
          exit 0 if $self->{can_exit};
          $self->{term_received}++;
          exit 0
              if ($is_keepalive && $self->{can_exit}) || $self->{term_received} > 1;
          # warn "server termination delayed while handling current HTTP request";
      };
  
      # Threads don't like simple 'IGNORE'
      local $SIG{PIPE} = sub { 'IGNORE' };
  
      while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
          threads->yield;
          if (my ($conn,$peer) = $self->{listen_sock}->accept) {
              $self->{_is_deferred_accept} = $self->{_using_defer_accept};
              $conn->blocking(0)
                  or die "failed to set socket to nonblocking mode:$!\n";
              my ($peerport, $peerhost, $peeraddr) = (0, undef, undef);
              if ($self->{_listen_sock_is_tcp}) {
                  $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
                      or die "setsockopt(TCP_NODELAY) failed:$!\n";
                  local $@;
                  if (HAS_INET6 && Socket::sockaddr_family(getsockname($conn)) == AF_INET6) {
                      ($peerport, $peerhost) = Socket::unpack_sockaddr_in6($peer);
                      $peeraddr = Socket::inet_ntop(AF_INET6, $peerhost);
                  } else {
                      ($peerport, $peerhost) = Socket::unpack_sockaddr_in($peer);
                      $peeraddr = Socket::inet_ntoa($peerhost);
                  }
              }
              my $req_count = 0;
              my $pipelined_buf = '';
              while (1) {
                  ++$req_count;
                  ++$proc_req_count;
                  my $env = {
                      SERVER_PORT => $self->{port} || 0,
                      SERVER_NAME => $self->{host} || '*',
                      SCRIPT_NAME => '',
                      REMOTE_ADDR => $peeraddr,
                      REMOTE_PORT => $peerport,
                      'psgi.version' => [ 1, 1 ],
                      'psgi.errors'  => *STDERR,
                      'psgi.url_scheme'   => $self->{ssl} ? 'https' : 'http',
                      'psgi.run_once'     => Plack::Util::FALSE,
                      'psgi.multithread'  => $self->{is_multithread},
                      'psgi.multiprocess' => $self->{is_multiprocess},
                      'psgi.streaming'    => Plack::Util::TRUE,
                      'psgi.nonblocking'  => Plack::Util::FALSE,
                      'psgix.input.buffered' => Plack::Util::TRUE,
                      'psgix.io'          => $conn,
                      'psgix.harakiri'    => Plack::Util::TRUE,
                  };
  
                  my $may_keepalive = $req_count < $self->{max_keepalive_reqs};
                  if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) {
                      $may_keepalive = undef;
                  }
                  $may_keepalive = 1 if length $pipelined_buf;
                  my $keepalive;
                  ($keepalive, $pipelined_buf) = $self->handle_connection($env, $conn, $app,
                                                                          $may_keepalive, $req_count != 1, $pipelined_buf);
  
                  if ($env->{'psgix.harakiri.commit'}) {
                      $conn->close;
                      return;
                  }
                  last unless $keepalive;
                  # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies
              }
              $conn->close;
          }
      }
  }
  
  my $bad_response = [ 400, [ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Bad Request' ] ];
  sub handle_connection {
      my($self, $env, $conn, $app, $use_keepalive, $is_keepalive, $prebuf) = @_;
  
      my $buf = '';
      my $pipelined_buf='';
      my $res = $bad_response;
  
      local $self->{can_exit} = (defined $prebuf) ? 0 : 1;
      while (1) {
          my $rlen;
          if ( $rlen = length $prebuf ) {
              $buf = $prebuf;
              undef $prebuf;
          }
          else {
              $rlen = $self->read_timeout(
                  $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
                  $is_keepalive ? $self->{keepalive_timeout} : $self->{timeout},
              ) or return;
          }
          $self->{can_exit} = 0;
          my $reqlen = parse_http_request($buf, $env);
          if ($reqlen >= 0) {
              # handle request
              my $protocol = $env->{SERVER_PROTOCOL};
              if ($use_keepalive) {
                  if ( $protocol eq 'HTTP/1.1' ) {
                      if (my $c = $env->{HTTP_CONNECTION}) {
                          $use_keepalive = undef
                              if $c =~ /^\s*close\s*/i;
                      }
                  }
                  else {
                      if (my $c = $env->{HTTP_CONNECTION}) {
                          $use_keepalive = undef
                              unless $c =~ /^\s*keep-alive\s*/i;
                      } else {
                          $use_keepalive = undef;
                      }
                  }
              }
              $buf = substr $buf, $reqlen;
              my $chunked = do { no warnings; lc delete $env->{HTTP_TRANSFER_ENCODING} eq 'chunked' };
              if (my $cl = $env->{CONTENT_LENGTH}) {
                  my $buffer = Plack::TempBuffer->new($cl);
                  while ($cl > 0) {
                      my $chunk;
                      if (length $buf) {
                          $chunk = $buf;
                          $buf = '';
                      } else {
                          $self->read_timeout(
                              $conn, \$chunk, $cl, 0, $self->{timeout})
                              or return;
                      }
                      $buffer->print($chunk);
                      $cl -= length $chunk;
                  }
                  $env->{'psgi.input'} = $buffer->rewind;
              }
              elsif ($chunked) {
                  my $buffer = Plack::TempBuffer->new;
                  my $chunk_buffer = '';
                  my $length;
                  DECHUNK: while(1) {
                      my $chunk;
                      if ( length $buf ) {
                          $chunk = $buf;
                          $buf = '';
                      }
                      else {
                          $self->read_timeout($conn, \$chunk, CHUNKSIZE, 0, $self->{timeout})
                              or return;
                      }
  
                      $chunk_buffer .= $chunk;
                      while ( $chunk_buffer =~ s/^(([0-9a-fA-F]+).*\015\012)// ) {
                          my $trailer   = $1;
                          my $chunk_len = hex $2;
                          if ($chunk_len == 0) {
                              last DECHUNK;
                          } elsif (length $chunk_buffer < $chunk_len + 2) {
                              $chunk_buffer = $trailer . $chunk_buffer;
                              last;
                          }
                          $buffer->print(substr $chunk_buffer, 0, $chunk_len, '');
                          $chunk_buffer =~ s/^\015\012//;
                          $length += $chunk_len;
                      }
                  }
                  $env->{CONTENT_LENGTH} = $length;
                  $env->{'psgi.input'} = $buffer->rewind;
              } else {
                  if ( $buf =~ m!^(?:GET|HEAD)! ) { #pipeline
                      $pipelined_buf = $buf;
                      $use_keepalive = 1; #force keepalive
                  } # else clear buffer
                  $env->{'psgi.input'} = $null_io;
              }
  
              if ( $env->{HTTP_EXPECT} ) {
                  if ( $env->{HTTP_EXPECT} eq '100-continue' ) {
                      $self->write_all($conn, "HTTP/1.1 100 Continue\015\012\015\012")
                          or return;
                  } else {
                      $res = [417,[ 'Content-Type' => 'text/plain', 'Connection' => 'close' ], [ 'Expectation Failed' ] ];
                      last;
                  }
              }
  
              $res = Plack::Util::run_app $app, $env;
              last;
          }
          if ($reqlen == -2) {
              # request is incomplete, do nothing
          } elsif ($reqlen == -1) {
              # error, close conn
              last;
          }
      }
  
      if (ref $res eq 'ARRAY') {
          $self->_handle_response($env->{SERVER_PROTOCOL}, $res, $conn, \$use_keepalive);
      } elsif (ref $res eq 'CODE') {
          $res->(sub {
              $self->_handle_response($env->{SERVER_PROTOCOL}, $_[0], $conn, \$use_keepalive);
          });
      } else {
          die "Bad response $res\n";
      }
      if ($self->{term_received}) {
          threads->exit;
      }
  
      return ($use_keepalive, $pipelined_buf);
  }
  
  sub _handle_response {
      my($self, $protocol, $res, $conn, $use_keepalive_r) = @_;
      my $status_code = $res->[0];
      my $headers = $res->[1];
      my $body = $res->[2];
  
      my @lines;
      my %send_headers;
      for (my $i = 0; $i < @$headers; $i += 2) {
          my $k = $headers->[$i];
          my $v = $headers->[$i + 1];
          $v = '' if not defined $v;
          my $lck = lc $k;
          if ($lck eq 'connection') {
              $$use_keepalive_r = undef
                  if $$use_keepalive_r && lc $v ne 'keep-alive';
          } else {
              push @lines, "$k: $v\015\012";
              $send_headers{$lck} = $v;
          }
      }
      if ( ! exists $send_headers{server} ) {
          unshift @lines, "Server: $self->{server_software}\015\012";
      }
      if ( ! exists $send_headers{date} ) {
          unshift @lines, "Date: @{[HTTP::Date::time2str()]}\015\012";
      }
  
      # try to set content-length when keepalive can be used, or disable it
      my $use_chunked;
      if ( $protocol eq 'HTTP/1.0' ) {
          if ($$use_keepalive_r) {
              if (defined $send_headers{'content-length'}
                  || defined $send_headers{'transfer-encoding'}) {
                  # ok
              }
              elsif ( ! Plack::Util::status_with_no_entity_body($status_code)
                      && defined(my $cl = Plack::Util::content_length($body))) {
                  push @lines, "Content-Length: $cl\015\012";
              }
              else {
                  $$use_keepalive_r = undef
              }
          }
          push @lines, "Connection: keep-alive\015\012" if $$use_keepalive_r;
          push @lines, "Connection: close\015\012" if !$$use_keepalive_r; #fmm..
      }
      elsif ( $protocol eq 'HTTP/1.1' ) {
          if (defined $send_headers{'content-length'}
                  || defined $send_headers{'transfer-encoding'}) {
              # ok
          } elsif ( !Plack::Util::status_with_no_entity_body($status_code) ) {
              push @lines, "Transfer-Encoding: chunked\015\012";
              $use_chunked = 1;
          }
          push @lines, "Connection: close\015\012" unless $$use_keepalive_r;
  
      }
  
      unshift @lines, "HTTP/1.1 $status_code @{[ HTTP::Status::status_message($status_code) || 'Unknown' ]}\015\012";
      push @lines, "\015\012";
  
      if (defined $body && ref $body eq 'ARRAY' && @$body == 1
              && defined $body->[0] && length $body->[0] < 8192) {
          # combine response header and small request body
          my $buf = $body->[0];
          if ($use_chunked ) {
              my $len = length $buf;
              $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012" . '0' . "\015\012\015\012";
          }
          $self->write_all(
              $conn, join('', @lines, $buf), $self->{timeout},
          );
          return;
      }
      $self->write_all($conn, join('', @lines), $self->{timeout})
          or return;
  
      if (defined $body) {
          my $failed;
          my $completed;
          my $body_count = (ref $body eq 'ARRAY') ? $#{$body} + 1 : -1;
          Plack::Util::foreach(
              $body,
              sub {
                  unless ($failed) {
                      my $buf = $_[0];
                      --$body_count;
                      if ( $use_chunked ) {
                          my $len = length $buf;
                          return unless $len;
                          $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012";
                          if ( $body_count == 0 ) {
                              $buf .= '0' . "\015\012\015\012";
                              $completed = 1;
                          }
                      }
                      $self->write_all($conn, $buf, $self->{timeout})
                          or $failed = 1;
                  }
              },
          );
          $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked && !$completed;
      } else {
          return Plack::Util::inline_object
              write => sub {
                  my $buf = $_[0];
                  if ( $use_chunked ) {
                      my $len = length $buf;
                      return unless $len;
                      $buf = sprintf("%x",$len) . "\015\012" . $buf . "\015\012"
                  }
                  $self->write_all($conn, $buf, $self->{timeout})
              },
              close => sub {
                  $self->write_all($conn, '0' . "\015\012\015\012", $self->{timeout}) if $use_chunked;
              };
      }
  }
  
  # returns value returned by $cb, or undef on timeout or network error
  sub do_io {
      my ($self, $is_write, $sock, $buf, $len, $off, $timeout) = @_;
      my $ret;
      unless ($is_write || delete $self->{_is_deferred_accept}) {
          goto DO_SELECT;
      }
   DO_READWRITE:
      # try to do the IO
      if ($is_write) {
          $ret = syswrite $sock, $buf, $len, $off
              and return $ret;
      } else {
          $ret = sysread $sock, $$buf, $len, $off
              and return $ret;
      }
      unless ((! defined($ret)
                   && ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK))) {
          return;
      }
      # wait for data
   DO_SELECT:
      while (1) {
          my ($rfd, $wfd);
          my $efd = '';
          vec($efd, fileno($sock), 1) = 1;
          if ($is_write) {
              ($rfd, $wfd) = ('', $efd);
          } else {
              ($rfd, $wfd) = ($efd, '');
          }
          my $start_at = time;
          my $nfound = select($rfd, $wfd, $efd, $timeout);
          $timeout -= (time - $start_at);
          last if $nfound;
          return if $timeout <= 0;
      }
      goto DO_READWRITE;
  }
  
  # returns (positive) number of bytes read, or undef if the socket is to be closed
  sub read_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_io(undef, $sock, $buf, $len, $off, $timeout);
  }
  
  # returns (positive) number of bytes written, or undef if the socket is to be closed
  sub write_timeout {
      my ($self, $sock, $buf, $len, $off, $timeout) = @_;
      $self->do_io(1, $sock, $buf, $len, $off, $timeout);
  }
  
  # writes all data in buf and returns number of bytes written or undef if failed
  sub write_all {
      my ($self, $sock, $buf, $timeout) = @_;
      my $off = 0;
      while (my $len = length($buf) - $off) {
          my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout)
              or return;
          $off += $ret;
      }
      return length $buf;
  }
  
  sub _add_to_unlink {
      my ($self, $filename) = @_;
      push @{$self->{_unlink}}, File::Spec->rel2abs($filename);
  }
  
  sub _daemonize {
      my $self = shift;
  
      if ($^O eq 'MSWin32') {
          foreach my $arg (qw(daemonize pid)) {
              die "$arg parameter is not supported on this platform ($^O)\n" if $self->{$arg};
          }
      }
  
      my ($pidfh, $pidfile);
      if ($self->{pid}) {
          $pidfile = File::Spec->rel2abs($self->{pid});
          if (defined *Fcntl::O_EXCL{CODE}) {
              sysopen $pidfh, $pidfile, Fcntl::O_WRONLY|Fcntl::O_CREAT|Fcntl::O_EXCL
                                                 or die "Cannot open pid file: $self->{pid}: $!\n";
          } else {
              open $pidfh, '>', $pidfile         or die "Cannot open pid file: $self->{pid}: $!\n";
          }
      }
  
      if (defined $self->{error_log}) {
          open STDERR, '>>', $self->{error_log}  or die "Cannot open error log file: $self->{error_log}: $!\n";
      }
  
      if ($self->{daemonize}) {
  
          chdir File::Spec->rootdir              or die "Cannot chdir to root directory: $!\n";
  
          open my $devnull,  '+>', File::Spec->devnull or die "Cannot open null device: $!\n";
  
          open STDIN, '>&', $devnull             or die "Cannot dup null device: $!\n";
          open STDOUT, '>&', $devnull            or die "Cannot dup null device: $!\n";
  
          defined(my $pid = fork)                or die "Cannot fork: $!\n";
          if ($pid) {
              if ($self->{pid} and $pid) {
                  print $pidfh "$pid\n"          or die "Cannot write pidfile $self->{pid}: $!\n";
                  close $pidfh;
                  open STDERR, '>&', $devnull    or die "Cannot dup null device: $!\n";
              }
              exit;
          }
  
          close $pidfh if $pidfh;
  
          if ($Config::Config{d_setsid}) {
              POSIX::setsid()                    or die "Cannot setsid: $!\n";
          }
  
          if (not defined $self->{error_log}) {
              open STDERR, '>&', $devnull        or die "Cannot dup null device: $!\n";
          }
      }
  
      if ($pidfile) {
          $self->_add_to_unlink($pidfile);
      }
  
      return;
  }
  
  sub _setup_privileges {
      my ($self) = @_;
  
      if (defined $self->{group}) {
          if (not $Config::Config{d_setegid}) {
              die "group parameter is not supported on this platform ($^O)\n";
          }
          if ($self->_get_gid($self->{group}) ne $EGID) {
              warn "*** setting group to \"$self->{group}\"" if DEBUG;
              $self->_set_gid($self->{group});
          }
      }
  
      if (defined $self->{user}) {
          if (not $Config::Config{d_seteuid}) {
              die "user parameter is not supported on this platform ($^O)\n";
          }
          if ($self->_get_uid($self->{user}) ne $EUID) {
              warn "*** setting user to \"$self->{user}\"" if DEBUG;
              $self->_set_uid($self->{user});
          }
      }
  
      if (defined $self->{umask}) {
          if (not $Config::Config{d_umask}) {
              die "umask parameter is not supported on this platform ($^O)\n";
          }
          warn "*** setting umask to \"$self->{umask}\"" if DEBUG;
          umask(oct($self->{umask}));
      }
  
      return;
  }
  
  # Taken from Net::Server::Daemonize
  sub _get_uid {
      my ($self, $user) = @_;
      my $uid  = ($user =~ /^(\d+)$/) ? $1 : getpwnam($user);
      die "No such user \"$user\"\n" unless defined $uid;
      return $uid;
  }
  
  # Taken from Net::Server::Daemonize
  sub _get_gid {
      my ($self, @groups) = @_;
      my @gid;
  
      foreach my $group ( split( /[, ]+/, join(" ",@groups) ) ){
          if( $group =~ /^\d+$/ ){
              push @gid, $group;
          }else{
              my $id = getgrnam($group);
              die "No such group \"$group\"\n" unless defined $id;
              push @gid, $id;
          }
      }
  
      die "No group found in arguments.\n" unless @gid;
      return join(" ",$gid[0],@gid);
  }
  
  # Taken from Net::Server::Daemonize
  sub _set_uid {
      my ($self, $user) = @_;
      my $uid = $self->_get_uid($user);
  
      eval { POSIX::setuid($uid) };
      if ($UID != $uid || $EUID != $uid) { # check $> also (rt #21262)
          $UID = $EUID = $uid; # try again - needed by some 5.8.0 linux systems (rt #13450)
          if ($UID != $uid) {
              die "Couldn't become uid \"$uid\": $!\n";
          }
      }
  
      return 1;
  }
  
  # Taken from Net::Server::Daemonize
  sub _set_gid {
      my ($self, @groups) = @_;
      my $gids = $self->_get_gid(@groups);
      my $gid  = (split /\s+/, $gids)[0];
      eval { $) = $gids }; # store all the gids - this is really sort of optional
  
      eval { POSIX::setgid($gid) };
      if (! grep {$gid == $_} split /\s+/, $GID) { # look for any valid id in the list
          die "Couldn't become gid \"$gid\": $!\n";
      }
  
      return 1;
  }
  
  sub _sleep {
      my ($self, $t) = @_;
      select undef, undef, undef, $t if $t;
  }
  
  sub _create_thread {
      my ($self, $app) = @_;
      my $thr = threads->create( {context => 'void'},
          sub {
              my ($self, $app) = @_;
              warn "*** thread ", threads->tid, " starting" if DEBUG;
              eval {
                  $self->accept_loop($app, $self->_calc_reqs_per_child());
              };
              warn $@ if $@;
              warn "*** thread ", threads->tid, " ending" if DEBUG;
          },
          $self, $app
      );
  }
  
  sub _calc_reqs_per_child {
      my $self = shift;
      my $max = $self->{max_reqs_per_child};
      if (my $min = $self->{min_reqs_per_child}) {
          srand((rand() * 2 ** 30) ^ $$ ^ time);
          return $max - int(($max - $min + 1) * rand);
      } else {
          return $max;
      }
  }
  
  sub DESTROY {
      my ($self) = @_;
      while (my $f = shift @{$self->{_unlink}}) {
          unlink $f;
      }
  }
  
  1;
THRALL_SERVER

$fatpacked{"Time/Local.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_LOCAL';
  package Time::Local;
  
  require Exporter;
  use Carp;
  use Config;
  use strict;
  
  use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
  $VERSION   = '1.2300';
  
  @ISA       = qw( Exporter );
  @EXPORT    = qw( timegm timelocal );
  @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
  
  my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
  
  # Determine breakpoint for rolling century
  my $ThisYear    = ( localtime() )[5];
  my $Breakpoint  = ( $ThisYear + 50 ) % 100;
  my $NextCentury = $ThisYear - $ThisYear % 100;
  $NextCentury += 100 if $Breakpoint < 50;
  my $Century = $NextCentury - 100;
  my $SecOff  = 0;
  
  my ( %Options, %Cheat );
  
  use constant SECS_PER_MINUTE => 60;
  use constant SECS_PER_HOUR   => 3600;
  use constant SECS_PER_DAY    => 86400;
  
  my $MaxDay;
  if ($] < 5.012000) {
      my $MaxInt;
      if ( $^O eq 'MacOS' ) {
          # time_t is unsigned...
          $MaxInt = ( 1 << ( 8 * $Config{ivsize} ) ) - 1;
      }
      else {
          $MaxInt = ( ( 1 << ( 8 * $Config{ivsize} - 2 ) ) - 1 ) * 2 + 1;
      }
  
      $MaxDay = int( ( $MaxInt - ( SECS_PER_DAY / 2 ) ) / SECS_PER_DAY ) - 1;
  }
  else {
      # recent localtime()'s limit is the year 2**31
      $MaxDay = 365 * (2**31);
  }
  
  # Determine the EPOC day for this machine
  my $Epoc = 0;
  if ( $^O eq 'vos' ) {
      # work around posix-977 -- VOS doesn't handle dates in the range
      # 1970-1980.
      $Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 );
  }
  elsif ( $^O eq 'MacOS' ) {
      $MaxDay *=2 if $^O eq 'MacOS';  # time_t unsigned ... quick hack?
      # MacOS time() is seconds since 1 Jan 1904, localtime
      # so we need to calculate an offset to apply later
      $Epoc = 693901;
      $SecOff = timelocal( localtime(0)) - timelocal( gmtime(0) ) ;
      $Epoc += _daygm( gmtime(0) );
  }
  else {
      $Epoc = _daygm( gmtime(0) );
  }
  
  %Cheat = ();    # clear the cache as epoc has changed
  
  sub _daygm {
  
      # This is written in such a byzantine way in order to avoid
      # lexical variables and sub calls, for speed
      return $_[3] + (
          $Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do {
              my $month = ( $_[4] + 10 ) % 12;
              my $year  = $_[5] + 1900 - int($month / 10);
  
              ( ( 365 * $year )
                + int( $year / 4 )
                - int( $year / 100 )
                + int( $year / 400 )
                + int( ( ( $month * 306 ) + 5 ) / 10 )
              )
              - $Epoc;
          }
      );
  }
  
  sub _timegm {
      my $sec =
          $SecOff + $_[0] + ( SECS_PER_MINUTE * $_[1] ) + ( SECS_PER_HOUR * $_[2] );
  
      return $sec + ( SECS_PER_DAY * &_daygm );
  }
  
  sub timegm {
      my ( $sec, $min, $hour, $mday, $month, $year ) = @_;
  
      if ( $year >= 1000 ) {
          $year -= 1900;
      }
      elsif ( $year < 100 and $year >= 0 ) {
          $year += ( $year > $Breakpoint ) ? $Century : $NextCentury;
      }
  
      unless ( $Options{no_range_check} ) {
          croak "Month '$month' out of range 0..11"
              if $month > 11
              or $month < 0;
  
      my $md = $MonthDays[$month];
          ++$md
              if $month == 1 && _is_leap_year( $year + 1900 );
  
          croak "Day '$mday' out of range 1..$md"  if $mday > $md or $mday < 1;
          croak "Hour '$hour' out of range 0..23"  if $hour > 23  or $hour < 0;
          croak "Minute '$min' out of range 0..59" if $min > 59   or $min < 0;
          croak "Second '$sec' out of range 0..59" if $sec >= 60  or $sec < 0;
      }
  
      my $days = _daygm( undef, undef, undef, $mday, $month, $year );
  
      unless ($Options{no_range_check} or abs($days) < $MaxDay) {
          my $msg = '';
          $msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay;
  
          $year += 1900;
          $msg .=  "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
  
          croak $msg;
      }
  
      return $sec
             + $SecOff
             + ( SECS_PER_MINUTE * $min )
             + ( SECS_PER_HOUR * $hour )
             + ( SECS_PER_DAY * $days );
  }
  
  sub _is_leap_year {
      return 0 if $_[0] % 4;
      return 1 if $_[0] % 100;
      return 0 if $_[0] % 400;
  
      return 1;
  }
  
  sub timegm_nocheck {
      local $Options{no_range_check} = 1;
      return &timegm;
  }
  
  sub timelocal {
      my $ref_t = &timegm;
      my $loc_for_ref_t = _timegm( localtime($ref_t) );
  
      my $zone_off = $loc_for_ref_t - $ref_t
          or return $loc_for_ref_t;
  
      # Adjust for timezone
      my $loc_t = $ref_t - $zone_off;
  
      # Are we close to a DST change or are we done
      my $dst_off = $ref_t - _timegm( localtime($loc_t) );
  
      # If this evaluates to true, it means that the value in $loc_t is
      # the _second_ hour after a DST change where the local time moves
      # backward.
      if ( ! $dst_off &&
           ( ( $ref_t - SECS_PER_HOUR ) - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 )
         ) {
          return $loc_t - SECS_PER_HOUR;
      }
  
      # Adjust for DST change
      $loc_t += $dst_off;
  
      return $loc_t if $dst_off > 0;
  
      # If the original date was a non-extent gap in a forward DST jump,
      # we should now have the wrong answer - undo the DST adjustment
      my ( $s, $m, $h ) = localtime($loc_t);
      $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
  
      return $loc_t;
  }
  
  sub timelocal_nocheck {
      local $Options{no_range_check} = 1;
      return &timelocal;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Time::Local - efficiently compute time from local and GMT time
  
  =head1 SYNOPSIS
  
      $time = timelocal( $sec, $min, $hour, $mday, $mon, $year );
      $time = timegm( $sec, $min, $hour, $mday, $mon, $year );
  
  =head1 DESCRIPTION
  
  This module provides functions that are the inverse of built-in perl
  functions C<localtime()> and C<gmtime()>. They accept a date as a
  six-element array, and return the corresponding C<time(2)> value in
  seconds since the system epoch (Midnight, January 1, 1970 GMT on Unix,
  for example). This value can be positive or negative, though POSIX
  only requires support for positive values, so dates before the
  system's epoch may not work on all operating systems.
  
  It is worth drawing particular attention to the expected ranges for
  the values provided. The value for the day of the month is the actual
  day (ie 1..31), while the month is the number of months since January
  (0..11). This is consistent with the values returned from
  C<localtime()> and C<gmtime()>.
  
  =head1 FUNCTIONS
  
  =head2 C<timelocal()> and C<timegm()>
  
  This module exports two functions by default, C<timelocal()> and
  C<timegm()>.
  
  The C<timelocal()> and C<timegm()> functions perform range checking on
  the input $sec, $min, $hour, $mday, and $mon values by default.
  
  =head2 C<timelocal_nocheck()> and C<timegm_nocheck()>
  
  If you are working with data you know to be valid, you can speed your
  code up by using the "nocheck" variants, C<timelocal_nocheck()> and
  C<timegm_nocheck()>. These variants must be explicitly imported.
  
      use Time::Local 'timelocal_nocheck';
  
      # The 365th day of 1999
      print scalar localtime timelocal_nocheck( 0, 0, 0, 365, 0, 99 );
  
  If you supply data which is not valid (month 27, second 1,000) the
  results will be unpredictable (so don't do that).
  
  =head2 Year Value Interpretation
  
  Strictly speaking, the year should be specified in a form consistent
  with C<localtime()>, i.e. the offset from 1900. In order to make the
  interpretation of the year easier for humans, however, who are more
  accustomed to seeing years as two-digit or four-digit values, the
  following conventions are followed:
  
  =over 4
  
  =item *
  
  Years greater than 999 are interpreted as being the actual year,
  rather than the offset from 1900. Thus, 1964 would indicate the year
  Martin Luther King won the Nobel prize, not the year 3864.
  
  =item *
  
  Years in the range 100..999 are interpreted as offset from 1900, so
  that 112 indicates 2012. This rule also applies to years less than
  zero (but see note below regarding date range).
  
  =item *
  
  Years in the range 0..99 are interpreted as shorthand for years in the
  rolling "current century," defined as 50 years on either side of the
  current year. Thus, today, in 1999, 0 would refer to 2000, and 45 to
  2045, but 55 would refer to 1955. Twenty years from now, 55 would
  instead refer to 2055. This is messy, but matches the way people
  currently think about two digit dates. Whenever possible, use an
  absolute four digit year instead.
  
  =back
  
  The scheme above allows interpretation of a wide range of dates,
  particularly if 4-digit years are used.
  
  =head2 Limits of time_t
  
  On perl versions older than 5.12.0, the range of dates that can be
  actually be handled depends on the size of C<time_t> (usually a signed
  integer) on the given platform. Currently, this is 32 bits for most
  systems, yielding an approximate range from Dec 1901 to Jan 2038.
  
  Both C<timelocal()> and C<timegm()> croak if given dates outside the
  supported range.
  
  As of version 5.12.0, perl has stopped using the underlying time
  library of the operating system it's running on and has its own
  implementation of those routines with a safe range of at least
  +/ 2**52 (about 142 million years).
  
  =head2 Ambiguous Local Times (DST)
  
  Because of DST changes, there are many time zones where the same local
  time occurs for two different GMT times on the same day. For example,
  in the "Europe/Paris" time zone, the local time of 2001-10-28 02:30:00
  can represent either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28
  01:30:00 GMT.
  
  When given an ambiguous local time, the timelocal() function should
  always return the epoch for the I<earlier> of the two possible GMT
  times.
  
  =head2 Non-Existent Local Times (DST)
  
  When a DST change causes a locale clock to skip one hour forward,
  there will be an hour's worth of local times that don't exist. Again,
  for the "Europe/Paris" time zone, the local clock jumped from
  2001-03-25 01:59:59 to 2001-03-25 03:00:00.
  
  If the C<timelocal()> function is given a non-existent local time, it
  will simply return an epoch value for the time one hour later.
  
  =head2 Negative Epoch Values
  
  On perl version 5.12.0 and newer, negative epoch values are fully
  supported.
  
  On older versions of perl, negative epoch (C<time_t>) values, which
  are not officially supported by the POSIX standards, are known not to
  work on some systems. These include MacOS (pre-OSX) and Win32.
  
  On systems which do support negative epoch values, this module should
  be able to cope with dates before the start of the epoch, down the
  minimum value of time_t for the system.
  
  =head1 IMPLEMENTATION
  
  These routines are quite efficient and yet are always guaranteed to
  agree with C<localtime()> and C<gmtime()>. We manage this by caching
  the start times of any months we've seen before. If we know the start
  time of the month, we can always calculate any time within the month.
  The start times are calculated using a mathematical formula. Unlike
  other algorithms that do multiple calls to C<gmtime()>.
  
  The C<timelocal()> function is implemented using the same cache. We
  just assume that we're translating a GMT time, and then fudge it when
  we're done for the timezone and daylight savings arguments. Note that
  the timezone is evaluated for each date because countries occasionally
  change their official timezones. Assuming that C<localtime()> corrects
  for these changes, this routine will also be correct.
  
  =head1 BUGS
  
  The whole scheme for interpreting two-digit years can be considered a
  bug.
  
  =head1 SUPPORT
  
  Support for this module is provided via the datetime@perl.org email
  list. See http://lists.perl.org/ for more details.
  
  Please submit bugs to the CPAN RT system at
  http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Time-Local or via email
  at bug-time-local@rt.cpan.org.
  
  =head1 COPYRIGHT
  
  Copyright (c) 1997-2003 Graham Barr, 2003-2007 David Rolsky.  All
  rights reserved.  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.
  
  =head1 AUTHOR
  
  This module is based on a Perl 4 library, timelocal.pl, that was
  included with Perl 4.036, and was most likely written by Tom
  Christiansen.
  
  The current version was written by Graham Barr.
  
  It is now being maintained separately from the Perl core by Dave
  Rolsky, <autarch@urth.org>.
  
  =cut
TIME_LOCAL

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

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

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

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

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

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

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

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

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

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

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

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

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

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

$fatpacked{"URI/_punycode.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__PUNYCODE';
  package URI::_punycode;
  
  use strict;
  use warnings;
  
  our $VERSION = "1.67";
  
  use Exporter 'import';
  our @EXPORT = qw(encode_punycode decode_punycode);
  
  use integer;
  
  our $DEBUG = 0;
  
  use constant BASE => 36;
  use constant TMIN => 1;
  use constant TMAX => 26;
  use constant SKEW => 38;
  use constant DAMP => 700;
  use constant INITIAL_BIAS => 72;
  use constant INITIAL_N => 128;
  
  my $Delimiter = chr 0x2D;
  my $BasicRE   = qr/[\x00-\x7f]/;
  
  sub _croak { require Carp; Carp::croak(@_); }
  
  sub digit_value {
      my $code = shift;
      return ord($code) - ord("A") if $code =~ /[A-Z]/;
      return ord($code) - ord("a") if $code =~ /[a-z]/;
      return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
      return;
  }
  
  sub code_point {
      my $digit = shift;
      return $digit + ord('a') if 0 <= $digit && $digit <= 25;
      return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
      die 'NOT COME HERE';
  }
  
  sub adapt {
      my($delta, $numpoints, $firsttime) = @_;
      $delta = $firsttime ? $delta / DAMP : $delta / 2;
      $delta += $delta / $numpoints;
      my $k = 0;
      while ($delta > ((BASE - TMIN) * TMAX) / 2) {
  	$delta /= BASE - TMIN;
  	$k += BASE;
      }
      return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
  }
  
  sub decode_punycode {
      my $code = shift;
  
      my $n      = INITIAL_N;
      my $i      = 0;
      my $bias   = INITIAL_BIAS;
      my @output;
  
      if ($code =~ s/(.*)$Delimiter//o) {
  	push @output, map ord, split //, $1;
  	return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
      }
  
      while ($code) {
  	my $oldi = $i;
  	my $w    = 1;
      LOOP:
  	for (my $k = BASE; 1; $k += BASE) {
  	    my $cp = substr($code, 0, 1, '');
  	    my $digit = digit_value($cp);
  	    defined $digit or return _croak("invalid punycode input");
  	    $i += $digit * $w;
  	    my $t = ($k <= $bias) ? TMIN
  		: ($k >= $bias + TMAX) ? TMAX : $k - $bias;
  	    last LOOP if $digit < $t;
  	    $w *= (BASE - $t);
  	}
  	$bias = adapt($i - $oldi, @output + 1, $oldi == 0);
  	warn "bias becomes $bias" if $DEBUG;
  	$n += $i / (@output + 1);
  	$i = $i % (@output + 1);
  	splice(@output, $i, 0, $n);
  	warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
  	$i++;
      }
      return join '', map chr, @output;
  }
  
  sub encode_punycode {
      my $input = shift;
      my @input = split //, $input;
  
      my $n     = INITIAL_N;
      my $delta = 0;
      my $bias  = INITIAL_BIAS;
  
      my @output;
      my @basic = grep /$BasicRE/, @input;
      my $h = my $b = @basic;
      push @output, @basic;
      push @output, $Delimiter if $b && $h < @input;
      warn "basic codepoints: (@output)" if $DEBUG;
  
      while ($h < @input) {
  	my $m = min(grep { $_ >= $n } map ord, @input);
  	warn sprintf "next code point to insert is %04x", $m if $DEBUG;
  	$delta += ($m - $n) * ($h + 1);
  	$n = $m;
  	for my $i (@input) {
  	    my $c = ord($i);
  	    $delta++ if $c < $n;
  	    if ($c == $n) {
  		my $q = $delta;
  	    LOOP:
  		for (my $k = BASE; 1; $k += BASE) {
  		    my $t = ($k <= $bias) ? TMIN :
  			($k >= $bias + TMAX) ? TMAX : $k - $bias;
  		    last LOOP if $q < $t;
  		    my $cp = code_point($t + (($q - $t) % (BASE - $t)));
  		    push @output, chr($cp);
  		    $q = ($q - $t) / (BASE - $t);
  		}
  		push @output, chr(code_point($q));
  		$bias = adapt($delta, $h + 1, $h == $b);
  		warn "bias becomes $bias" if $DEBUG;
  		$delta = 0;
  		$h++;
  	    }
  	}
  	$delta++;
  	$n++;
      }
      return join '', @output;
  }
  
  sub min {
      my $min = shift;
      for (@_) { $min = $_ if $_ <= $min }
      return $min;
  }
  
  1;
  __END__
  
  =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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__QUERY';
  package URI::_query;
  
  use strict;
  use warnings;
  
  use URI ();
  use URI::Escape qw(uri_unescape);
  
  sub query
  {
      my $self = shift;
      $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
  
      if (@_) {
  	my $q = shift;
  	$$self = $1;
  	if (defined $q) {
  	    $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
  	    utf8::downgrade($q);
  	    $$self .= "?$q";
  	}
  	$$self .= $3;
      }
      $2;
  }
  
  # Handle ...?foo=bar&bar=foo type of query
  sub query_form {
      my $self = shift;
      my $old = $self->query;
      if (@_) {
          # Try to set query string
          my $delim;
          my $r = $_[0];
          if (ref($r) eq "ARRAY") {
              $delim = $_[1];
              @_ = @$r;
          }
          elsif (ref($r) eq "HASH") {
              $delim = $_[1];
              @_ = %$r;
          }
          $delim = pop if @_ % 2;
  
          my @query;
          while (my($key,$vals) = splice(@_, 0, 2)) {
              $key = '' unless defined $key;
  	    $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
  	    $key =~ s/ /+/g;
  	    $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
              for my $val (@$vals) {
                  $val = '' unless defined $val;
  		$val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
                  $val =~ s/ /+/g;
                  push(@query, "$key=$val");
              }
          }
          if (@query) {
              unless ($delim) {
                  $delim = $1 if $old && $old =~ /([&;])/;
                  $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
              }
              $self->query(join($delim, @query));
          }
          else {
              $self->query(undef);
          }
      }
      return if !defined($old) || !length($old) || !defined(wantarray);
      return unless $old =~ /=/; # not a form
      map { s/\+/ /g; uri_unescape($_) }
           map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
  }
  
  # Handle ...?dog+bones type of query
  sub query_keywords
  {
      my $self = shift;
      my $old = $self->query;
      if (@_) {
          # Try to set query string
  	my @copy = @_;
  	@copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
  	for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
  	$self->query(@copy ? join('+', @copy) : undef);
      }
      return if !defined($old) || !defined(wantarray);
      return if $old =~ /=/;  # not keywords, but a form
      map { uri_unescape($_) } split(/\+/, $old, -1);
  }
  
  # Some URI::URL compatibility stuff
  sub equery { goto &query }
  
  1;
URI__QUERY

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

$fatpacked{"if.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IF';
  package if;
  
  $VERSION = '0.0603';
  
  sub work {
    my $method = shift() ? 'import' : 'unimport';
    die "Too few arguments to 'use if' (some code returning an empty list in list context?)"
      unless @_ >= 2;
    return unless shift;		# CONDITION
  
    my $p = $_[0];		# PACKAGE
    (my $file = "$p.pm") =~ s!::!/!g;
    require $file;		# Works even if $_[0] is a keyword (like open)
    my $m = $p->can($method);
    goto &$m if $m;
  }
  
  sub import   { shift; unshift @_, 1; goto &work }
  sub unimport { shift; unshift @_, 0; goto &work }
  
  1;
  __END__
  
  =head1 NAME
  
  if - C<use> a Perl module if a condition holds
  
  =head1 SYNOPSIS
  
    use if CONDITION, MODULE => ARGUMENTS;
  
  =head1 DESCRIPTION
  
  The C<if> module is used to conditionally load another module.
  The construct
  
    use if CONDITION, MODULE => ARGUMENTS;
  
  will load MODULE only if CONDITION evaluates to true.
  The above statement has no effect unless C<CONDITION> is true.
  If the CONDITION does evaluate to true, then the above line has
  the same effect as:
  
    use MODULE ARGUMENTS;
  
  The use of C<< => >> above provides necessary quoting of C<MODULE>.
  If you don't use the fat comma (eg you don't have any ARGUMENTS),
  then you'll need to quote the MODULE.
  
  =head2 EXAMPLES
  
  The following line is taken from the testsuite for L<File::Map>:
  
    use if $^O ne 'MSWin32', POSIX => qw/setlocale LC_ALL/;
  
  If run on any operating system other than Windows,
  this will import the functions C<setlocale> and C<LC_ALL> from L<POSIX>.
  On Windows it does nothing.
  
  The following is used to L<deprecate> core modules beyond a certain version of Perl:
  
    use if $] > 5.016, 'deprecate';
  
  This line is taken from L<Text::Soundex> 3.04,
  and marks it as deprecated beyond Perl 5.16.
  If you C<use Text::Soundex> in Perl 5.18, for example,
  and you have used L<warnings>,
  then you'll get a warning message
  (the deprecate module looks to see whether the
  calling module was C<use>'d from a core library directory,
  and if so, generates a warning),
  unless you've installed a more recent version of L<Text::Soundex> from CPAN.
  
  =head1 BUGS
  
  The current implementation does not allow specification of the
  required version of the module.
  
  =head1 SEE ALSO
  
  L<Module::Requires> can be used to conditionally load one or modules,
  with constraints based on the version of the module.
  Unlike C<if> though, L<Module::Requires> is not a core module.
  
  L<Module::Load::Conditional> provides a number of functions you can use to
  query what modules are available, and then load one or more of them at runtime.
  
  L<provide> can be used to select one of several possible modules to load,
  based on what version of Perl is running.
  
  =head1 AUTHOR
  
  Ilya Zakharevich L<mailto:ilyaz@cpan.org>.
  
  =cut
  
IF

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

s/^  //mg for values %fatpacked;

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

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
     if (my $fat = $_[0]{$_[1]}) {
       return sub {
         return 0 unless length $fat;
         $fat =~ s/^([^\n]*\n?)//;
         $_ = $1;
         return 1;
       };
     }
     return;
  };
}

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

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


=head1 NAME

pureproxy - a Pure Perl HTTP proxy server

=cut

no warnings;

our $VERSION = '0.0100';

BEGIN {
    *warnings::import = sub { };
}

use constant SERVER => $ENV{PUREPROXY_SERVER} || $^O =~ /MSWin32|cygwin/ ? 'Thrall' : 'Starlight';

BEGIN {
    delete $ENV{http_proxy};
    delete $ENV{https_proxy};
}

use Plack::Builder;
use Plack::App::Proxy;

my $app = builder {
    enable 'Proxy::Connect::IO';
    enable 'Proxy::Requests';
    Plack::App::Proxy->new(backend => 'HTTP::Tiny')->to_app;
};

use Plack;
use Plack::Runner;

my $runner = Plack::Runner->new(
    server     => SERVER,
    env        => 'proxy',
    loader     => 'Delayed',
    version_cb => \&version,
);

sub _version () {
    my $server = $runner->{server};
    my $server_version = eval { Plack::Util::load_class($server); $server->VERSION }
                      || eval { Plack::Util::load_class("Plack::Handler::$server"); "Plack::Handler::$server"->VERSION }
                      || 0;
    return "PureProxy/$VERSION $server/$server_version Plack/" . Plack->VERSION . " Perl/$] ($^O)";
}

sub version {
    my ($class) = @_;
    print _version(), "\n";
}

$runner->parse_options(@ARGV);

if ($runner->{help}) {
    require Pod::Usage;
    Pod::Usage::pod2usage(-verbose => 1, -input => \*DATA);
}

my %options = @{$runner->{options}};

if ($options{traffic_log}) {
    $body_eol = $options{traffic_log_body_eol};
    if ($options{traffic_log} ne '1') {
        open my $logfh, ">>", $options{traffic_log}
            or die "open($options{traffic_log}): $!";
        $logfh->autoflush(1);
        $app = builder { enable 'TrafficLog', logger => sub { $logfh->print( @_ ) }, body_eol => $body_eol, with_body => !! $body_eol; $app; };
    } else {
        $app = builder { enable 'TrafficLog', body_eol => $body_eol, with_body => !! $body_eol; $app; };
    }
}

if (not defined $runner->{access_log} or $runner->{access_log} eq '1') {
    $runner->{access_log} = undef;
    $app = builder { enable 'AccessLog'; $app; };
}

push @{$runner->{options}}, 'server_software', _version();

$runner->run($app);

__DATA__

=head1 SYNOPSIS

  pureproxy --host=0.0.0.0 --port=5000 --workers=10 --server Starlight

  pureproxy --traffic-log=traffic.log --traffic-log-body-eol='|'

  pureproxy --access-log=access.log

  pureproxy --other-plackup-options

  pureproxy -v

  http_proxy=http://localhost:5000/ lwp-request http://www.perl.org/

  https_proxy=http://localhost:5000/ lwp-request https://metacpan.org/

=head1 DESCRIPTION

This is pure-Perl HTTP proxy server which can be run on almost every Perl
installation.

It supports SSL and TLS if L<IO::Socket::SSL> is installed and IPv6 if
L<IO::Socket::IP> is installed.

It can be fat-packed and then run with any system with standard Perl
interpreter without installing other packages. See F<examples> directory
for fat-packed version of PureProxy script.

=cut

__END__

=head1 ENVIRONMENT

=head2 PUREPROXY_SERVER

Changes the default PSGI server. This is L<Thrall> for C<MSWin32> and C<cygwin>
and L<Starlight> otherwise.

=head1 INSTALLATION

=head2 With cpanm(1)

  $ cpanm App::PureProxy

=head2 Directly

  $ lwp-request http://git.io/jEE6 | sh

or

  $ curl -kL http://git.io/jEE6 | sh

or

  $ wget --quiet -O- http://git.io/jEE6 | sh

=head1 SEE ALSO

L<http://github.com/dex4er/PureProxy>.

=head1 BUGS

This tool has unstable features and can change in future.

=head1 AUTHOR

Piotr Roszatycki <dexter@cpan.org>

=head1 LICENSE

Copyright (c) 2014-2015 Piotr Roszatycki <dexter@cpan.org>.

This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.

See L<http://dev.perl.org/licenses/artistic.html>
