package Foo::CGI::Rest; use base 'CGI::Simple'; sub _read_parse { my $self = shift; my $data = ''; my $type = $ENV{'CONTENT_TYPE'} || 'No CONTENT_TYPE received'; my $length = $ENV{'CONTENT_LENGTH'} || 0; my $method = $ENV{'REQUEST_METHOD'} || 'No REQUEST_METHOD received'; # change #1 - added or "PUT" here ... we don't want # malicious PUTs either # first check POST_MAX Steve Purkis pointed out the previous bug if( ( $method eq 'POST' or $method eq "PUT" ) and $self->{'.globals'}->{'POST_MAX'} != -1 and $length > $self->{'.globals'}->{'POST_MAX'}) { $self->cgi_error( "413 Request entity too large: $length bytes on STDIN exceeds \$POST_MAX!" ); # silently discard data ??? better to just close the socket ??? while ($length > 0) { last unless sysread(STDIN, my $buffer, 4096); $length -= length($buffer); } return; } if( $length and $type =~ m|^multipart/form-data|i ) { my $got_length = $self->_parse_multipart; if( $length != $got_length ) { $self->cgi_error("500 Bad read on multipart/form-data! wanted $length, got $got_length"); } # changed #2 - or "PUT" here too } elsif( $method eq 'POST' or $method eq 'PUT' ) { if( $length ) { # we may not get all the data we want with a single read on large # POSTs as it may not be here yet! Credit Jason Luther for patch # CGI.pm < 2.99 suffers from same bug sysread(STDIN, $data, $length); while( length($data) < $length ) { last unless sysread(STDIN, my $buffer, 4096); $data .= $buffer; } # change 3 - don't send data to parse params ... it's not form data if( $length == length $data ) { $self->set_data( $data ); } else { $self->cgi_error("500 Bad read on POST! wanted $length, got " . length($data)); } } } elsif( $method eq 'GET' or $method eq 'HEAD' ) { $data = $self->{'.mod_perl'} ? $self->_mod_perl_request()->args() : $ENV{'QUERY_STRING'} || $ENV{'REDIRECT_QUERY_STRING'} || ''; $self->_parse_params($data); } else { unless ($self->{'.globals'}->{'DEBUG'} and $data = $self->read_from_cmdline()) { $self->cgi_error("400 Unknown method $method"); } } } # change 4 - create accessors sub set_data { my( $self, $data ) = @_; $self->{_data} = $data; } sub get_data { my( $self ) = @_; return $self->{_data}; } 1;