1 package Net::HTTP::Methods;
3 require 5.005; # 4-arg substr
10 my $CRLF = "\015\012"; # "\r\n" is not portable
14 unshift(@_, "Host") if @_ == 1;
17 my $self = bless Symbol::gensym(), $class;
18 return $self->http_configure(\%cnf);
24 die "Listen option not allowed" if $cnf->{Listen};
25 my $explict_host = (exists $cnf->{Host});
26 my $host = delete $cnf->{Host};
27 my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
29 die "No Host option provided" unless $host;
30 $cnf->{PeerAddr} = $peer = $host;
33 if ($peer =~ s,:(\d+)$,,) {
34 $cnf->{PeerPort} = int($1); # always override
36 if (!$cnf->{PeerPort}) {
37 $cnf->{PeerPort} = $self->http_default_port;
44 if ($host && $host !~ /:/) {
45 my $p = $cnf->{PeerPort};
46 $host .= ":$p" if $p != $self->http_default_port;
49 $cnf->{Proto} = 'tcp';
51 my $keep_alive = delete $cnf->{KeepAlive};
52 my $http_version = delete $cnf->{HTTPVersion};
53 $http_version = "1.1" unless defined $http_version;
54 my $peer_http_version = delete $cnf->{PeerHTTPVersion};
55 $peer_http_version = "1.0" unless defined $peer_http_version;
56 my $send_te = delete $cnf->{SendTE};
57 my $max_line_length = delete $cnf->{MaxLineLength};
58 $max_line_length = 4*1024 unless defined $max_line_length;
59 my $max_header_lines = delete $cnf->{MaxHeaderLines};
60 $max_header_lines = 128 unless defined $max_header_lines;
62 return undef unless $self->http_connect($cnf);
65 $self->keep_alive($keep_alive);
66 $self->send_te($send_te);
67 $self->http_version($http_version);
68 $self->peer_http_version($peer_http_version);
69 $self->max_line_length($max_line_length);
70 $self->max_header_lines($max_header_lines);
72 ${*$self}{'http_buf'} = "";
77 sub http_default_port {
81 # set up property accessors
82 for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
83 my $prop_name = "http_" . $method;
87 my $old = ${*$self}{$prop_name};
88 ${*$self}{$prop_name} = shift if @_;
93 # we want this one to be a bit smarter
96 my $old = ${*$self}{'http_version'};
99 $v = "1.0" if $v eq "1"; # float
100 unless ($v eq "1.0" or $v eq "1.1") {
102 Carp::croak("Unsupported HTTP version '$v'");
104 ${*$self}{'http_version'} = $v;
114 my $content = (@_ % 2) ? pop : "";
116 for ($method, $uri) {
118 Carp::croak("Bad method or uri") if /\s/ || !length;
121 push(@{${*$self}{'http_request_method'}}, $method);
122 my $ver = ${*$self}{'http_version'};
123 my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
127 my %given = (host => 0, "content-length" => 0, "te" => 0);
129 my($k, $v) = splice(@_, 0, 2);
131 if ($lc_k eq "connection") {
134 push(@connection, split(/\s*,\s*/, $v));
137 if (exists $given{$lc_k}) {
143 if (length($content) && !$given{'content-length'}) {
144 push(@h, "Content-Length: " . length($content));
149 push(@connection, "TE") unless grep lc($_) eq "te", @connection;
151 elsif ($self->send_te && zlib_ok()) {
152 # gzip is less wanted since the Compress::Zlib interface for
153 # it does not really allow chunked decoding to take place easily.
154 push(@h2, "TE: deflate,gzip;q=0.3");
155 push(@connection, "TE");
158 unless (grep lc($_) eq "close", @connection) {
159 if ($self->keep_alive) {
160 if ($peer_ver eq "1.0") {
161 # from looking at Netscape's headers
162 push(@h2, "Keep-Alive: 300");
163 unshift(@connection, "Keep-Alive");
167 push(@connection, "close") if $ver ge "1.1";
170 push(@h2, "Connection: " . join(", ", @connection)) if @connection;
171 unless ($given{host}) {
172 my $h = ${*$self}{'http_host'};
173 push(@h2, "Host: $h") if $h;
176 return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
182 $self->print($self->format_request(@_));
187 return $_[0] unless defined($_[0]) && length($_[0]);
188 return sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF;
193 return 1 unless defined($_[0]) && length($_[0]);
194 $self->print(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
197 sub format_chunk_eof {
201 push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
203 return join("", "0$CRLF", @h, $CRLF);
206 sub write_chunk_eof {
208 $self->print($self->format_chunk_eof(@_));
216 for (${*$self}{'http_buf'}) {
218 $_[0] = substr($_, 0, $len, "");
219 return length($_[0]);
222 return $self->sysread($_[0], $len);
230 for (${*$self}{'http_buf'}) {
231 my $max_line_length = ${*$self}{'http_max_line_length'};
235 $pos = index($_, "\012");
237 die "Line too long (limit is $max_line_length)"
238 if $max_line_length && length($_) > $max_line_length;
240 # need to read more data to find a line ending
243 my $n = $self->sysread($_, 1024, length);
244 unless (defined $n) {
245 redo READ if $!{EINTR};
247 # Hmm, we must be reading from a non-blocking socket
248 # XXX Should really wait until this socket is readable,...
249 select(undef, undef, undef, 0.1); # but this will do for now
252 # if we have already accumulated some data let's at least
253 # return that as a line
254 die "read failed: $!" unless length;
257 return undef unless length;
258 return substr($_, 0, length, "");
262 die "Line too long ($pos; limit is $max_line_length)"
263 if $max_line_length && $pos > $max_line_length;
265 my $line = substr($_, 0, $pos+1, "");
266 $line =~ s/(\015?\012)\z// || die "Assert";
267 return wantarray ? ($line, $1) : $line;
275 for (${*$self}{'http_buf'}) {
277 $old = $_ if defined wantarray;
283 return ${*$self}{'http_buf'};
289 return length ${*$self}{'http_buf'};
293 sub _read_header_lines {
295 my $junk_out = shift;
299 my $max_header_lines = ${*$self}{'http_max_header_lines'};
300 while (my $line = my_readline($self)) {
301 if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
302 push(@headers, $1, $2);
304 elsif (@headers && $line =~ s/^\s+//) {
305 $headers[-1] .= " " . $line;
308 push(@$junk_out, $line);
311 die "Bad header: '$line'\n";
313 if ($max_header_lines) {
315 if ($line_count >= $max_header_lines) {
316 die "Too many header lines (limit is $max_header_lines)";
324 sub read_response_headers {
325 my($self, %opt) = @_;
326 my $laxed = $opt{laxed};
328 my($status, $eol) = my_readline($self);
329 unless (defined $status) {
330 die "Server closed connection without sending any data back";
333 my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
334 if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
335 die "Bad response status line: '$status'" unless $laxed;
337 ${*$self}{'http_peer_http_version'} = "0.9";
338 ${*$self}{'http_status'} = "200";
339 substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
340 return 200 unless wantarray;
341 return (200, "Assumed OK");
344 ${*$self}{'http_peer_http_version'} = $peer_ver;
345 ${*$self}{'http_status'} = $code;
349 $junk_out = $opt{junk_out} || [];
351 my @headers = $self->_read_header_lines($junk_out);
353 # pick out headers that read_entity_body might need
356 for (my $i = 0; $i < @headers; $i += 2) {
357 my $h = lc($headers[$i]);
358 if ($h eq 'transfer-encoding') {
359 my $te = $headers[$i+1];
362 push(@te, $te) if length($te);
364 elsif ($h eq 'content-length') {
365 # ignore bogus and overflow values
366 if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
367 $content_length = $1;
371 ${*$self}{'http_te'} = join(",", @te);
372 ${*$self}{'http_content_length'} = $content_length;
373 ${*$self}{'http_first_body'}++;
374 delete ${*$self}{'http_trailers'};
375 return $code unless wantarray;
376 return ($code, $message, @headers);
380 sub read_entity_body {
382 my $buf_ref = \$_[0];
384 die "Offset not supported yet" if $_[2];
389 if (${*$self}{'http_first_body'}) {
390 ${*$self}{'http_first_body'} = 0;
391 delete ${*$self}{'http_chunked'};
392 delete ${*$self}{'http_bytes'};
393 my $method = shift(@{${*$self}{'http_request_method'}});
394 my $status = ${*$self}{'http_status'};
395 if ($method eq "HEAD") {
396 # this response is always empty regardless of other headers
399 elsif (my $te = ${*$self}{'http_te'}) {
400 my @te = split(/\s*,\s*/, lc($te));
401 die "Chunked must be last Transfer-Encoding '$te'"
402 unless pop(@te) eq "chunked";
405 if ($_ eq "deflate" && zlib_ok()) {
406 #require Compress::Zlib;
407 my $i = Compress::Zlib::inflateInit();
408 die "Can't make inflator" unless $i;
409 $_ = sub { scalar($i->inflate($_[0])) }
411 elsif ($_ eq "gzip" && zlib_ok()) {
412 #require Compress::Zlib;
416 return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
420 elsif ($_ eq "identity") {
424 die "Can't handle transfer encoding '$te'";
430 ${*$self}{'http_te2'} = @te ? \@te : "";
433 elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
434 $bytes = $content_length;
436 elsif ($status =~ /^(?:1|[23]04)/) {
437 # RFC 2616 says that these responses should always be empty
438 # but that does not appear to be true in practice [RT#17907]
442 # XXX Multi-Part types are self delimiting, but RFC 2616 says we
443 # only has to deal with 'multipart/byteranges'
449 $chunked = ${*$self}{'http_chunked'};
450 $bytes = ${*$self}{'http_bytes'};
453 if (defined $chunked) {
454 # The state encoded in $chunked is:
455 # $chunked == 0: read CRLF after chunk, then chunk header
456 # $chunked == -1: read chunk header
457 # $chunked > 0: bytes left in current chunk to read
460 my $line = my_readline($self);
462 die "Missing newline after chunk data: '$line'"
463 if !defined($line) || $line ne "";
464 $line = my_readline($self);
466 die "EOF when chunk header expected" unless defined($line);
467 my $chunk_len = $line;
468 $chunk_len =~ s/;.*//; # ignore potential chunk parameters
469 unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
470 die "Bad chunk-size in HTTP response: $line";
474 ${*$self}{'http_trailers'} = [$self->_read_header_lines];
478 if (my $transforms = delete ${*$self}{'http_te2'}) {
480 $$buf_ref = &$_($$buf_ref, 1);
482 $n = length($$buf_ref);
485 # in case somebody tries to read more, make sure we continue
487 delete ${*$self}{'http_chunked'};
488 ${*$self}{'http_bytes'} = 0;
495 $n = $size if $size && $size < $n;
496 $n = my_read($self, $$buf_ref, $n);
497 return undef unless defined $n;
499 ${*$self}{'http_chunked'} = $chunked - $n;
502 if (my $transforms = ${*$self}{'http_te2'}) {
504 $$buf_ref = &$_($$buf_ref, 0);
506 $n = length($$buf_ref);
512 elsif (defined $bytes) {
518 $n = $size if $size && $size < $n;
519 $n = my_read($self, $$buf_ref, $n);
520 return undef unless defined $n;
521 ${*$self}{'http_bytes'} = $bytes - $n;
527 return my_read($self, $$buf_ref, $size);
533 @{${*$self}{'http_trailers'} || []};
540 return $zlib_ok if defined $zlib_ok;
542 # Try to load Compress::Zlib.
548 require Compress::Zlib;
549 Compress::Zlib->VERSION(1.10);