/lib/Perlbal/Test/WebClient.pm

  1#!/usr/bin/perl
  2
  3package Perlbal::Test::WebClient;
  4
  5use strict;
  6use IO::Socket::INET;
  7use Perlbal::Test;
  8use HTTP::Response;
  9use Socket qw(MSG_NOSIGNAL IPPROTO_TCP TCP_NODELAY SOL_SOCKET);
 10
 11require Exporter;
 12use vars qw(@ISA @EXPORT $FLAG_NOSIGNAL);
 13@ISA = qw(Exporter);
 14@EXPORT = qw(new);
 15
 16$FLAG_NOSIGNAL = 0;
 17eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; };
 18
 19# create a blank object
 20sub new {
 21    my $class = shift;
 22    my $self = {};
 23    bless $self, $class;
 24    return $self;
 25}
 26
 27# get/set what server we should be testing; "ip:port" generally
 28sub server {
 29    my $self = shift;
 30    if (@_) {
 31    	$self->{_sock} = undef;
 32        return $self->{server} = shift;
 33    } else {
 34        return $self->{server};
 35    }
 36}
 37
 38# get/set what hostname we send with requests
 39sub host {
 40    my $self = shift;
 41    if (@_) {
 42        $self->{_sock} = undef;
 43        return $self->{host} = shift;
 44    } else {
 45        return $self->{host};
 46    }
 47}
 48
 49# set which HTTP version to emulate; specify '1.0' or '1.1'
 50sub http_version {
 51    my $self = shift;
 52    if (@_) {
 53        return $self->{http_version} = shift;
 54    } else {
 55        return $self->{http_version};
 56    }
 57}
 58
 59# set on or off to enable or disable persistent connection
 60sub keepalive {
 61    my $self = shift;
 62    if (@_) {
 63        $self->{keepalive} = shift() ? 1 : 0;
 64    }
 65    return $self->{keepalive};
 66}
 67
 68# construct and send a request
 69sub request {
 70    my $self = shift;
 71    return undef unless $self->{server};
 72
 73    my $opts = ref $_[0] eq "HASH" ? shift : {};
 74    my $opt_headers           = delete $opts->{'headers'};
 75    my $opt_host              = delete $opts->{'host'};
 76    my $opt_method            = delete $opts->{'method'};
 77    my $opt_content           = delete $opts->{'content'};
 78    my $opt_extra_rn          = delete $opts->{'extra_rn'};
 79    my $opt_return_reader     = delete $opts->{'return_reader'};
 80    my $opt_post_header_pause = delete $opts->{'post_header_pause'};
 81    die "Bogus options: " . join(", ", keys %$opts) if %$opts;
 82
 83    my $cmds = join(',', map { eurl($_) } @_);
 84    return undef unless $cmds;
 85
 86    # keep-alive header if 1.0, also means add content-length header
 87    my $headers = '';
 88    if ($self->{keepalive}) {
 89        $headers .= "Connection: keep-alive\r\n";
 90    } else {
 91        $headers .= "Connection: close\r\n";
 92    }
 93
 94    if ($opt_headers) {
 95        $headers .= $opt_headers;
 96    }
 97
 98    if (my $hostname = $opt_host || $self->{host}) {
 99        $headers .= "Host: $hostname\r\n";
100    }
101    my $method = $opt_method || "GET";
102    my $body = "";
103
104    if ($opt_content) {
105        $headers .= "Content-Length: " . length($opt_content) . "\r\n";
106        $body = $opt_content;
107    }
108
109    if ($opt_extra_rn) {
110        $body .= "\r\n";  # some browsers on POST send an extra \r\n that's not part of content-length
111    }
112
113    my $send = "$method /$cmds HTTP/$self->{http_version}\r\n$headers\r\n";
114
115    unless ($opt_post_header_pause) {
116        $send .= $body;
117    }
118
119    my $len = length $send;
120
121    # send setup
122    my $rv;
123    my $sock = delete $self->{_sock};
124    local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
125
126    ### send it cached
127    if ($sock) {
128        $rv = send($sock, $send, $FLAG_NOSIGNAL);
129        if ($! || ! defined $rv) {
130            undef $self->{_sock};
131        } elsif ($rv != $len) {
132            return undef;
133        }
134    }
135
136    # failing that, send it through a new socket
137    unless ($rv) {
138        $self->{_reqdone} = 0;
139
140        $sock = IO::Socket::INET->new(
141                PeerAddr => $self->{server},
142                Timeout => 3,
143            ) or return undef;
144        setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, pack("l", 1)) or die "failed to set sockopt: $!\n";
145
146        $rv = send($sock, $send, $FLAG_NOSIGNAL);
147        if ($! || $rv != $len) {
148            return undef;
149        }
150    }
151
152    if ($opt_post_header_pause) {
153        select undef, undef, undef, $opt_post_header_pause;
154        my $len = length $body;
155        if ($len) {
156            my $rv = send($sock, $body, $FLAG_NOSIGNAL);
157            if ($! || ! defined $rv) {
158                undef $self->{_sock};
159            } elsif ($rv != $len) {
160                return undef;
161            }
162        }
163    }
164
165    my $parse_it = sub {
166        my ($resp, $firstline) = resp_from_sock($sock);
167
168        my $conhdr = $resp->header("Connection") || "";
169        if (($firstline =~ m!\bHTTP/1\.1\b! && $conhdr !~ m!\bclose\b!i) ||
170            ($firstline =~ m!\bHTTP/1\.0\b! && $conhdr =~ m!\bkeep-alive\b!i)) {
171            $self->{_sock} = $sock;
172            $self->{_reqdone}++;
173        } else {
174            $self->{_reqdone} = 0;
175        }
176
177        return $resp;
178    };
179
180    if ($opt_return_reader) {
181        return $parse_it;
182    } else {
183        return $parse_it->();
184    }
185}
186
187sub reqdone {
188    my $self = shift;
189    return $self->{_reqdone};
190}
191
192# general purpose URL escaping function
193sub eurl {
194    my $a = $_[0];
195    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
196    $a =~ tr/ /+/;
197    return $a;
198}
199
2001;