home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Net / HTTP / Methods.pm next >
Encoding:
Perl POD Document  |  2005-12-07  |  12.4 KB  |  530 lines

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