| Category: | CGI Programming |
| Author/Contact Info | dree <dree@perlmongers.it> |
| Description: | This script is a wrapper (or a proxy) for HTTP.
Briefly it allows to redirect to the browser the content of a site target, masking the true address of the target.
As an example, if the site target is www.mysite.suffix and the HTTP wrapper is installed on www.perlmongers.it/cgi-bin/tools/http_wrapper.pl/ (<- notice the final slash) by calling this address, you are browsing the site target. If the site target has links and images indicated with *relative* addresses, the user will not be able to notice that the site target is masked by the wrapper. Of course, ALL will pass for the wrapper, that actually it browses the target page, returning the same page and the objects contained in this, to the user's browser. All that is obviously EXPENSIVE (in computational terms) for the site that executes the wrapper. Always, in presence of relative addresses, it works also with upload, form mail, etc :))) |
#!/usr/bin/perl
# http_wrapperl.pl v0.9.0 by dree <dree@perlmongers.it>
#
# Copyleft: Nordest Perl Mongers (http://www.perlmongers.it)
#
# License: GPL (http://www.gnu.org/copyleft/gpl.html)
use strict;
use CGI;
use LWP::UserAgent;
use HTTP::Request::Common;
my $q=new CGI;
my $ua = LWP::UserAgent->new;
###############
# CONFIGURATION
###############
my $target_base_address=q[http://www.mysite.suffix]; # site target
######
# MAIN
######
my $method;
my $content;
my $submit;
my $content_type;
my $target_remaining_address=$q->path_info();
# method acknowledgment
if ($ENV{REQUEST_METHOD} eq 'POST') {
$method='POST';
} elsif ($ENV{REQUEST_METHOD} eq 'GET') {
$method='GET';
} elsif (index($target_remaining_address,'GET',0) > -1) {
$target_remaining_address=~s#^/GET(.+)#$1#;
$method='GET';
} elsif (index($target_remaining_address,'POST',0) > -1) {
$target_remaining_address=~s#^/POST(.+)#$1#;
$method='POST';
} else {
$method='GET';
}
# management of images & other (if presents) on a *POST* request
if ($method eq 'POST') {
my $other_remaining_on_POST=uc substr($target_remaining_addres
+s,-3,3);
if ($other_remaining_on_POST eq '.JS') {
$method='GET';
} else {
$other_remaining_on_POST=uc substr($target_remaining_addre
+ss,-4,4);
if (($other_remaining_on_POST eq '.GIF')
or ($other_remaining_on_POST eq '.JPG')
or ($other_remaining_on_POST eq '.PNG')
or ($other_remaining_on_POST eq '.CSS')) {
$method='GET';
} else {
$other_remaining_on_POST=uc substr($target_remaining_a
+ddress,-5,5);
if ($other_remaining_on_POST eq '.JPEG') {
$method='GET';
}
}
}
}
my $target_full_address=$target_base_address.$target_remaining_address
+;
if ($ENV{QUERY_STRING}) {
$target_full_address.="?$ENV{QUERY_STRING}";
}
if ($method eq 'POST') {
foreach my $key ($q->param) {
my $val=$q->param("$key");
my $name_attach;
my $tmpfilename;
if (eval {$tmpfilename = $q->tmpFileName($val);}) {
($name_attach=$val)=~s#.+\\(.+)#$1#;
my $type = $q->uploadInfo($val)->{'Content-Type'};
if (!$type) {
$type='application/octet-stream';
}
$content.=qq{$key => ["$tmpfilename",'$name_attach',Conten
+t_Type=>'$type'],};
$method='POST-ATTACH';
} else {
$content.=qq{$key => '$val',};
}
}
}
if ($method eq 'GET') {
$submit=qq{GET '$target_full_address'};
} else {
$submit=qq{POST '$target_full_address'};
if ($method eq 'POST') {
$content_type=q{application/x-www-form-urlencoded};
} elsif ($method eq 'POST-ATTACH') {
$content_type=q{form-data};
}
if ($content) {
chop($content);
$submit.=qq{,
Content_Type => '$content_type',
Content => [$content]
};
}
}
my $ua_out=eval "\$ua->request($submit)";
my $result=${$ua_out}{'_content'};
if (${$ua_out}{'_rc'} eq '302') {
my $location=${$ua_out}{'_headers'}{'location'};
# eventually $location=~s#.+/(.+)#$1#;
$location="http://$ENV{HTTP_HOST}"."$ENV{SCRIPT_NAME}/$location";
print "Location: $location\n\n";
exit;
}
no strict 'refs';
if (${$ua_out}{'_headers'}{'content-type'}[0]) {
$content_type="${$ua_out}{'_headers'}{'content-type'}[0]"
} else {
$content_type="${$ua_out}{'_headers'}{'content-type'}";
}
print "Content-Type: $content_type\n\n";
print $result;
exit;
|
|
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re: http wrapper
by TheHobbit (Pilgrim) on Apr 21, 2002 at 21:21 UTC | |
|
Re: http wrapper
by yodabjorn (Monk) on May 04, 2002 at 10:16 UTC |
Back to
Code Catacombs