view release on metacpan or  search on metacpan

lib/Apache2/Proxy.pm  view on Meta::CPAN

            }

        }
        elsif ( grep { $_ eq 'deflate' } @h ) {

            my $copy = $$response_content_ref;
            $$response_content_ref = Compress::Zlib::compress($copy);
            $encoding              = 'deflate';

        }
        else {
            $r->log->error( "$$ unknown content-encoding encountered:  "
                  . join( ',', @h ) );
        }
    }

    if ($encoding) {
        $r->log->debug("$$ setting content encoding to $encoding") if DEBUG;
        $r->content_encoding($encoding);
        delete $headers{'Transfer-Encoding'};    # don't want to be chunked here
    }
    delete $headers{'Content-Encoding'};

    ###########################
    # set the content length to the uncompressed content length
    $r->set_content_length( length($$response_content_ref) );
    delete $headers{'Content-Length'};

    ##########################################
    # this is for any additional headers, usually site specific
    $class->translate_remaining_headers( $r, \%headers );

    ###############################
    # possible through a nasty hack, set the server version
    $r->server->add_version_component( $headers{Server} || 'sl' );

    ###############################
    # maybe someday but not today, do not cache this response
    $r->no_cache(1);

    return 1;
}

# figure out what charset a response was made in, code adapted from
# HTTP::Message::decoded_content
sub response_charset {
    my ( $class, $r, $response ) = @_;

    # pull apart Content-Type header and extract charset
    my $charset;
    my @ct = HTTP::Headers::Util::split_header_words(
        $response->header("Content-Type") );
    if (@ct) {
        my ( undef, undef, %ct_param ) = @{ $ct[-1] };
        $charset = $ct_param{charset};
    }

    # if the charset wasn't in the http header look for meta-equiv
    unless ($charset) {

        # default charset for HTTP::Message - if it couldn't guess it will
        # have decoded as 8859-1, so we need to match that when
        # re-encoding
        return $charset || "ISO-8859-1";
    }
}

sub resolve {
    my ( $class, $hostname ) = @_;

    # run the dns query
    my $query = $Resolver->query($hostname);
    unless ($query) {

        die "dns resolution failed: " . $Resolver->errorstring;

    }
    else {

        foreach my $rr ( $query->answer ) {

            next unless $rr->type eq "A";

            # return the A record
            return $rr->address;
        }
    }

    die "could not resolve A record for $hostname";
}

sub handler {
    my ( $class, $r ) = @_;

    unless ($r->hostname) {
        $r->log->error("$$ no hostname for req " . $r->as_string);
        return Apache2::Const::HTTP_BAD_REQUEST;
    }

    # Build the request headers
    my $headers = $class->get_request_headers($r);

    my $url = $r->construct_url($r->unparsed_uri);
    $r->pnotes('url' => $url);

    my %get = (
        headers      => $headers,
        url          => $url,
    );

    my $ip;
    if ($r->hostname !~ m/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {

        $r->log->debug( "$$ resolving host " . $r->hostname ) if DEBUG;
        $ip = eval { $class->resolve( $r->hostname ) };
        if ($@) {

            # dns error
            $r->log->error( "$$ unable to resolve host " . $r->hostname );
            return &crazypage($r);    # haha this page is kwazy!