view release on metacpan or  search on metacpan

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

      $self->{response_disposition} = $disposition;
      # filename will be quoted/escaped later
      $self->{response_filename} = $filename;
    }
    return $self;
  }
}

sub set_response_type {
  my ($self, $content_type) = @_;
  if ($self->{headers_rendered}) {
    Carp::carp "Attempted to set HTTP response content type but headers have already been rendered";
  } else {
    Carp::croak "Newline characters not allowed in HTTP response content type" if defined $content_type and $content_type =~ tr/\r\n//;
    $self->{response_type} = $content_type;
  }
  return $self;
}

sub set_response_charset {
  my ($self, $charset) = @_;
  Carp::croak "Invalid characters in HTTP response charset" if defined $charset and $charset =~ m/[^a-zA-Z0-9!#\$%&'*+\-.^_`|~]/;
  $self->{response_charset} = $charset;
  return $self;
}

sub add_response_header {
  my ($self, $name, $value) = @_;
  if ($self->{headers_rendered}) {
    Carp::carp "Attempted to add HTTP response header '$name' but headers have already been rendered";
  } else {
    Carp::croak "Newline characters not allowed in HTTP response header '$name'" if $value =~ tr/\r\n//;
    push @{$self->{response_headers}}, [$name, $value];
  }
  return $self;
}

{
  my %COOKIE_ATTR_VALUE = (expires => 1, domain => 1, path => 1, secure => 0, httponly => 0, samesite => 1, 'max-age' => 1);
  sub add_response_cookie {
    my ($self, $name, $value, @attrs) = @_;
    if ($self->{headers_rendered}) {
      Carp::carp "Attempted to add HTTP response cookie '$name' but headers have already been rendered";
    } else {
      my $cookie_str = "$name=$value";
      my $i = 0;
      while ($i <= $#attrs) {
        my ($key, $val) = @attrs[$i, $i+1];
        my $has_value = $COOKIE_ATTR_VALUE{lc $key};
        if (!defined $has_value) {
          Carp::croak "Attempted to set unknown cookie attribute '$key' for HTTP response cookie '$name'";
        } elsif ($has_value) {
          $cookie_str .= "; $key=$val" if defined $val;
        } else {
          $cookie_str .= "; $key" if $val;
        }
      } continue {
        $i += 2;
      }
      Carp::croak "Newline characters not allowed in HTTP response cookie '$name'" if $cookie_str =~ tr/\r\n//;
      push @{$self->{response_headers}}, ['Set-Cookie', $cookie_str];
    }
    return $self;
  }
}

sub reset_response_headers { delete $_[0]{response_headers}; $_[0] }

sub response_status_code {
  my ($self) = @_;
  if (defined $self->{response_status} and $self->{response_status} =~ m/\A([0-9]+)/) {
    return 0+$1;
  }
  return 200;
}

{
  my %RENDER_TYPES = (text => 1, html => 1, xml => 1, json => 1, data => 1, file => 1, handle => 1, redirect => 1);

  sub render {
    my ($self, $type, $data) = @_;
    Carp::croak "Cannot render additional data with ->render; use ->render_chunk" if $self->{headers_rendered};
    $type = '' unless defined $type;
    Carp::croak "Don't know how to render '$type'" if length $type and !exists $RENDER_TYPES{$type};
    Carp::croak "Cannot render from an open filehandle with ->render; use ->render_chunk" if $type eq 'handle';

    my ($response_body, $response_length, $redirect_url);
    if ($type eq 'redirect') {
      Carp::croak "Newline characters not allowed in HTTP redirect" if $data =~ tr/\r\n//;
      $redirect_url = $data;
    } elsif (uc($ENV{REQUEST_METHOD} || '') eq 'HEAD') {
      # no response content
    } elsif ($type eq 'text' or $type eq 'html' or $type eq 'xml') {
      my $charset = $self->{response_charset};
      $charset = 'UTF-8' unless defined $charset;
      if (uc $charset eq 'UTF-8' and do { local $@; eval { require Unicode::UTF8; 1 } }) {
        $response_body = Unicode::UTF8::encode_utf8($data);
      } else {
        require Encode;
        $response_body = Encode::encode($charset, "$data");
      }
      $response_length = length $response_body;
    } elsif ($type eq 'json') {
      $response_body = $self->_json->encode($data);
      $response_length = length $response_body;
    } elsif ($type eq 'data') {
      $response_body = $data;
      $response_length = length $response_body;
    } elsif ($type eq 'file') {
      $response_length = -s $data;
      Carp::croak "Failed to retrieve size of file '$data': $!" unless defined $response_length;
    }
    $response_length = 0 unless defined $response_length;

    my $headers_str = $self->_response_headers($type, $response_length, $redirect_url);
    my $out_fh = defined $self->{output_handle} ? $self->{output_handle} : *STDOUT;
    binmode $out_fh;
    $out_fh->printflush($headers_str);
    $self->{headers_rendered} = 1;
    $self->{response_fixed_length} = 1;
    return $self unless $response_length;