view release on metacpan or  search on metacpan

HTTP.pm  view on Meta::CPAN

   $hdr{te}         = "trailers" unless exists $hdr{te}; #1.1

   my %state = (connect_guard => 1);

   my $ae_error = 595; # connecting

   # handle actual, non-tunneled, request
   my $handle_actual_request = sub {
      $ae_error = 596; # request phase

      my $hdl = $state{handle};

      $hdl->starttls ("connect") if $uscheme eq "https" && !exists $hdl->{tls};

      # send request
      $hdl->push_write (
         "$method $rpath HTTP/1.1\015\012"
         . (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
         . "\015\012"
         . $arg{body}
      );

      # 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 $2 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 = "$uscheme:$loc";

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

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

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

                  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{Status} = 599;
                  #$hdr{Reason} = "Unparsable Redirect (URI module missing)";
                  #$recurse = 0;
               }
            }

            $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])