/lib/Perlbal/Test/WebClient.pm

http://github.com/perlbal/Perlbal · Perl · 200 lines · 155 code · 33 blank · 12 comment · 35 complexity · 44fa7cf32c940f502a806f76000b84f0 MD5 · raw file

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