view release on metacpan or  search on metacpan

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

  unless (exists $self->{body_params}) {
    $self->{body_params} = {names => \my @names, ordered => \my @ordered, keyed => \my %keyed};
    if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m/^application\/x-www-form-urlencoded\b/i) {
      foreach my $pair (split /&/, $self->body) {
        my ($name, $value) = split /=/, $pair, 2;
        $value = '' unless defined $value;
        do { tr/+/ /; s/%([0-9a-fA-F]{2})/chr hex $1/ge; utf8::decode $_ } for $name, $value;
        push @names, $name unless exists $keyed{$name};
        push @ordered, [$name, $value];
        push @{$keyed{$name}}, $value;
      }
    } elsif ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m/^multipart\/form-data\b/i) {
      my $default_charset = $self->{multipart_form_charset};
      $default_charset = 'UTF-8' unless defined $default_charset;
      foreach my $part (@{$self->_body_multipart}) {
        next if defined $part->{filename};
        my ($name, $headers, $content, $file) = @$part{'name','headers','content','file'};
        if (length $default_charset) {
          require Encode;
          $name = Encode::decode($default_charset, "$name");
        }
        my $value = '';
        if (defined $content) {
          $value = $content;
        } elsif (defined $file) {
          binmode $file;
          seek $file, 0, 0;
          $value = do { local $/; readline $file };
          seek $file, 0, 0;
        }
        my $value_charset;
        if (defined $headers->{'content-type'}) {
          if (my ($charset_quoted, $charset_unquoted) = $headers->{'content-type'} =~ m/;\s*charset=(?:"((?:\\[\\"]|[^"])+)"|([^";]+))/i) {
            $charset_quoted =~ s/\\([\\"])/$1/g if defined $charset_quoted;
            $value_charset = defined $charset_quoted ? $charset_quoted : $charset_unquoted;
          }
        }
        if (defined $value_charset or !defined $headers->{'content-type'} or $headers->{'content-type'} =~ m/^text\/plain\b/i) {
          require Encode;
          if (defined $value_charset) {
            $value = Encode::decode($value_charset, "$value");
          } elsif (length $default_charset) {
            $value = Encode::decode($default_charset, "$value");
          }
        }
        push @names, $name unless exists $keyed{$name};
        push @ordered, [$name, $value];
        push @{$keyed{$name}}, $value;
      }
    }
  }
  return $self->{body_params};
}

sub body_parts {
  my ($self) = @_;
  return [] unless $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m/^multipart\/form-data\b/i;
  return [map { +{%$_} } @{$self->_body_multipart}];
}

sub uploads      { [map { [@$_] } @{$_[0]->_body_uploads->{ordered}}] }
sub upload_names { [@{$_[0]->_body_uploads->{names}}] }
sub upload       { my $u = $_[0]->_body_uploads->{keyed}; exists $u->{$_[1]} ? $u->{$_[1]}[-1] : undef }
sub upload_array { my $u = $_[0]->_body_uploads->{keyed}; exists $u->{$_[1]} ? [@{$u->{$_[1]}}] : [] }

sub _body_uploads {
  my ($self) = @_;
  unless (exists $self->{body_uploads}) {
    $self->{body_uploads} = {names => \my @names, ordered => \my @ordered, keyed => \my %keyed};
    if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m/^multipart\/form-data\b/i) {
      my $default_charset = $self->{multipart_form_charset};
      $default_charset = 'UTF-8' unless defined $default_charset;
      foreach my $part (@{$self->_body_multipart}) {
        next unless defined $part->{filename};
        my ($name, $filename, $size, $headers, $file, $content) = @$part{'name','filename','size','headers','file','content'};
        if (length $default_charset) {
          require Encode;
          $name = Encode::decode($default_charset, "$name");
          $filename = Encode::decode($default_charset, "$filename");
        }
        my $upload = {
          filename     => $filename,
          size         => $size,
          content_type => $headers->{'content-type'},
        };
        $upload->{file} = $file if defined $file;
        $upload->{content} = $content if defined $content;
        push @names, $name unless exists $keyed{$name};
        push @ordered, [$name, $upload];
        push @{$keyed{$name}}, $upload;
      }
    }
  }
  return $self->{body_uploads};
}

sub _body_length {
  my ($self) = @_;
  my $limit = $self->{request_body_limit};
  $limit = $ENV{CGI_TINY_REQUEST_BODY_LIMIT} unless defined $limit;
  $limit = DEFAULT_REQUEST_BODY_LIMIT unless defined $limit;
  my $length = $ENV{CONTENT_LENGTH} || 0;
  if ($limit and $length > $limit) {
    $self->{response_status} = "413 $HTTP_STATUS{413}" unless $self->{headers_rendered};
    die "Request body limit exceeded\n";
  }
  return 0 + $length;
}

sub _body_multipart {
  my ($self) = @_;
  unless (exists $self->{body_parts}) {
    $self->{body_parts} = [];
    require CGI::Tiny::Multipart;
    my $boundary = CGI::Tiny::Multipart::extract_multipart_boundary($ENV{CONTENT_TYPE});
    unless (defined $boundary) {
      $self->{response_status} = "400 $HTTP_STATUS{400}" unless $self->{headers_rendered};
      die "Malformed multipart/form-data request\n";
    }

    my ($input, $length);
    if (exists $self->{body_content}) {
      $length = length $self->{body_content};
      $input = \$self->{body_content};
    } else {
      $length = $self->_body_length;
      $input = defined $self->{input_handle} ? $self->{input_handle} : *STDIN;
    }

    my $parts = CGI::Tiny::Multipart::parse_multipart_form_data($input, $length, $boundary, {
      buffer_size => $self->{request_body_buffer} || $ENV{CGI_TINY_REQUEST_BODY_BUFFER},
      %{$self->{multipart_form_options} || {}},
    });
    unless (defined $parts) {
      $self->{response_status} = "400 $HTTP_STATUS{400}" unless $self->{headers_rendered};
      die "Malformed multipart/form-data request\n";
    }

    $self->{body_parts} = $parts;
  }
  return $self->{body_parts};
}

sub set_nph {
  my ($self, $value) = @_;
  if ($self->{headers_rendered}) {
    Carp::carp "Attempted to set NPH response mode but headers have already been rendered";
  } else {
    $self->{nph} = @_ < 2 ? 1 : $value;
  }
  return $self;
}

sub set_response_body_buffer { $_[0]{response_body_buffer} = $_[1]; $_[0] }