"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/Net/HTTP/Methods.pm" (7 Mar 2020, 17333 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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