http://qs1969.pair.com?node_id=147608
Category: Web Stuff
Author/Contact Info Claudio Garcia (gregorovius) (claudio.garcia@stanfordalumni.org)
Description: A subclass of LWP::UserAgent that replicates Netscape's behavior on redirects after a POST request (ie. it will follow POST redirects but it will turn them into GETs before doing so ). I believe Microsoft's IE behaves like this as well.

A lot of web applications rely on this non-standard behavior in browsers so I think it would be a good idea to integrate this to LWP. See Redirect after POST behavior in LWP::UserAgent differs from Netscape for reference.

Look for the XXX marker in the code to see where this code differs from the one in LWP::UserAgent.

package LWP::NetscapeLikeUserAgent;

use LWP::UserAgent;

use vars qw(@ISA);

@ISA = qw(LWP::UserAgent);


#
# request
#
# Substitutes the default (and standard compliant) "request" method of
+ the
# LWP::UserAgent module for one that behaves like the Netscape browser
+, ie.
# it will follow redirects after POST requests.
#
sub request
{
    my($self, $request, $arg, $size, $previous) = @_;

    LWP::Debug::trace('()');

    my $response = $self->simple_request($request, $arg, $size);

    my $code = $response->code;
    $response->previous($previous) if defined $previous;

    LWP::Debug::debug('Simple response: ' .
              (HTTP::Status::status_message($code) ||
               "Unknown code $code"));

    if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
    $code == &HTTP::Status::RC_MOVED_TEMPORARILY) {

    # Make a copy of the request and initialize it with the new URI
    my $referral = $request->clone;

    # XXX This is where this routine differs from the one in LWP::User
+Agent.
    # If the method of the request is POST then we make the method of 
+the
    # new request be GET, so that it passes the redirect_ok test. This
+ is 
    # non-standard but is the way Netscape does it, and many web appli
+cations
    # rely on this.
    if($request->method eq 'POST') {
        $referral->method('GET');
        $referral->content('');
    }

    # And then we update the URL based on the Location:-header.
    my $referral_uri = $response->header('Location');
    {
        # Some servers erroneously return a relative URL for redirects
+,
        # so make it absolute if it not already is.
        local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
        my $base = $response->base;
        $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
                    ->abs($base);
    }

    $referral->url($referral_uri);

    return $response unless $self->redirect_ok($referral);

    # Check for loop in the redirects
    my $count = 0;
    my $r = $response;
    while ($r) {
        if (++$count > 13 ||
                $r->request->url->as_string eq $referral_uri->as_strin
+g) {
        $response->header("Client-Warning" =>
                  "Redirect loop detected");
        return $response;
        }
        $r = $r->previous;
    }

    return $self->request($referral, $arg, $size, $response);

    } elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
         $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
        )
    {
    my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUI
+RED);
    my $ch_header = $proxy ?  "Proxy-Authenticate" : "WWW-Authenticate
+";
    my @challenge = $response->header($ch_header);
    unless (@challenge) {
        $response->header("Client-Warning" => 
                  "Missing Authenticate header");
        return $response;
    }

    require HTTP::Headers::Util;
    CHALLENGE: for my $challenge (@challenge) {
        $challenge =~ tr/,/;/;  # "," is used to separate auth-params!
+!
        ($challenge) = HTTP::Headers::Util::split_header_words($challe
+nge);
        my $scheme = lc(shift(@$challenge));
        shift(@$challenge); # no value
        $challenge = { @$challenge };  # make rest into a hash
        for (keys %$challenge) {       # make sure all keys are lower 
+case
        $challenge->{lc $_} = delete $challenge->{$_};
        }

        unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
        $response->header("Client-Warning" => 
                  "Bad authentication scheme '$scheme'");
        return $response;
        }
        $scheme = $1;  # untainted now
        my $class = "LWP::Authen::\u$scheme";
        $class =~ s/-/_/g;
    
        no strict 'refs';
        unless (%{"$class\::"}) {
        # try to load it
        eval "require $class";
        if ($@) {
            if ($@ =~ /^Can\'t locate/) {
            $response->header("Client-Warning" =>
                      "Unsupported authentication scheme '$scheme'");
            } else {
            $response->header("Client-Warning" => $@);
            }
            next CHALLENGE;
        }
        }
        return $class->authenticate($self, $proxy, $challenge, $respon
+se,
                    $request, $arg, $size);
    }
    return $response;
    }
    return $response;
}

sub redirect_ok
{
    1;
}

1;