| 1 | package Net::HTTP::Methods;
|
|---|
| 2 |
|
|---|
| 3 | require 5.005; # 4-arg substr
|
|---|
| 4 |
|
|---|
| 5 | use strict;
|
|---|
| 6 | use vars qw($VERSION);
|
|---|
| 7 |
|
|---|
| 8 | $VERSION = "5.834";
|
|---|
| 9 |
|
|---|
| 10 | my $CRLF = "\015\012"; # "\r\n" is not portable
|
|---|
| 11 |
|
|---|
| 12 | *_bytes = defined(&utf8::downgrade) ?
|
|---|
| 13 | sub {
|
|---|
| 14 | unless (utf8::downgrade($_[0], 1)) {
|
|---|
| 15 | require Carp;
|
|---|
| 16 | Carp::croak("Wide character in HTTP request (bytes required)");
|
|---|
| 17 | }
|
|---|
| 18 | return $_[0];
|
|---|
| 19 | }
|
|---|
| 20 | :
|
|---|
| 21 | sub {
|
|---|
| 22 | return $_[0];
|
|---|
| 23 | };
|
|---|
| 24 |
|
|---|
| 25 |
|
|---|
| 26 | sub new {
|
|---|
| 27 | my $class = shift;
|
|---|
| 28 | unshift(@_, "Host") if @_ == 1;
|
|---|
| 29 | my %cnf = @_;
|
|---|
| 30 | require Symbol;
|
|---|
| 31 | my $self = bless Symbol::gensym(), $class;
|
|---|
| 32 | return $self->http_configure(\%cnf);
|
|---|
| 33 | }
|
|---|
| 34 |
|
|---|
| 35 | sub http_configure {
|
|---|
| 36 | my($self, $cnf) = @_;
|
|---|
| 37 |
|
|---|
| 38 | die "Listen option not allowed" if $cnf->{Listen};
|
|---|
| 39 | my $explict_host = (exists $cnf->{Host});
|
|---|
| 40 | my $host = delete $cnf->{Host};
|
|---|
| 41 | my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
|
|---|
| 42 | if (!$peer) {
|
|---|
| 43 | die "No Host option provided" unless $host;
|
|---|
| 44 | $cnf->{PeerAddr} = $peer = $host;
|
|---|
| 45 | }
|
|---|
| 46 |
|
|---|
| 47 | if ($peer =~ s,:(\d+)$,,) {
|
|---|
| 48 | $cnf->{PeerPort} = int($1); # always override
|
|---|
| 49 | }
|
|---|
| 50 | if (!$cnf->{PeerPort}) {
|
|---|
| 51 | $cnf->{PeerPort} = $self->http_default_port;
|
|---|
| 52 | }
|
|---|
| 53 |
|
|---|
| 54 | if (!$explict_host) {
|
|---|
| 55 | $host = $peer;
|
|---|
| 56 | $host =~ s/:.*//;
|
|---|
| 57 | }
|
|---|
| 58 | if ($host && $host !~ /:/) {
|
|---|
| 59 | my $p = $cnf->{PeerPort};
|
|---|
| 60 | $host .= ":$p" if $p != $self->http_default_port;
|
|---|
| 61 | }
|
|---|
| 62 |
|
|---|
| 63 | $cnf->{Proto} = 'tcp';
|
|---|
| 64 |
|
|---|
| 65 | my $keep_alive = delete $cnf->{KeepAlive};
|
|---|
| 66 | my $http_version = delete $cnf->{HTTPVersion};
|
|---|
| 67 | $http_version = "1.1" unless defined $http_version;
|
|---|
| 68 | my $peer_http_version = delete $cnf->{PeerHTTPVersion};
|
|---|
| 69 | $peer_http_version = "1.0" unless defined $peer_http_version;
|
|---|
| 70 | my $send_te = delete $cnf->{SendTE};
|
|---|
| 71 | my $max_line_length = delete $cnf->{MaxLineLength};
|
|---|
| 72 | $max_line_length = 8*1024 unless defined $max_line_length;
|
|---|
| 73 | my $max_header_lines = delete $cnf->{MaxHeaderLines};
|
|---|
| 74 | $max_header_lines = 128 unless defined $max_header_lines;
|
|---|
| 75 |
|
|---|
| 76 | return undef unless $self->http_connect($cnf);
|
|---|
| 77 |
|
|---|
| 78 | $self->host($host);
|
|---|
| 79 | $self->keep_alive($keep_alive);
|
|---|
| 80 | $self->send_te($send_te);
|
|---|
| 81 | $self->http_version($http_version);
|
|---|
| 82 | $self->peer_http_version($peer_http_version);
|
|---|
| 83 | $self->max_line_length($max_line_length);
|
|---|
| 84 | $self->max_header_lines($max_header_lines);
|
|---|
| 85 |
|
|---|
| 86 | ${*$self}{'http_buf'} = "";
|
|---|
| 87 |
|
|---|
| 88 | return $self;
|
|---|
| 89 | }
|
|---|
| 90 |
|
|---|
| 91 | sub http_default_port {
|
|---|
| 92 | 80;
|
|---|
| 93 | }
|
|---|
| 94 |
|
|---|
| 95 | # set up property accessors
|
|---|
| 96 | for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
|
|---|
| 97 | my $prop_name = "http_" . $method;
|
|---|
| 98 | no strict 'refs';
|
|---|
| 99 | *$method = sub {
|
|---|
| 100 | my $self = shift;
|
|---|
| 101 | my $old = ${*$self}{$prop_name};
|
|---|
| 102 | ${*$self}{$prop_name} = shift if @_;
|
|---|
| 103 | return $old;
|
|---|
| 104 | };
|
|---|
| 105 | }
|
|---|
| 106 |
|
|---|
| 107 | # we want this one to be a bit smarter
|
|---|
| 108 | sub http_version {
|
|---|
| 109 | my $self = shift;
|
|---|
| 110 | my $old = ${*$self}{'http_version'};
|
|---|
| 111 | if (@_) {
|
|---|
| 112 | my $v = shift;
|
|---|
| 113 | $v = "1.0" if $v eq "1"; # float
|
|---|
| 114 | unless ($v eq "1.0" or $v eq "1.1") {
|
|---|
| 115 | require Carp;
|
|---|
| 116 | Carp::croak("Unsupported HTTP version '$v'");
|
|---|
| 117 | }
|
|---|
| 118 | ${*$self}{'http_version'} = $v;
|
|---|
| 119 | }
|
|---|
| 120 | $old;
|
|---|
| 121 | }
|
|---|
| 122 |
|
|---|
| 123 | sub format_request {
|
|---|
| 124 | my $self = shift;
|
|---|
| 125 | my $method = shift;
|
|---|
| 126 | my $uri = shift;
|
|---|
| 127 |
|
|---|
| 128 | my $content = (@_ % 2) ? pop : "";
|
|---|
| 129 |
|
|---|
| 130 | for ($method, $uri) {
|
|---|
| 131 | require Carp;
|
|---|
| 132 | Carp::croak("Bad method or uri") if /\s/ || !length;
|
|---|
| 133 | }
|
|---|
| 134 |
|
|---|
| 135 | push(@{${*$self}{'http_request_method'}}, $method);
|
|---|
| 136 | my $ver = ${*$self}{'http_version'};
|
|---|
| 137 | my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
|
|---|
| 138 |
|
|---|
| 139 | my @h;
|
|---|
| 140 | my @connection;
|
|---|
| 141 | my %given = (host => 0, "content-length" => 0, "te" => 0);
|
|---|
| 142 | while (@_) {
|
|---|
| 143 | my($k, $v) = splice(@_, 0, 2);
|
|---|
| 144 | my $lc_k = lc($k);
|
|---|
| 145 | if ($lc_k eq "connection") {
|
|---|
| 146 | $v =~ s/^\s+//;
|
|---|
| 147 | $v =~ s/\s+$//;
|
|---|
| 148 | push(@connection, split(/\s*,\s*/, $v));
|
|---|
| 149 | next;
|
|---|
| 150 | }
|
|---|
| 151 | if (exists $given{$lc_k}) {
|
|---|
| 152 | $given{$lc_k}++;
|
|---|
| 153 | }
|
|---|
| 154 | push(@h, "$k: $v");
|
|---|
| 155 | }
|
|---|
| 156 |
|
|---|
| 157 | if (length($content) && !$given{'content-length'}) {
|
|---|
| 158 | push(@h, "Content-Length: " . length($content));
|
|---|
| 159 | }
|
|---|
| 160 |
|
|---|
| 161 | my @h2;
|
|---|
| 162 | if ($given{te}) {
|
|---|
| 163 | push(@connection, "TE") unless grep lc($_) eq "te", @connection;
|
|---|
| 164 | }
|
|---|
| 165 | elsif ($self->send_te && gunzip_ok()) {
|
|---|
| 166 | # gzip is less wanted since the IO::Uncompress::Gunzip interface for
|
|---|
| 167 | # it does not really allow chunked decoding to take place easily.
|
|---|
| 168 | push(@h2, "TE: deflate,gzip;q=0.3");
|
|---|
| 169 | push(@connection, "TE");
|
|---|
| 170 | }
|
|---|
| 171 |
|
|---|
| 172 | unless (grep lc($_) eq "close", @connection) {
|
|---|
| 173 | if ($self->keep_alive) {
|
|---|
| 174 | if ($peer_ver eq "1.0") {
|
|---|
| 175 | # from looking at Netscape's headers
|
|---|
| 176 | push(@h2, "Keep-Alive: 300");
|
|---|
| 177 | unshift(@connection, "Keep-Alive");
|
|---|
| 178 | }
|
|---|
| 179 | }
|
|---|
| 180 | else {
|
|---|
| 181 | push(@connection, "close") if $ver ge "1.1";
|
|---|
| 182 | }
|
|---|
| 183 | }
|
|---|
| 184 | push(@h2, "Connection: " . join(", ", @connection)) if @connection;
|
|---|
| 185 | unless ($given{host}) {
|
|---|
| 186 | my $h = ${*$self}{'http_host'};
|
|---|
| 187 | push(@h2, "Host: $h") if $h;
|
|---|
| 188 | }
|
|---|
| 189 |
|
|---|
| 190 | return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content));
|
|---|
| 191 | }
|
|---|
| 192 |
|
|---|
| 193 |
|
|---|
| 194 | sub write_request {
|
|---|
| 195 | my $self = shift;
|
|---|
| 196 | $self->print($self->format_request(@_));
|
|---|
| 197 | }
|
|---|
| 198 |
|
|---|
| 199 | sub format_chunk {
|
|---|
| 200 | my $self = shift;
|
|---|
| 201 | return $_[0] unless defined($_[0]) && length($_[0]);
|
|---|
| 202 | return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
|
|---|
| 203 | }
|
|---|
| 204 |
|
|---|
| 205 | sub write_chunk {
|
|---|
| 206 | my $self = shift;
|
|---|
| 207 | return 1 unless defined($_[0]) && length($_[0]);
|
|---|
| 208 | $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF));
|
|---|
| 209 | }
|
|---|
| 210 |
|
|---|
| 211 | sub format_chunk_eof {
|
|---|
| 212 | my $self = shift;
|
|---|
| 213 | my @h;
|
|---|
| 214 | while (@_) {
|
|---|
| 215 | push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
|
|---|
| 216 | }
|
|---|
| 217 | return _bytes(join("", "0$CRLF", @h, $CRLF));
|
|---|
| 218 | }
|
|---|
| 219 |
|
|---|
| 220 | sub write_chunk_eof {
|
|---|
| 221 | my $self = shift;
|
|---|
| 222 | $self->print($self->format_chunk_eof(@_));
|
|---|
| 223 | }
|
|---|
| 224 |
|
|---|
| 225 |
|
|---|
| 226 | sub my_read {
|
|---|
| 227 | die if @_ > 3;
|
|---|
| 228 | my $self = shift;
|
|---|
| 229 | my $len = $_[1];
|
|---|
| 230 | for (${*$self}{'http_buf'}) {
|
|---|
| 231 | if (length) {
|
|---|
| 232 | $_[0] = substr($_, 0, $len, "");
|
|---|
| 233 | return length($_[0]);
|
|---|
| 234 | }
|
|---|
| 235 | else {
|
|---|
| 236 | return $self->sysread($_[0], $len);
|
|---|
| 237 | }
|
|---|
| 238 | }
|
|---|
| 239 | }
|
|---|
| 240 |
|
|---|
| 241 |
|
|---|
| 242 | sub my_readline {
|
|---|
| 243 | my $self = shift;
|
|---|
| 244 | my $what = shift;
|
|---|
| 245 | for (${*$self}{'http_buf'}) {
|
|---|
| 246 | my $max_line_length = ${*$self}{'http_max_line_length'};
|
|---|
| 247 | my $pos;
|
|---|
| 248 | while (1) {
|
|---|
| 249 | # find line ending
|
|---|
| 250 | $pos = index($_, "\012");
|
|---|
| 251 | last if $pos >= 0;
|
|---|
| 252 | die "$what line too long (limit is $max_line_length)"
|
|---|
| 253 | if $max_line_length && length($_) > $max_line_length;
|
|---|
| 254 |
|
|---|
| 255 | # need to read more data to find a line ending
|
|---|
| 256 | READ:
|
|---|
| 257 | {
|
|---|
| 258 | my $n = $self->sysread($_, 1024, length);
|
|---|
| 259 | unless (defined $n) {
|
|---|
| 260 | redo READ if $!{EINTR};
|
|---|
| 261 | if ($!{EAGAIN}) {
|
|---|
| 262 | # Hmm, we must be reading from a non-blocking socket
|
|---|
| 263 | # XXX Should really wait until this socket is readable,...
|
|---|
| 264 | select(undef, undef, undef, 0.1); # but this will do for now
|
|---|
| 265 | redo READ;
|
|---|
| 266 | }
|
|---|
| 267 | # if we have already accumulated some data let's at least
|
|---|
| 268 | # return that as a line
|
|---|
| 269 | die "$what read failed: $!" unless length;
|
|---|
| 270 | }
|
|---|
| 271 | unless ($n) {
|
|---|
| 272 | return undef unless length;
|
|---|
| 273 | return substr($_, 0, length, "");
|
|---|
| 274 | }
|
|---|
| 275 | }
|
|---|
| 276 | }
|
|---|
| 277 | die "$what line too long ($pos; limit is $max_line_length)"
|
|---|
| 278 | if $max_line_length && $pos > $max_line_length;
|
|---|
| 279 |
|
|---|
| 280 | my $line = substr($_, 0, $pos+1, "");
|
|---|
| 281 | $line =~ s/(\015?\012)\z// || die "Assert";
|
|---|
| 282 | return wantarray ? ($line, $1) : $line;
|
|---|
| 283 | }
|
|---|
| 284 | }
|
|---|
| 285 |
|
|---|
| 286 |
|
|---|
| 287 | sub _rbuf {
|
|---|
| 288 | my $self = shift;
|
|---|
| 289 | if (@_) {
|
|---|
| 290 | for (${*$self}{'http_buf'}) {
|
|---|
| 291 | my $old;
|
|---|
| 292 | $old = $_ if defined wantarray;
|
|---|
| 293 | $_ = shift;
|
|---|
| 294 | return $old;
|
|---|
| 295 | }
|
|---|
| 296 | }
|
|---|
| 297 | else {
|
|---|
| 298 | return ${*$self}{'http_buf'};
|
|---|
| 299 | }
|
|---|
| 300 | }
|
|---|
| 301 |
|
|---|
| 302 | sub _rbuf_length {
|
|---|
| 303 | my $self = shift;
|
|---|
| 304 | return length ${*$self}{'http_buf'};
|
|---|
| 305 | }
|
|---|
| 306 |
|
|---|
| 307 |
|
|---|
| 308 | sub _read_header_lines {
|
|---|
| 309 | my $self = shift;
|
|---|
| 310 | my $junk_out = shift;
|
|---|
| 311 |
|
|---|
| 312 | my @headers;
|
|---|
| 313 | my $line_count = 0;
|
|---|
| 314 | my $max_header_lines = ${*$self}{'http_max_header_lines'};
|
|---|
| 315 | while (my $line = my_readline($self, 'Header')) {
|
|---|
| 316 | if ($line =~ /^(\S+?)\s*:\s*(.*)/s) {
|
|---|
| 317 | push(@headers, $1, $2);
|
|---|
| 318 | }
|
|---|
| 319 | elsif (@headers && $line =~ s/^\s+//) {
|
|---|
| 320 | $headers[-1] .= " " . $line;
|
|---|
| 321 | }
|
|---|
| 322 | elsif ($junk_out) {
|
|---|
| 323 | push(@$junk_out, $line);
|
|---|
| 324 | }
|
|---|
| 325 | else {
|
|---|
| 326 | die "Bad header: '$line'\n";
|
|---|
| 327 | }
|
|---|
| 328 | if ($max_header_lines) {
|
|---|
| 329 | $line_count++;
|
|---|
| 330 | if ($line_count >= $max_header_lines) {
|
|---|
| 331 | die "Too many header lines (limit is $max_header_lines)";
|
|---|
| 332 | }
|
|---|
| 333 | }
|
|---|
| 334 | }
|
|---|
| 335 | return @headers;
|
|---|
| 336 | }
|
|---|
| 337 |
|
|---|
| 338 |
|
|---|
| 339 | sub read_response_headers {
|
|---|
| 340 | my($self, %opt) = @_;
|
|---|
| 341 | my $laxed = $opt{laxed};
|
|---|
| 342 |
|
|---|
| 343 | my($status, $eol) = my_readline($self, 'Status');
|
|---|
| 344 | unless (defined $status) {
|
|---|
| 345 | die "Server closed connection without sending any data back";
|
|---|
| 346 | }
|
|---|
| 347 |
|
|---|
| 348 | my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
|
|---|
| 349 | if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
|
|---|
| 350 | die "Bad response status line: '$status'" unless $laxed;
|
|---|
| 351 | # assume HTTP/0.9
|
|---|
| 352 | ${*$self}{'http_peer_http_version'} = "0.9";
|
|---|
| 353 | ${*$self}{'http_status'} = "200";
|
|---|
| 354 | substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || "");
|
|---|
| 355 | return 200 unless wantarray;
|
|---|
| 356 | return (200, "Assumed OK");
|
|---|
| 357 | };
|
|---|
| 358 |
|
|---|
| 359 | ${*$self}{'http_peer_http_version'} = $peer_ver;
|
|---|
| 360 | ${*$self}{'http_status'} = $code;
|
|---|
| 361 |
|
|---|
| 362 | my $junk_out;
|
|---|
| 363 | if ($laxed) {
|
|---|
| 364 | $junk_out = $opt{junk_out} || [];
|
|---|
| 365 | }
|
|---|
| 366 | my @headers = $self->_read_header_lines($junk_out);
|
|---|
| 367 |
|
|---|
| 368 | # pick out headers that read_entity_body might need
|
|---|
| 369 | my @te;
|
|---|
| 370 | my $content_length;
|
|---|
| 371 | for (my $i = 0; $i < @headers; $i += 2) {
|
|---|
| 372 | my $h = lc($headers[$i]);
|
|---|
| 373 | if ($h eq 'transfer-encoding') {
|
|---|
| 374 | my $te = $headers[$i+1];
|
|---|
| 375 | $te =~ s/^\s+//;
|
|---|
| 376 | $te =~ s/\s+$//;
|
|---|
| 377 | push(@te, $te) if length($te);
|
|---|
| 378 | }
|
|---|
| 379 | elsif ($h eq 'content-length') {
|
|---|
| 380 | # ignore bogus and overflow values
|
|---|
| 381 | if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) {
|
|---|
| 382 | $content_length = $1;
|
|---|
| 383 | }
|
|---|
| 384 | }
|
|---|
| 385 | }
|
|---|
| 386 | ${*$self}{'http_te'} = join(",", @te);
|
|---|
| 387 | ${*$self}{'http_content_length'} = $content_length;
|
|---|
| 388 | ${*$self}{'http_first_body'}++;
|
|---|
| 389 | delete ${*$self}{'http_trailers'};
|
|---|
| 390 | return $code unless wantarray;
|
|---|
| 391 | return ($code, $message, @headers);
|
|---|
| 392 | }
|
|---|
| 393 |
|
|---|
| 394 |
|
|---|
| 395 | sub read_entity_body {
|
|---|
| 396 | my $self = shift;
|
|---|
| 397 | my $buf_ref = \$_[0];
|
|---|
| 398 | my $size = $_[1];
|
|---|
| 399 | die "Offset not supported yet" if $_[2];
|
|---|
| 400 |
|
|---|
| 401 | my $chunked;
|
|---|
| 402 | my $bytes;
|
|---|
| 403 |
|
|---|
| 404 | if (${*$self}{'http_first_body'}) {
|
|---|
| 405 | ${*$self}{'http_first_body'} = 0;
|
|---|
| 406 | delete ${*$self}{'http_chunked'};
|
|---|
| 407 | delete ${*$self}{'http_bytes'};
|
|---|
| 408 | my $method = shift(@{${*$self}{'http_request_method'}});
|
|---|
| 409 | my $status = ${*$self}{'http_status'};
|
|---|
| 410 | if ($method eq "HEAD") {
|
|---|
| 411 | # this response is always empty regardless of other headers
|
|---|
| 412 | $bytes = 0;
|
|---|
| 413 | }
|
|---|
| 414 | elsif (my $te = ${*$self}{'http_te'}) {
|
|---|
| 415 | my @te = split(/\s*,\s*/, lc($te));
|
|---|
| 416 | die "Chunked must be last Transfer-Encoding '$te'"
|
|---|
| 417 | unless pop(@te) eq "chunked";
|
|---|
| 418 |
|
|---|
| 419 | for (@te) {
|
|---|
| 420 | if ($_ eq "deflate" && inflate_ok()) {
|
|---|
| 421 | #require Compress::Raw::Zlib;
|
|---|
| 422 | my ($i, $status) = Compress::Raw::Zlib::Inflate->new();
|
|---|
| 423 | die "Can't make inflator: $status" unless $i;
|
|---|
| 424 | $_ = sub { my $out; $i->inflate($_[0], \$out); $out }
|
|---|
| 425 | }
|
|---|
| 426 | elsif ($_ eq "gzip" && gunzip_ok()) {
|
|---|
| 427 | #require IO::Uncompress::Gunzip;
|
|---|
| 428 | my @buf;
|
|---|
| 429 | $_ = sub {
|
|---|
| 430 | push(@buf, $_[0]);
|
|---|
| 431 | return "" unless $_[1];
|
|---|
| 432 | my $input = join("", @buf);
|
|---|
| 433 | my $output;
|
|---|
| 434 | IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0)
|
|---|
| 435 | or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
|
|---|
| 436 | return \$output;
|
|---|
| 437 | };
|
|---|
| 438 | }
|
|---|
| 439 | elsif ($_ eq "identity") {
|
|---|
| 440 | $_ = sub { $_[0] };
|
|---|
| 441 | }
|
|---|
| 442 | else {
|
|---|
| 443 | die "Can't handle transfer encoding '$te'";
|
|---|
| 444 | }
|
|---|
| 445 | }
|
|---|
| 446 |
|
|---|
| 447 | @te = reverse(@te);
|
|---|
| 448 |
|
|---|
| 449 | ${*$self}{'http_te2'} = @te ? \@te : "";
|
|---|
| 450 | $chunked = -1;
|
|---|
| 451 | }
|
|---|
| 452 | elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
|
|---|
| 453 | $bytes = $content_length;
|
|---|
| 454 | }
|
|---|
| 455 | elsif ($status =~ /^(?:1|[23]04)/) {
|
|---|
| 456 | # RFC 2616 says that these responses should always be empty
|
|---|
| 457 | # but that does not appear to be true in practice [RT#17907]
|
|---|
| 458 | $bytes = 0;
|
|---|
| 459 | }
|
|---|
| 460 | else {
|
|---|
| 461 | # XXX Multi-Part types are self delimiting, but RFC 2616 says we
|
|---|
| 462 | # only has to deal with 'multipart/byteranges'
|
|---|
| 463 |
|
|---|
| 464 | # Read until EOF
|
|---|
| 465 | }
|
|---|
| 466 | }
|
|---|
| 467 | else {
|
|---|
| 468 | $chunked = ${*$self}{'http_chunked'};
|
|---|
| 469 | $bytes = ${*$self}{'http_bytes'};
|
|---|
| 470 | }
|
|---|
| 471 |
|
|---|
| 472 | if (defined $chunked) {
|
|---|
| 473 | # The state encoded in $chunked is:
|
|---|
| 474 | # $chunked == 0: read CRLF after chunk, then chunk header
|
|---|
| 475 | # $chunked == -1: read chunk header
|
|---|
| 476 | # $chunked > 0: bytes left in current chunk to read
|
|---|
| 477 |
|
|---|
| 478 | if ($chunked <= 0) {
|
|---|
| 479 | my $line = my_readline($self, 'Entity body');
|
|---|
| 480 | if ($chunked == 0) {
|
|---|
| 481 | die "Missing newline after chunk data: '$line'"
|
|---|
| 482 | if !defined($line) || $line ne "";
|
|---|
| 483 | $line = my_readline($self, 'Entity body');
|
|---|
| 484 | }
|
|---|
| 485 | die "EOF when chunk header expected" unless defined($line);
|
|---|
| 486 | my $chunk_len = $line;
|
|---|
| 487 | $chunk_len =~ s/;.*//; # ignore potential chunk parameters
|
|---|
| 488 | unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
|
|---|
| 489 | die "Bad chunk-size in HTTP response: $line";
|
|---|
| 490 | }
|
|---|
| 491 | $chunked = hex($1);
|
|---|
| 492 | if ($chunked == 0) {
|
|---|
| 493 | ${*$self}{'http_trailers'} = [$self->_read_header_lines];
|
|---|
| 494 | $$buf_ref = "";
|
|---|
| 495 |
|
|---|
| 496 | my $n = 0;
|
|---|
| 497 | if (my $transforms = delete ${*$self}{'http_te2'}) {
|
|---|
| 498 | for (@$transforms) {
|
|---|
| 499 | $$buf_ref = &$_($$buf_ref, 1);
|
|---|
| 500 | }
|
|---|
| 501 | $n = length($$buf_ref);
|
|---|
| 502 | }
|
|---|
| 503 |
|
|---|
| 504 | # in case somebody tries to read more, make sure we continue
|
|---|
| 505 | # to return EOF
|
|---|
| 506 | delete ${*$self}{'http_chunked'};
|
|---|
| 507 | ${*$self}{'http_bytes'} = 0;
|
|---|
| 508 |
|
|---|
| 509 | return $n;
|
|---|
| 510 | }
|
|---|
| 511 | }
|
|---|
| 512 |
|
|---|
| 513 | my $n = $chunked;
|
|---|
| 514 | $n = $size if $size && $size < $n;
|
|---|
| 515 | $n = my_read($self, $$buf_ref, $n);
|
|---|
| 516 | return undef unless defined $n;
|
|---|
| 517 |
|
|---|
| 518 | ${*$self}{'http_chunked'} = $chunked - $n;
|
|---|
| 519 |
|
|---|
| 520 | if ($n > 0) {
|
|---|
| 521 | if (my $transforms = ${*$self}{'http_te2'}) {
|
|---|
| 522 | for (@$transforms) {
|
|---|
| 523 | $$buf_ref = &$_($$buf_ref, 0);
|
|---|
| 524 | }
|
|---|
| 525 | $n = length($$buf_ref);
|
|---|
| 526 | $n = -1 if $n == 0;
|
|---|
| 527 | }
|
|---|
| 528 | }
|
|---|
| 529 | return $n;
|
|---|
| 530 | }
|
|---|
| 531 | elsif (defined $bytes) {
|
|---|
| 532 | unless ($bytes) {
|
|---|
| 533 | $$buf_ref = "";
|
|---|
| 534 | return 0;
|
|---|
| 535 | }
|
|---|
| 536 | my $n = $bytes;
|
|---|
| 537 | $n = $size if $size && $size < $n;
|
|---|
| 538 | $n = my_read($self, $$buf_ref, $n);
|
|---|
| 539 | return undef unless defined $n;
|
|---|
| 540 | ${*$self}{'http_bytes'} = $bytes - $n;
|
|---|
| 541 | return $n;
|
|---|
| 542 | }
|
|---|
| 543 | else {
|
|---|
| 544 | # read until eof
|
|---|
| 545 | $size ||= 8*1024;
|
|---|
| 546 | return my_read($self, $$buf_ref, $size);
|
|---|
| 547 | }
|
|---|
| 548 | }
|
|---|
| 549 |
|
|---|
| 550 | sub get_trailers {
|
|---|
| 551 | my $self = shift;
|
|---|
| 552 | @{${*$self}{'http_trailers'} || []};
|
|---|
| 553 | }
|
|---|
| 554 |
|
|---|
| 555 | BEGIN {
|
|---|
| 556 | my $gunzip_ok;
|
|---|
| 557 | my $inflate_ok;
|
|---|
| 558 |
|
|---|
| 559 | sub gunzip_ok {
|
|---|
| 560 | return $gunzip_ok if defined $gunzip_ok;
|
|---|
| 561 |
|
|---|
| 562 | # Try to load IO::Uncompress::Gunzip.
|
|---|
| 563 | local $@;
|
|---|
| 564 | local $SIG{__DIE__};
|
|---|
| 565 | $gunzip_ok = 0;
|
|---|
| 566 |
|
|---|
| 567 | eval {
|
|---|
| 568 | require IO::Uncompress::Gunzip;
|
|---|
| 569 | $gunzip_ok++;
|
|---|
| 570 | };
|
|---|
| 571 |
|
|---|
| 572 | return $gunzip_ok;
|
|---|
| 573 | }
|
|---|
| 574 |
|
|---|
| 575 | sub inflate_ok {
|
|---|
| 576 | return $inflate_ok if defined $inflate_ok;
|
|---|
| 577 |
|
|---|
| 578 | # Try to load Compress::Raw::Zlib.
|
|---|
| 579 | local $@;
|
|---|
| 580 | local $SIG{__DIE__};
|
|---|
| 581 | $inflate_ok = 0;
|
|---|
| 582 |
|
|---|
| 583 | eval {
|
|---|
| 584 | require Compress::Raw::Zlib;
|
|---|
| 585 | $inflate_ok++;
|
|---|
| 586 | };
|
|---|
| 587 |
|
|---|
| 588 | return $inflate_ok;
|
|---|
| 589 | }
|
|---|
| 590 |
|
|---|
| 591 | } # BEGIN
|
|---|
| 592 |
|
|---|
| 593 | 1;
|
|---|
