vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/Net/HTTP/Methods.pm

   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.812";
   9
  10 my $CRLF = "\015\012";   # "\r\n" is not portable
  11
  12 sub new {
  13     my $class = shift;
  14     unshift(@_, "Host") if @_ == 1;
  15     my %cnf = @_;
  16     require Symbol;
  17     my $self = bless Symbol::gensym(), $class;
  18     return $self->http_configure(\%cnf);
  19 }
  20
  21 sub http_configure {
  22     my($self, $cnf) = @_;
  23
  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};
  28     if (!$peer) {
  29         die "No Host option provided" unless $host;
  30         $cnf->{PeerAddr} = $peer = $host;
  31     }
  32
  33     if ($peer =~ s,:(\d+)$,,) {
  34         $cnf->{PeerPort} = int($1);  # always override
  35     }
  36     if (!$cnf->{PeerPort}) {
  37         $cnf->{PeerPort} = $self->http_default_port;
  38     }
  39
  40     if (!$explict_host) {
  41         $host = $peer;
  42         $host =~ s/:.*//;
  43     }
  44     if ($host && $host !~ /:/) {
  45         my $p = $cnf->{PeerPort};
  46         $host .= ":$p" if $p != $self->http_default_port;
  47     }
  48
  49     $cnf->{Proto} = 'tcp';
  50
  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;
  61
  62     return undef unless $self->http_connect($cnf);
  63
  64     $self->host($host);
  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);
  71
  72     ${*$self}{'http_buf'} = "";
  73
  74     return $self;
  75 }
  76
  77 sub http_default_port {
  78     80;
  79 }
  80
  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;
  84     no strict 'refs';
  85     *$method = sub {
  86         my $self = shift;
  87         my $old = ${*$self}{$prop_name};
  88         ${*$self}{$prop_name} = shift if @_;
  89         return $old;
  90     };
  91 }
  92
  93 # we want this one to be a bit smarter
  94 sub http_version {
  95     my $self = shift;
  96     my $old = ${*$self}{'http_version'};
  97     if (@_) {
  98         my $v = shift;
  99         $v = "1.0" if $v eq "1";  # float
 100         unless ($v eq "1.0" or $v eq "1.1") {
 101             require Carp;
 102             Carp::croak("Unsupported HTTP version '$v'");
 103         }
 104         ${*$self}{'http_version'} = $v;
 105     }
 106     $old;
 107 }
 108
 109 sub format_request {
 110     my $self = shift;
 111     my $method = shift;
 112     my $uri = shift;
 113
 114     my $content = (@_ % 2) ? pop : "";
 115
 116     for ($method, $uri) {
 117         require Carp;
 118         Carp::croak("Bad method or uri") if /\s/ || !length;
 119     }
 120
 121     push(@{${*$self}{'http_request_method'}}, $method);
 122     my $ver = ${*$self}{'http_version'};
 123     my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
 124
 125     my @h;
 126     my @connection;
 127     my %given = (host => 0, "content-length" => 0, "te" => 0);
 128     while (@_) {
 129         my($k, $v) = splice(@_, 0, 2);
 130         my $lc_k = lc($k);
 131         if ($lc_k eq "connection") {
 132             $v =~ s/^\s+//;
 133             $v =~ s/\s+$//;
 134             push(@connection, split(/\s*,\s*/, $v));
 135             next;
 136         }
 137         if (exists $given{$lc_k}) {
 138             $given{$lc_k}++;
 139         }
 140         push(@h, "$k: $v");
 141     }
 142
 143     if (length($content) && !$given{'content-length'}) {
 144         push(@h, "Content-Length: " . length($content));
 145     }
 146
 147     my @h2;
 148     if ($given{te}) {
 149         push(@connection, "TE") unless grep lc($_) eq "te", @connection;
 150     }
 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");
 156     }
 157
 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");
 164             }
 165         }
 166         else {
 167             push(@connection, "close") if $ver ge "1.1";
 168         }
 169     }
 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;
 174     }
 175
 176     return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
 177 }
 178
 179
 180 sub write_request {
 181     my $self = shift;
 182     $self->print($self->format_request(@_));
 183 }
 184
 185 sub format_chunk {
 186     my $self = shift;
 187     return $_[0] unless defined($_[0]) && length($_[0]);
 188     return sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF;
 189 }
 190
 191 sub write_chunk {
 192     my $self = shift;
 193     return 1 unless defined($_[0]) && length($_[0]);
 194     $self->print(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
 195 }
 196
 197 sub format_chunk_eof {
 198     my $self = shift;
 199     my @h;
 200     while (@_) {
 201         push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
 202     }
 203     return join("", "0$CRLF", @h, $CRLF);
 204 }
 205
 206 sub write_chunk_eof {
 207     my $self = shift;
 208     $self->print($self->format_chunk_eof(@_));
 209 }
 210
 211
 212 sub my_read {
 213     die if @_ > 3;
 214     my $self = shift;
 215     my $len = $_[1];
 216     for (${*$self}{'http_buf'}) {
 217         if (length) {
 218             $_[0] = substr($_, 0, $len, "");
 219             return length($_[0]);
 220         }
 221         else {
 222             return $self->sysread($_[0], $len);
 223         }
 224     }
 225 }
 226
 227
 228 sub my_readline {
 229     my $self = shift;
 230     for (${*$self}{'http_buf'}) {
 231         my $max_line_length = ${*$self}{'http_max_line_length'};
 232         my $pos;
 233         while (1) {
 234             # find line ending
 235             $pos = index($_, "\012");
 236             last if $pos >= 0;
 237             die "Line too long (limit is $max_line_length)"
 238                 if $max_line_length && length($_) > $max_line_length;
 239
 240             # need to read more data to find a line ending
 241           READ:
 242             {
 243                 my $n = $self->sysread($_, 1024, length);
 244                 unless (defined $n) {
 245                     redo READ if $!{EINTR};
 246                     if ($!{EAGAIN}) {
 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
 250                         redo READ;
 251                     }
 252                     # if we have already accumulated some data let's at least
 253                     # return that as a line
 254                     die "read failed: $!" unless length;
 255                 }
 256                 unless ($n) {
 257                     return undef unless length;
 258                     return substr($_, 0, length, "");
 259                 }
 260             }
 261         }
 262         die "Line too long ($pos; limit is $max_line_length)"
 263             if $max_line_length && $pos > $max_line_length;
 264
 265         my $line = substr($_, 0, $pos+1, "");
 266         $line =~ s/(\015?\012)\z// || die "Assert";
 267         return wantarray ? ($line, $1) : $line;
 268     }
 269 }
 270
 271
 272 sub _rbuf {
 273     my $self = shift;
 274     if (@_) {
 275         for (${*$self}{'http_buf'}) {
 276             my $old;
 277             $old = $_ if defined wantarray;
 278             $_ = shift;
 279             return $old;
 280         }
 281     }
 282     else {
 283         return ${*$self}{'http_buf'};
 284     }
 285 }
 286
 287 sub _rbuf_length {
 288     my $self = shift;
 289     return length ${*$self}{'http_buf'};
 290 }
 291
 292
 293 sub _read_header_lines {
 294     my $self = shift;
 295     my $junk_out = shift;
 296
 297     my @headers;
 298     my $line_count = 0;
 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);
 303         }
 304         elsif (@headers && $line =~ s/^\s+//) {
 305             $headers[-1] .= " " . $line;
 306         }
 307         elsif ($junk_out) {
 308             push(@$junk_out, $line);
 309         }
 310         else {
 311             die "Bad header: '$line'\n";
 312         }
 313         if ($max_header_lines) {
 314             $line_count++;
 315             if ($line_count >= $max_header_lines) {
 316                 die "Too many header lines (limit is $max_header_lines)";
 317             }
 318         }
 319     }
 320     return @headers;
 321 }
 322
 323
 324 sub read_response_headers {
 325     my($self, %opt) = @_;
 326     my $laxed = $opt{laxed};
 327
 328     my($status, $eol) = my_readline($self);
 329     unless (defined $status) {
 330         die "Server closed connection without sending any data back";
 331     }
 332
 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;
 336         # assume HTTP/0.9
 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");
 342     };
 343
 344     ${*$self}{'http_peer_http_version'} = $peer_ver;
 345     ${*$self}{'http_status'} = $code;
 346
 347     my $junk_out;
 348     if ($laxed) {
 349         $junk_out = $opt{junk_out} || [];
 350     }
 351     my @headers = $self->_read_header_lines($junk_out);
 352
 353     # pick out headers that read_entity_body might need
 354     my @te;
 355     my $content_length;
 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];
 360             $te =~ s/^\s+//;
 361             $te =~ s/\s+$//;
 362             push(@te, $te) if length($te);
 363         }
 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;
 368             }
 369         }
 370     }
 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);
 377 }
 378
 379
 380 sub read_entity_body {
 381     my $self = shift;
 382     my $buf_ref = \$_[0];
 383     my $size = $_[1];
 384     die "Offset not supported yet" if $_[2];
 385
 386     my $chunked;
 387     my $bytes;
 388
 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
 397             $bytes = 0;
 398         }
 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";
 403
 404             for (@te) {
 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])) }
 410                 }
 411                 elsif ($_ eq "gzip" && zlib_ok()) {
 412                     #require Compress::Zlib;
 413                     my @buf;
 414                     $_ = sub {
 415                         push(@buf, $_[0]);
 416                         return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
 417                         return "";
 418                     };
 419                 }
 420                 elsif ($_ eq "identity") {
 421                     $_ = sub { $_[0] };
 422                 }
 423                 else {
 424                     die "Can't handle transfer encoding '$te'";
 425                 }
 426             }
 427
 428             @te = reverse(@te);
 429
 430             ${*$self}{'http_te2'} = @te ? \@te : "";
 431             $chunked = -1;
 432         }
 433         elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
 434             $bytes = $content_length;
 435         }
 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]
 439             $bytes = 0;
 440         }
 441         else {
 442             # XXX Multi-Part types are self delimiting, but RFC 2616 says we
 443             # only has to deal with 'multipart/byteranges'
 444
 445             # Read until EOF
 446         }
 447     }
 448     else {
 449         $chunked = ${*$self}{'http_chunked'};
 450         $bytes   = ${*$self}{'http_bytes'};
 451     }
 452
 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
 458
 459         if ($chunked <= 0) {
 460             my $line = my_readline($self);
 461             if ($chunked == 0) {
 462                 die "Missing newline after chunk data: '$line'"
 463                     if !defined($line) || $line ne "";
 464                 $line = my_readline($self);
 465             }
 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";
 471             }
 472             $chunked = hex($1);
 473             if ($chunked == 0) {
 474                 ${*$self}{'http_trailers'} = [$self->_read_header_lines];
 475                 $$buf_ref = "";
 476
 477                 my $n = 0;
 478                 if (my $transforms = delete ${*$self}{'http_te2'}) {
 479                     for (@$transforms) {
 480                         $$buf_ref = &$_($$buf_ref, 1);
 481                     }
 482                     $n = length($$buf_ref);
 483                 }
 484
 485                 # in case somebody tries to read more, make sure we continue
 486                 # to return EOF
 487                 delete ${*$self}{'http_chunked'};
 488                 ${*$self}{'http_bytes'} = 0;
 489
 490                 return $n;
 491             }
 492         }
 493
 494         my $n = $chunked;
 495         $n = $size if $size && $size < $n;
 496         $n = my_read($self, $$buf_ref, $n);
 497         return undef unless defined $n;
 498
 499         ${*$self}{'http_chunked'} = $chunked - $n;
 500
 501         if ($n > 0) {
 502             if (my $transforms = ${*$self}{'http_te2'}) {
 503                 for (@$transforms) {
 504                     $$buf_ref = &$_($$buf_ref, 0);
 505                 }
 506                 $n = length($$buf_ref);
 507                 $n = -1 if $n == 0;
 508             }
 509         }
 510         return $n;
 511     }
 512     elsif (defined $bytes) {
 513         unless ($bytes) {
 514             $$buf_ref = "";
 515             return 0;
 516         }
 517         my $n = $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;
 522         return $n;
 523     }
 524     else {
 525         # read until eof
 526         $size ||= 8*1024;
 527         return my_read($self, $$buf_ref, $size);
 528     }
 529 }
 530
 531 sub get_trailers {
 532     my $self = shift;
 533     @{${*$self}{'http_trailers'} || []};
 534 }
 535
 536 BEGIN {
 537 my $zlib_ok;
 538
 539 sub zlib_ok {
 540     return $zlib_ok if defined $zlib_ok;
 541
 542     # Try to load Compress::Zlib.
 543     local $@;
 544     local $SIG{__DIE__};
 545     $zlib_ok = 0;
 546
 547     eval {
 548         require Compress::Zlib;
 549         Compress::Zlib->VERSION(1.10);
 550         $zlib_ok++;
 551     };
 552
 553     return $zlib_ok;
 554 }
 555
 556 } # BEGIN
 557
 558 1;