The Labs.Com Issue_11_Proxy

TPJ: Issue_11_Proxy

This is a collection of programs published by The Perl Journal. You can download all source-code also from TPJ: Programs.

Download AdBlocker.pm

package Apache::AdBlocker;

use strict;

use vars qw(@ISA $VERSION);

use Apache::Constants qw(:common);

use GD ();

use Image::Size qw(imgsize);

use LWP::UserAgent ();

@ISA = qw(LWP::UserAgent);

$VERSION = '1.00';

my $UA = __PACKAGE__->new;

$UA->agent(join "/", __PACKAGE__, $VERSION);

my $Ad = join "|", qw{ads? advertisements? banners? adv promotions?};

sub handler {

my($r) = @_;

return DECLINED unless $r->proxyreq;

$r->handler("perl-script"); #ok, let's do it

$r->push_handlers(PerlHandler => \&proxy_handler);

return OK;

}

sub proxy_handler {

my($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') {

my $len = $r->header_in('Content-length');

my $buf;

$r->read($buf, $len);

$request->content($buf);

}

my $response = $UA->request($request);

$r->content_type($response->header('Content-type'));

#feed reponse back into our request_rec*

$r->status($response->code);

$r->status_line(join " ", $response->code, $response->mes\

sage);

$response->scan(sub {

$r->header_out(@_);

});

$r->send_http_header();

my $content = \$response->content;

if($r->content_type =~ /^image/ && $r->uri =~ /\b($Ad)\b/i) \

{

$r->content_type("image/gif");

block_ad($content);

}

$r->print($$content);

return OK;

}

sub block_ad {

my $data = shift;

my($x, $y) = imgsize($data);

my $im = GD::Image->new($x,$y);

my $white = $im->colorAllocate(255,255,255);

my $black = $im->colorAllocate(0,0,0);

my $red = $im->colorAllocate(255,0,0);

$im->transparent($white);

$im->string(GD::gdLargeFont(),5,5,"Blocked Ad",$red);

$im->rectangle(0,0,$x-1,$y-1,$black);

$$data = $im->gif;

}

1;

__END__

Issue_11_Proxy 2. More Samples on Proxy

• Issue_11_Proxy