view release on metacpan or  search on metacpan

lib/CGI/Simple.pm  view on Meta::CPAN

  for my $value ( @values ) {
    next
     if $value eq ''
       and $self->{'.globals'}->{'NO_UNDEF_PARAMS'};
    $value =~ tr/\000//d
     if $self->{'.globals'}->{'NO_NULL'} and $param ne 'PUTDATA' and $param ne 'POSTDATA';
    $value = Encode::decode( utf8 => $value )
     if $self->{'.globals'}->{PARAM_UTF8} and $param ne 'PUTDATA' and $param ne 'POSTDATA';
    push @{ $self->{$param} }, $value;
    unless ( $self->{'.fieldnames'}->{$param} ) {
      push @{ $self->{'.parameters'} }, $param;
      $self->{'.fieldnames'}->{$param}++;
    }
  }
  return scalar @values;    # for compatibility with CGI.pm request.t
}

sub _parse_keywordlist {
  my ( $self, $data ) = @_;
  return () unless defined $data;
  $data = $self->url_decode( $data );
  $data =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
  my @keywords = split /\s+/, $data;
  return @keywords;
}

sub _massage_boundary {
  my ( $self, $boundary ) = @_;

  # BUG: IE 3.01 on the Macintosh uses just the boundary,
  # forgetting the --
  $boundary = '--' . $boundary
   unless exists $ENV{'HTTP_USER_AGENT'}
     && $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+3\.0[12];\s*Mac/i;

  return quotemeta $boundary;
}

sub _parse_multipart {
  my $self = shift;
  my $handle = shift or die "NEED A HANDLE!?";

  my ( $boundary )
   = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;

  $boundary = $self->_massage_boundary( $boundary ) if $boundary;

  my $got_data = 0;
  my $data     = '';
  my $length   = $ENV{'CONTENT_LENGTH'} || 0;
  my $CRLF     = $self->crlf;

  READ:

  while ( $got_data < $length ) {
    last READ unless _internal_read( $self, $handle, my $buffer );
    $data .= $buffer;
    $got_data += length $buffer;

    unless ( $boundary ) {
      # If we're going to guess the boundary we need a complete line.
      next READ unless $data =~ /^(.*)$CRLF/o;
      $boundary = $1;

      # Still no boundary? Give up...
      unless ( $boundary ) {
        $self->cgi_error(
          '400 No boundary supplied for multipart/form-data' );
        return 0;
      }
      $boundary = $self->_massage_boundary( $boundary );
    }

    BOUNDARY:

    while ( $data =~ m/^$boundary$CRLF/ ) {
      ## TAB and high ascii chars are definitivelly allowed in headers.
      ## Not accepting them in the following regex prevents the upload of
      ## files with filenames like "España.txt".
      # next READ unless $data =~ m/^([\040-\176$CRLF]+?$CRLF$CRLF)/o;
      next READ
       unless $data =~ m/^([\x20-\x7E\x80-\xFF\x09$CRLF]+?$CRLF$CRLF)/o;
      my $header = $1;
      ( my $unfold = $1 ) =~ s/$CRLF\s+/ /og;
      my ( $param ) = $unfold =~ m/form-data;\s+name="?([^\";]*)"?/;
      my ( $filename )
       = $unfold =~ m/name="?\Q$param\E"?;\s+filename="?([^\"]*)"?/;

      if ( defined $filename ) {
        my ( $mime ) = $unfold =~ m/Content-Type:\s+([-\w\+\.\/]+)/io;
        $data =~ s/^\Q$header\E//;
        ( $got_data, $data, my $fh, my $size )
         = $self->_save_tmpfile( $handle, $boundary, $filename,
          $got_data, $data );
        $self->_add_param( $param, $filename );
        $self->{'.upload_fields'}->{$param} = $filename;
        $self->{'.filehandles'}->{$filename} = $fh if $fh;
        $self->{'.tmpfiles'}->{$filename}
         = { 'size' => $size, 'mime' => $mime }
         if $size;
        next BOUNDARY;
      }
      next READ
       unless $data =~ s/^\Q$header\E(.*?)$CRLF(?=$boundary)//s;
      $self->_add_param( $param, $1 );
    }
    unless ( $data =~ m/^$boundary/ ) {
      ## In a perfect world, $data should always begin with $boundary.
      ## But sometimes, IE5 prepends garbage boundaries into POST(ed) data.
      ## Then, $data does not start with $boundary and the previous block
      ## never gets executed. The following fix attempts to remove those
      ## extra boundaries from readed $data and restart boundary parsing.
      ## Note about performance: with well formed data, previous check is
      ## executed (generally) only once, when $data value is "$boundary--"
      ## at end of parsing.
      goto BOUNDARY if ( $data =~ s/.*?$CRLF(?=$boundary$CRLF)//s );
    }
  }
  return $got_data;
}