#!/usr/bin/perl -w
use strict;
use HTTP::Daemon;
use LWP::UserAgent;
use Data::Dumper;
use URI::Escape qw(uri_unescape uri_escape);
$Data::Dumper::Varname = 'req';
$Data::Dumper::Purity = 1;
use RoboWeb::Util qw(pristine_please);
my $listen_port = 8080;
my $logfile = '/tmp/proxy_log';
sub _gen_page_fetch {
my $request = shift;
my $path = $request->uri->path();
my $url = $request->uri->as_string();
# we don't test for images being there.
return unless ($path !~ /(gif|jpg|jpeg)$/);
# don't save the cookies
$request->header('Cookie' => '');
my $req_code = Dumper $request;
$req_code = uri_escape($req_code);
open LOG, ">>$logfile" or die "could not open $logfile";
print LOG "# print STDERR \"fetching $url\\n\\n\";\n\n";
print LOG "\$req_code = uri_unescape(q{$req_code\});\n";
print LOG "eval(\$req_code);\n";
print LOG "die \"badly frozen request \$!\" if \$\@;\n";
print LOG "\$cookie_jar->add_cookie_header(\$req1);\n";
print LOG "\$resp = \$ua->request(\$req1);\n";
print LOG "die \"could not fetch URL $url\" unless(\$resp->is_succ
+ess());\n";
print LOG "\$cookie_jar->extract_cookies(\$resp);\n";
print LOG "\$html = \$resp->content();\n";
print LOG "#print STDERR \$html;\n";
print LOG "#print STDERR \"\\n\\n\", '*' x 70, \"\\n\\n\";";
print LOG "\n\n\n\n";
close LOG;
}
sub _start_rec {
&pristine_please;
open LOG, ">$logfile" or die "could not open $logfile";
print LOG "#!/usr/bin/perl -w\n\n";
print LOG "use RoboWeb::NetscapeLikeUA;\n";
print LOG "use HTTP::Cookies;\n";
print LOG "use URI::http;\n";
print LOG "use URI::Escape qw(uri_unescape);\n\n";
print LOG "print \"1..__REPLACE_NUM_TESTS__\\n\";\n\n";
print LOG "my (\$req1, \$resp, \$html);\n";
print LOG "my \$cookie_jar = HTTP::Cookies->new;\n";
print LOG "my \$ua = RoboWeb::NetscapeLikeUA->new;\n\n\n";
close LOG;
}
sub _end_rec {
my $filename = shift;
$filename =~ s/\W//g;
$filename = $filename || 'HERE_I_AM';
$filename .= '.t';
open LOG, "$logfile" or die "could not open $logfile";
open OUTF, ">$filename" or die "could not open /tmp/$filename";
my $text;
{
local $/ = undef; # slurp mode
$text = <LOG>;
close LOG;
}
my $i = 1;
$i++ while $text =~ s/__REPLACE_ME__/$i/;
$i--;
$text =~ s/__REPLACE_NUM_TESTS__/$i/;
print OUTF $text;
close OUTF;
print "Created file: $filename\n";
}
sub _must_match {
my $path = shift;
open LOG, ">>$logfile" or die "could not open $logfile";
print LOG "print 'not ' unless \$html =~ $path;\n";
print LOG "print \"ok __REPLACE_ME__\\n\";\n\n\n";
close LOG;
}
sub _must_not_match {
my $path = shift;
open LOG, ">>$logfile" or die "could not open $logfile";
print LOG "print 'not ' unless \$html !~ $path;\n";
print LOG "print \"ok __REPLACE_ME__\\n\";\n\n\n";
close LOG;
}
my ($req, $resp, $html);
my $ua = LWP::UserAgent->new;
my $d = new HTTP::Daemon LocalPort => $listen_port;
print "I'll be your proxy today. Please contact me at: <URL:", $d->url
+, ">\n";
while (my $c = $d->accept) {
while (my $r = $c->get_request) {
my $serv = $r->uri->host;
my $path = $r->uri->path;
my $port = $r->uri->port;
print STDERR "Getting $serv - $path - $port\n";
if($serv =~ /start_rec$/i) {
_start_rec();
}
elsif($serv =~ /end_rec$/i) {
_end_rec($path);
}
elsif($serv =~ /must_match$/i) {
_must_match($path);
}
elsif($serv =~ /must_not_match$/i) {
_must_not_match($path);
}
elsif($serv =~ /pristine$/i) {
&pristine_please;
}
else {
# proxy code
# XXX change port of the request
$resp = $ua->request($r);
_gen_page_fetch($r);
$c->send_response($resp);
}
}
$c->close;
undef($c);
}
Regards,
Gregorovius |