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