CGI-Tiny/lib/CGI/Tiny.pm
package CGI::Tiny;
# ABSTRACT: Common Gateway Interface, with no frills
# This file is part of CGI::Tiny which is released under:
# The Artistic License 2.0 (GPL Compatible)
# See the documentation for CGI::Tiny for full license details.
use strict;
use warnings;
use Carp ();
use IO::Handle ();
use Exporter ();
our $VERSION = '1.003';
use constant DEFAULT_REQUEST_BODY_LIMIT => 16777216;
use constant DEFAULT_REQUEST_BODY_BUFFER => 262144;
use constant DEFAULT_RESPONSE_BODY_BUFFER => 131072;
our @EXPORT = 'cgi';
# List from HTTP::Status 6.46
# Unmarked codes are from RFC 7231 (2017-12-20)
my %HTTP_STATUS = (
100 => 'Continue',
101 => 'Switching Protocols',
102 => 'Processing', # RFC 2518: WebDAV
103 => 'Early Hints', # RFC 8297: Indicating Hints
200 => 'OK',
201 => 'Created',
202 => 'Accepted',
203 => 'Non-Authoritative Information',
204 => 'No Content',
205 => 'Reset Content',
206 => 'Partial Content', # RFC 7233: Range Requests
207 => 'Multi-Status', # RFC 4918: WebDAV
208 => 'Already Reported', # RFC 5842: WebDAV bindings
226 => 'IM Used', # RFC 3229: Delta encoding
300 => 'Multiple Choices',
301 => 'Moved Permanently',
302 => 'Found',
303 => 'See Other',
304 => 'Not Modified', # RFC 7232: Conditional Request
305 => 'Use Proxy',
307 => 'Temporary Redirect',
308 => 'Permanent Redirect', # RFC 9110: HTTP Semantics
400 => 'Bad Request',
401 => 'Unauthorized', # RFC 7235: Authentication
402 => 'Payment Required',
403 => 'Forbidden',
404 => 'Not Found',
405 => 'Method Not Allowed',
406 => 'Not Acceptable',
407 => 'Proxy Authentication Required', # RFC 7235: Authentication
408 => 'Request Timeout',
409 => 'Conflict',
410 => 'Gone',
411 => 'Length Required',
412 => 'Precondition Failed', # RFC 7232: Conditional Request
413 => 'Content Too Large', # RFC 9110: HTTP Semantics
414 => 'URI Too Long',
415 => 'Unsupported Media Type',
416 => 'Range Not Satisfiable', # RFC 7233: Range Requests
417 => 'Expectation Failed',
418 => 'I\'m a teapot', # RFC 2324: HTCPC/1.0 1-april
421 => 'Misdirected Request', # RFC 9110: HTTP Semantics
422 => 'Unprocessable Content', # RFC 9110: HTTP Semantics
423 => 'Locked', # RFC 4918: WebDAV
424 => 'Failed Dependency', # RFC 4918: WebDAV
425 => 'Too Early', # RFC 8470: Using Early Data in HTTP
426 => 'Upgrade Required',
428 => 'Precondition Required', # RFC 6585: Additional Codes
429 => 'Too Many Requests', # RFC 6585: Additional Codes
431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes
451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
506 => 'Variant Also Negotiates', # RFC 2295: Transparant Ngttn
507 => 'Insufficient Storage', # RFC 4918: WebDAV
508 => 'Loop Detected', # RFC 5842: WebDAV bindings
509 => 'Bandwidth Limit Exceeded', # Apache / cPanel
510 => 'Not Extended', # RFC 2774: Extension Framework
511 => 'Network Authentication Required', # RFC 6585: Additional Codes
);
{
my $cgi;
sub import {
# for cleanup in END in case of premature exit
$cgi ||= bless {pid => $$}, $_[0];
goto &Exporter::import;
}
sub cgi (&) {
my ($handler) = @_;
$cgi ||= bless {pid => $$}, __PACKAGE__;
if (@ARGV and !defined $ENV{REQUEST_METHOD}) {
require CGI::Tiny::_Debug;
CGI::Tiny::_Debug::debug_command($cgi, [@ARGV]);
}
my ($error, $errored);
{
local $@;
eval { local $_ = $cgi; $handler->(); 1 } or do { $error = $@; $errored = 1 };
}
if ($errored) {
_handle_error($cgi, $error);
} elsif (!$cgi->{headers_rendered}) {
_handle_error($cgi, "cgi completed without rendering a response\n");
}
undef $cgi;
1;
}
# cleanup of premature exit, more reliable than potentially doing this in global destruction
# ModPerl::Registry or CGI::Compile won't run END after each request,
# but they override exit to throw an exception which we handle already
END {
if (defined $cgi) {
_handle_error($cgi, "cgi exited without rendering a response\n") unless $cgi->{headers_rendered};
undef $cgi;
}
}
}
sub _handle_error {
my ($cgi, $error) = @_;
return unless $cgi->{pid} == $$; # in case of fork
$cgi->{response_status} = "500 $HTTP_STATUS{500}" unless $cgi->{headers_rendered}
or (defined $cgi->{response_status} and $cgi->{response_status} =~ m/^[45][0-9]{2} /);
if (defined(my $handler = $cgi->{on_error})) {
my ($error_error, $error_errored);
{
local $@;
eval { $handler->($cgi, $error, !!$cgi->{headers_rendered}); 1 } or do { $error_error = $@; $error_errored = 1 };
}
return unless $cgi->{pid} == $$; # in case of fork in error handler
if ($error_errored) {
warn "Exception in error handler: $error_error";
warn "Original error: $error";
}
} else {
warn $error;
}
$cgi->set_response_type('text/plain')->render(data => $cgi->{response_status}) unless $cgi->{headers_rendered};
}
sub set_error_handler { $_[0]{on_error} = $_[1]; $_[0] }
sub set_request_body_buffer { $_[0]{request_body_buffer} = $_[1]; $_[0] }
sub set_request_body_limit { $_[0]{request_body_limit} = $_[1]; $_[0] }
sub set_multipart_form_options { $_[0]{multipart_form_options} = $_[1]; $_[0] }
sub set_multipart_form_charset { $_[0]{multipart_form_charset} = $_[1]; $_[0] }
sub set_input_handle { $_[0]{input_handle} = $_[1]; $_[0] }
sub set_output_handle { $_[0]{output_handle} = $_[1]; $_[0] }
sub auth_type { defined $ENV{AUTH_TYPE} ? $ENV{AUTH_TYPE} : '' }
sub content_length { defined $ENV{CONTENT_LENGTH} ? $ENV{CONTENT_LENGTH} : '' }
sub content_type { defined $ENV{CONTENT_TYPE} ? $ENV{CONTENT_TYPE} : '' }
sub gateway_interface { defined $ENV{GATEWAY_INTERFACE} ? $ENV{GATEWAY_INTERFACE} : '' }
sub path_info { defined $ENV{PATH_INFO} ? $ENV{PATH_INFO} : '' }
*path = \&path_info;
sub path_translated { defined $ENV{PATH_TRANSLATED} ? $ENV{PATH_TRANSLATED} : '' }
sub query_string { defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : '' }
*query = \&query_string;
sub remote_addr { defined $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : '' }
sub remote_host { defined $ENV{REMOTE_HOST} ? $ENV{REMOTE_HOST} : '' }
sub remote_ident { defined $ENV{REMOTE_IDENT} ? $ENV{REMOTE_IDENT} : '' }
sub remote_user { defined $ENV{REMOTE_USER} ? $ENV{REMOTE_USER} : '' }
sub request_method { defined $ENV{REQUEST_METHOD} ? $ENV{REQUEST_METHOD} : '' }
*method = \&request_method;
sub script_name { defined $ENV{SCRIPT_NAME} ? $ENV{SCRIPT_NAME} : '' }
sub server_name { defined $ENV{SERVER_NAME} ? $ENV{SERVER_NAME} : '' }
sub server_port { defined $ENV{SERVER_PORT} ? $ENV{SERVER_PORT} : '' }
sub server_protocol { defined $ENV{SERVER_PROTOCOL} ? $ENV{SERVER_PROTOCOL} : '' }
sub server_software { defined $ENV{SERVER_SOFTWARE} ? $ENV{SERVER_SOFTWARE} : '' }
sub headers {
my ($self) = @_;
unless (exists $self->{request_headers}) {
my %headers;
foreach my $key (keys %ENV) {
my $name = $key;
next unless $name =~ s/^HTTP_//;
$name =~ tr/_/-/;
$headers{lc $name} = $ENV{$key};
}
$self->{request_headers} = \%headers;
}
return {%{$self->{request_headers}}};
}
sub header { (my $name = $_[1]) =~ tr/-/_/; $ENV{"HTTP_\U$name"} }
sub cookies { [map { [@$_] } @{$_[0]->_cookies->{ordered}}] }
sub cookie_names { [@{$_[0]->_cookies->{names}}] }
sub cookie { my $c = $_[0]->_cookies->{keyed}; exists $c->{$_[1]} ? $c->{$_[1]}[-1] : undef }
sub cookie_array { my $c = $_[0]->_cookies->{keyed}; exists $c->{$_[1]} ? [@{$c->{$_[1]}}] : [] }
sub _cookies {
my ($self) = @_;
unless (exists $self->{request_cookies}) {
$self->{request_cookies} = {names => \my @names, ordered => \my @ordered, keyed => \my %keyed};
if (defined $ENV{HTTP_COOKIE}) {
foreach my $pair (split /\s*;\s*/, $ENV{HTTP_COOKIE}) {
next unless length $pair;
my ($name, $value) = split /=/, $pair, 2;
next unless defined $value;
push @names, $name unless exists $keyed{$name};
push @ordered, [$name, $value];
push @{$keyed{$name}}, $value;
}
}
}
return $self->{request_cookies};
}
sub params { [map { [@$_] } @{$_[0]->_query_params->{ordered}}, @{$_[0]->_body_params->{ordered}}] }
sub param_names { my $q = $_[0]->_query_params; [@{$q->{names}}, grep { !exists $q->{keyed}{$_} } @{$_[0]->_body_params->{names}}] }
sub param {
my ($self, $name) = @_;
my $p = $self->_body_params->{keyed};
return $p->{$name}[-1] if exists $p->{$name};
my $q = $self->_query_params->{keyed};
return exists $q->{$name} ? $q->{$name}[-1] : undef;
}
sub param_array { [map { exists $_->{$_[1]} ? @{$_->{$_[1]}} : () } $_[0]->_query_params->{keyed}, $_[0]->_body_params->{keyed}] }
sub query_params { [map { [@$_] } @{$_[0]->_query_params->{ordered}}] }
sub query_param_names { [@{$_[0]->_query_params->{names}}] }
sub query_param { my $p = $_[0]->_query_params->{keyed}; exists $p->{$_[1]} ? $p->{$_[1]}[-1] : undef }
sub query_param_array { my $p = $_[0]->_query_params->{keyed}; exists $p->{$_[1]} ? [@{$p->{$_[1]}}] : [] }
sub _query_params {
my ($self) = @_;
unless (exists $self->{query_params}) {
$self->{query_params} = {names => \my @names, ordered => \my @ordered, keyed => \my %keyed};
foreach my $pair (split /[&;]/, $self->query) {
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;
}
}
return $self->{query_params};
}
sub body {
my ($self) = @_;
unless (exists $self->{body_content} or exists $self->{body_parts}) {
$self->{body_content} = '';
my $length = $self->_body_length;
my $in_fh = defined $self->{input_handle} ? $self->{input_handle} : *STDIN;
binmode $in_fh;
my $buffer_size = 0 + ($self->{request_body_buffer} || $ENV{CGI_TINY_REQUEST_BODY_BUFFER} || DEFAULT_REQUEST_BODY_BUFFER);
while ($length > 0) {
my $chunk = $length < $buffer_size ? $length : $buffer_size;
last unless my $read = read $in_fh, $self->{body_content}, $chunk, length $self->{body_content};
$length -= $read;
}
}
return $self->{body_content};
}
sub body_json {
my ($self) = @_;
unless (exists $self->{body_json}) {
$self->{body_json} = undef;
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ m/^application\/json\b/i) {
$self->{body_json} = $self->_json->decode($self->body);
}
}
return $self->{body_json};
}
sub body_params { [map { [@$_] } @{$_[0]->_body_params->{ordered}}] }
sub body_param_names { [@{$_[0]->_body_params->{names}}] }
sub body_param { my $p = $_[0]->_body_params->{keyed}; exists $p->{$_[1]} ? $p->{$_[1]}[-1] : undef }
sub body_param_array { my $p = $_[0]->_body_params->{keyed}; exists $p->{$_[1]} ? [@{$p->{$_[1]}}] : [] }
sub _body_params {
my ($self) = @_;
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] }
sub set_response_status {
my ($self, $status) = @_;
if ($self->{headers_rendered}) {
Carp::carp "Attempted to set HTTP response status but headers have already been rendered";
} else {
if (defined $status and $status =~ m/\A[0-9]+ [^\r\n]*\z/) {
$self->{response_status} = $status;
} elsif (defined $status) {
Carp::croak "Attempted to set unknown HTTP response status $status" unless exists $HTTP_STATUS{$status};
$self->{response_status} = "$status $HTTP_STATUS{$status}";
} else {
delete $self->{response_status};
}
}
return $self;
}
{
my %DISPOSITIONS = (attachment => 1, inline => 1);
sub set_response_disposition {
my ($self, $disposition, $filename) = @_;
if ($self->{headers_rendered}) {
Carp::carp "Attempted to set HTTP response content disposition but headers have already been rendered";
} else {
Carp::croak "Attempted to set unknown Content-Disposition value '$disposition'" unless exists $DISPOSITIONS{lc $disposition};
$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;
if ($type eq 'file') {
open my $in_fh, '<', $data or Carp::croak "Failed to open file '$data' for rendering: $!";
binmode $in_fh;
my $buffer_size = 0 + ($self->{response_body_buffer} || $ENV{CGI_TINY_RESPONSE_BODY_BUFFER} || DEFAULT_RESPONSE_BODY_BUFFER);
while (read $in_fh, my $buffer, $buffer_size) {
$out_fh->print($buffer);
}
$out_fh->flush;
} else {
$out_fh->printflush($response_body);
}
return $self;
}
sub render_chunk {
my ($self, $type, $data) = @_;
Carp::croak "Cannot render additional data after ->render" if $self->{response_fixed_length};
$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 a chunked redirect" if $type eq 'redirect';
my $out_fh = defined $self->{output_handle} ? $self->{output_handle} : *STDOUT;
unless ($self->{headers_rendered}) {
my $headers_str = $self->_response_headers($type);
binmode $out_fh;
$out_fh->printflush($headers_str);
$self->{headers_rendered} = 1;
}
if (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;
my $response_body;
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");
}
$out_fh->printflush($response_body);
} elsif ($type eq 'json') {
my $response_body = $self->_json->encode($data);
$out_fh->printflush($response_body);
} elsif ($type eq 'data') {
$out_fh->printflush($data);
} elsif ($type eq 'file' or $type eq 'handle') {
my $in_fh;
if ($type eq 'file') {
open $in_fh, '<', $data or Carp::croak "Failed to open file '$data' for rendering: $!";
} else {
$in_fh = $data;
}
binmode $in_fh;
my $buffer_size = 0 + ($self->{response_body_buffer} || $ENV{CGI_TINY_RESPONSE_BODY_BUFFER} || DEFAULT_RESPONSE_BODY_BUFFER);
while (read $in_fh, my $buffer, $buffer_size) {
$out_fh->print($buffer);
}
$out_fh->flush;
}
return $self;
}
}
sub _response_headers {
my ($self, $type, $content_length, $location) = @_;
my $headers_str = '';
return $headers_str if defined $self->{debug_method} and !$self->{debug_verbose};
my %headers_set;
foreach my $header (@{$self->{response_headers} || []}) {
my ($name, $value) = @$header;
$headers_str .= "$name: $value\r\n";
$headers_set{lc $name} = 1;
}
if (!$headers_set{'content-length'} and defined $content_length) {
$headers_str = "Content-Length: $content_length\r\n$headers_str";
}
if (!$headers_set{'content-disposition'} and (defined $self->{response_disposition} or defined $self->{response_filename})) {
my $value = defined $self->{response_disposition} ? $self->{response_disposition} : 'inline';
if (defined(my $filename = $self->{response_filename})) {
require Encode;
my $quoted_filename = Encode::encode('ISO-8859-1', "$filename");
$quoted_filename =~ tr/\r\n/ /;
$quoted_filename =~ s/([\\"])/\\$1/g;
$value .= "; filename=\"$quoted_filename\"";
my $ext_filename = Encode::encode('UTF-8', "$filename");
$ext_filename =~ s/([^a-zA-Z0-9!#\$&+\-.^_`|~])/sprintf '%%%02X', ord $1/ge;
$value .= "; filename*=UTF-8''$ext_filename";
}
$headers_str = "Content-Disposition: $value\r\n$headers_str" unless lc $value eq 'inline';
}
if (!$headers_set{location} and $type eq 'redirect') {
$headers_str = "Location: $location\r\n$headers_str";
}
if (!$headers_set{'content-type'} and $type ne 'redirect') {
my $content_type = $self->{response_type};
my $charset = $self->{response_charset};
$charset = 'UTF-8' unless defined $charset;
$content_type =
$type eq 'text' ? "text/plain;charset=$charset"
: $type eq 'html' ? "text/html;charset=$charset"
: $type eq 'xml' ? "application/xml;charset=$charset"
: $type eq 'json' ? 'application/json;charset=UTF-8'
: 'application/octet-stream'
unless defined $content_type or (defined $content_length and $content_length == 0);
$headers_str = "Content-Type: $content_type\r\n$headers_str" if defined $content_type;
}
if (!$headers_set{date}) {
my $date_str = epoch_to_date(time);
$headers_str = "Date: $date_str\r\n$headers_str";
}
my $status = $self->{response_status};
$status = $self->{response_status} = "302 $HTTP_STATUS{302}" if $type eq 'redirect'
and !(defined $status and $status =~ m/^3[0-9]{2} /);
if ($self->{nph}) {
$status = "200 $HTTP_STATUS{200}" unless defined $status;
my $protocol = $ENV{SERVER_PROTOCOL};
$protocol = 'HTTP/1.0' unless defined $protocol and length $protocol;
$headers_str = "$protocol $status\r\n$headers_str";
my $server = $ENV{SERVER_SOFTWARE};
$headers_str .= "Server: $server\r\n" if defined $server and length $server;
} elsif (!$headers_set{status} and defined $status) {
$headers_str = "Status: $status\r\n$headers_str";
}
return "$headers_str\r\n";
}
sub _json {
my ($self) = @_;
unless (exists $self->{json}) {
if (do { local $@; eval { require Cpanel::JSON::XS; Cpanel::JSON::XS->VERSION('4.09'); 1 } }) {
$self->{json} = Cpanel::JSON::XS->new->allow_dupkeys->stringify_infnan;
} else {
require JSON::PP;
$self->{json} = JSON::PP->new;
}
$self->{json}->utf8->canonical->allow_nonref->allow_unknown->allow_blessed->convert_blessed->escape_slash;
}
return $self->{json};
}
{
my @DAYS_OF_WEEK = qw(Sun Mon Tue Wed Thu Fri Sat);
my @MONTH_NAMES = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my %MONTH_NUMS;
@MONTH_NUMS{@MONTH_NAMES} = 0..11;
sub epoch_to_date {
my ($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime $_[0];
return sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT',
$DAYS_OF_WEEK[$wday], $mday, $MONTH_NAMES[$mon], $year + 1900, $hour, $min, $sec;
}
sub date_to_epoch {
# RFC 1123 (Sun, 06 Nov 1994 08:49:37 GMT)
my ($mday,$mon,$year,$hour,$min,$sec) = $_[0] =~ m/^ (?:Sun|Mon|Tue|Wed|Thu|Fri|Sat),
[ ] ([0-9]{2}) [ ] (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [ ] ([0-9]{4})
[ ] ([0-9]{2}) : ([0-9]{2}) : ([0-9]{2}) [ ] GMT $/x;
# RFC 850 (Sunday, 06-Nov-94 08:49:37 GMT)
($mday,$mon,$year,$hour,$min,$sec) = $_[0] =~ m/^ (?:Sun|Mon|Tues|Wednes|Thurs|Fri|Satur)day,
[ ] ([0-9]{2}) - (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) - ([0-9]{2})
[ ] ([0-9]{2}) : ([0-9]{2}) : ([0-9]{2}) [ ] GMT $/x unless defined $mday;
# asctime (Sun Nov 6 08:49:37 1994)
($mon,$mday,$hour,$min,$sec,$year) = $_[0] =~ m/^ (?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)
[ ] (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) [ ]{1,2} ([0-9]{1,2})
[ ] ([0-9]{2}) : ([0-9]{2}) : ([0-9]{2}) [ ] ([0-9]{4}) $/x unless defined $mday;
return undef unless defined $mday;
require Time::Local;
# 4 digit years interpreted literally, but may have leading zeroes
# 2 digit years interpreted with best effort heuristic
return scalar Time::Local::timegm($sec, $min, $hour, $mday, $MONTH_NUMS{$mon},
(length($year) == 4 && $year < 1900) ? $year - 1900 : $year);
}
}
{
my %ESCAPES = ('&' => '&', '<' => '<', '>' => '>', '"' => '"', '\'' => ''');
sub escape_html { (my $escaped = $_[0]) =~ s/([&<>"'])/$ESCAPES{$1}/ge; $escaped }
}
1;