view release on metacpan or  search on metacpan

lib/AnyEvent/UWSGI.pm  view on Meta::CPAN

          $env->{PATH_INFO} = Encode::decode('utf8', URI::Escape::XS::uri_unescape($env->{PATH_INFO}));
      }

      foreach my $k (keys %hdr) {
          (my $env_k = uc $k) =~ tr/-/_/;
          $env->{"HTTP_$env_k"} = defined $hdr{$k} ? $hdr{$k} : '';
      }

      my $data = '';
      foreach my $k (sort keys %$env) {
          die "Undef value found for $k" unless defined $env->{$k};
          $data .= pack 'v/a*v/a*', map { Encode::encode('utf8', $_) } $k, $env->{$k};
      }

      my $req_buf = pack('C1v1C1',
          defined $arg{modifier1} ? $arg{modifier1} : 5, # default PSGI_MODIFIER1,
          length($data),
          defined $arg{modifier2} ? $arg{modifier2} : 0, # default PSGI_MODIFIER2,
      ) . $data;

      # send request
      $hdl->push_write($req_buf);

      # return if error occurred during push_write()
      return unless %state;

      # reduce memory usage, save a kitten, also re-use it for the response headers.
      %hdr = ();

      # status line and headers
      $state{read_response} = sub {
         return unless %state;

         for ("$_[1]") {
            y/\015//d; # weed out any \015, as they show up in the weirdest of places.
            /^HTTP\/0*([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\012]*) )? \012/gxci
                or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Invalid server response" };

            # 100 Continue handling
            # should not happen as we don't send expect: 100-continue,
            # but we handle it just in case.
            # since we send the request body regardless, if we get an error
            # we are out of-sync, which we currently do NOT handle correctly.
            return $state{handle}->push_read (line => $qr_nlnl, $state{read_response})
               if $1 eq 100;

            push @pseudo,
               HTTPVersion => $1,
               Status      => $2,
               Reason      => $3,
            ;

            my $hdr = _parse_hdr
               or return _error %state, $cb, { @pseudo, Status => 599, Reason => "Garbled response headers" };

            %hdr = (%$hdr, @pseudo);
         }

         # redirect handling
         # relative uri handling forced by microsoft and other shitheads.
         # we give our best and fall back to URI if available.
         if (exists $hdr{location}) {
            my $loc = $hdr{location};

            if ($loc =~ m%^//%) { # //
               $loc = "$rscheme:$loc";

            } elsif ($loc eq "") {
               $loc = $url;

            } elsif ($loc !~ /^(?: $ | [^:\/?\#]+ : )/x) { # anything "simple"
               $loc =~ s/^\.\/+//;

               if ($loc !~ m%^[.?#]%) {
                  my $prefix = "$rscheme://$uhost:$uport";

                  unless ($loc =~ s/^\///) {
                     $prefix .= $upath;
                     $prefix =~ s/\/[^\/]*$//;
                  }

                  $loc = "$prefix/$loc";

               } elsif (eval { require URI }) { # uri
                  $loc = URI->new_abs ($loc, $url)->as_string;

               } else {
                  return _error %state, $cb, { @pseudo, Status => 599, Reason => "Cannot parse Location (URI module missing)" };
               }
            }

            $hdr{location} = $loc;
         }

         my $redirect;

         if ($recurse) {
            my $status = $hdr{Status};

            # industry standard is to redirect POST as GET for
            # 301, 302 and 303, in contrast to HTTP/1.0 and 1.1.
            # also, the UA should ask the user for 301 and 307 and POST,
            # industry standard seems to be to simply follow.
            # we go with the industry standard. 308 is defined
            # by rfc7538
            if ($status == 301 or $status == 302 or $status == 303) {
               $redirect = 1;
               # HTTP/1.1 is unclear on how to mutate the method
               unless ($method eq "HEAD") {
                  $method = "GET";
                  delete $arg{body};
               }
            } elsif ($status == 307 or $status == 308) {
               $redirect = 1;
            }
         }

         my $finish = sub { # ($data, $err_status, $err_reason[, $persistent])
            if ($state{handle}) {
               # handle keepalive
               if (