view release on metacpan or  search on metacpan

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

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 };