view release on metacpan or  search on metacpan

lib/Apache/No404Proxy.pm  view on Meta::CPAN

package Apache::No404Proxy;

use strict;
use vars qw($VERSION);
$VERSION = 0.05;

use Apache::Constants qw(:response);
use LWP::UserAgent;
use URI;

sub handler($$) {
    my($class, $r) = @_;
    return DECLINED unless $r->proxyreq;
    $r->handler('perl-script');
    $r->set_handlers(PerlHandler => [ sub { $class->proxy_handler($r); } ]);
    return OK;
}

sub proxy_handler {
    my($class, $r) = @_;
    my $request = HTTP::Request->new($r->method, $r->uri);
    my %headers_in = $r->headers_in;

    while(my($key, $val) = each %headers_in) {
	$request->header($key, $val);
    }

    if ($r->method eq 'POST') {
	$request->content(scalar $r->content);
    }

    my $res = LWP::UserAgent->new->simple_request($request);
    $r->content_type($res->header('Content-type'));

    my $body;
    if ($res->code == 404 && ! $class->exclude($r->uri)) {
	$body = $class->fetch($r);
	unless ($body) {
	    require Apache::Log;
	    $r->log->error('Apache::No404Proxy: no cache found');
	    return NOT_FOUND;
	}
    } else {
	$body = $res->content;
    }

    $r->status($res->code);
    $r->status_line($res->status_line);
    my $table = $r->headers_out;
    $res->scan(sub { $table->add(@_); });
    $r->send_http_header();
    $r->print($body);

    return OK;
}

# default excludes image files
sub exclude {
    my($class, $uri) = @_;
    return $uri =~ /\.(?:gif|jpe?g|png)$/i;
}

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

    # Default to Google. Oddly enough delegating to my own child!
    require Apache::No404Proxy::Google;
    Apache::No404Proxy::Google->fetch($r);
}


1;
__END__

=head1 NAME

Apache::No404Proxy - 404 free Proxy

=head1 SYNOPSIS

  # in httpd.conf