Path: blob/main/website/content/en/cgi/MyCgiSimple.pm
18093 views
# This module is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself. See https://metacpan.org/pod/perlartistic
#
# MyCgiSimple.pm - striped down version of CGI::Simple;
package MyCgiSimple;
sub charset {
return 'utf-8';
}
sub param {
my ( $self, $param, @p ) = @_;
unless ( defined $param ) { # return list of all params
my @params = $self->{'.parameters'} ? @{ $self->{'.parameters'} } : ();
return @params;
}
unless (@p) { # return values for $param
return () unless exists $self->{$param};
return wantarray ? @{ $self->{$param} } : $self->{$param}->[0];
}
if ( $param =~ m/^-name$/i and @p == 1 ) {
return () unless exists $self->{ $p[0] };
return wantarray ? @{ $self->{ $p[0] } } : $self->{ $p[0] }->[0];
}
# set values using -name=>'foo',-value=>'bar' syntax.
# also allows for $q->param( 'foo', 'some', 'new', 'values' ) syntax
( $param, undef, @p ) = @p
if $param =~ m/^-name$/i; # undef represents -value token
$self->_add_param( $param, ( ref $p[0] eq 'ARRAY' ? $p[0] : [@p] ),
'overwrite' );
return wantarray ? @{ $self->{$param} } : $self->{$param}->[0];
}
sub new {
my ( $class, $init ) = @_;
$class = ref($class) || $class;
my $self = {};
bless $self, $class;
$self->_initialize_globals;
$self->_store_globals;
$self->_initialize($init);
return $self;
}
sub path_info {
my ( $self, $info ) = @_;
if ( defined $info ) {
$info = "/$info" if $info !~ m|^/|;
$self->{'.path_info'} = $info;
}
elsif ( !defined( $self->{'.path_info'} ) ) {
$self->{'.path_info'} =
defined( $ENV{'PATH_INFO'} ) ? $ENV{'PATH_INFO'} : '';
# hack to fix broken path info in IIS source CGI.pm
$self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E//
if defined( $ENV{'SERVER_SOFTWARE'} )
&& $ENV{'SERVER_SOFTWARE'} =~ /IIS/;
}
return $self->{'.path_info'};
}
sub _initialize {
my ( $self, $init ) = @_;
if ( !defined $init ) {
# initialize from QUERY_STRING, STDIN or @ARGV
$self->_read_parse();
}
elsif ( ( ref $init ) =~ m/HASH/i ) {
# initialize from param hash
for my $param ( keys %{$init} ) {
$self->_add_param( $param, $init->{$param} );
}
}
# chromatic's blessed GLOB patch
# elsif ( (ref $init) =~ m/GLOB/i ) { # initialize from a file
elsif ( UNIVERSAL::isa( $init, 'GLOB' ) ) { # initialize from a file
$self->_init_from_file($init);
}
elsif ( ( ref $init ) eq 'CGI::Simple' ) {
# initialize from a CGI::Simple object
require Data::Dumper;
# avoid problems with strict when Data::Dumper returns $VAR1
my $VAR1;
my $clone = eval( Data::Dumper::Dumper($init) );
if ($@) {
$self->cgi_error("Can't clone CGI::Simple object: $@");
}
else {
$_[0] = $clone;
}
}
else {
$self->_parse_params($init); # initialize from a query string
}
}
sub _initialize_globals {
# set this to 1 to use CGI.pm default global settings
$USE_CGI_PM_DEFAULTS = 0
unless defined $USE_CGI_PM_DEFAULTS;
# see if user wants old CGI.pm defaults
if ($USE_CGI_PM_DEFAULTS) {
_use_cgi_pm_global_settings();
return;
}
# no file uploads by default, set to 0 to enable uploads
$DISABLE_UPLOADS = 1
unless defined $DISABLE_UPLOADS;
# use a post max of 100K, set to -1 for no limits
$POST_MAX = 102_400
unless defined $POST_MAX;
# set to 1 to not include undefined params parsed from query string
$NO_UNDEF_PARAMS = 0
unless defined $NO_UNDEF_PARAMS;
# separate the name=value pairs with ; rather than &
$USE_PARAM_SEMICOLONS = 0
unless defined $USE_PARAM_SEMICOLONS;
# return everything as utf-8
$PARAM_UTF8 ||= 0;
$PARAM_UTF8 and require Encode;
# only print headers once
$HEADERS_ONCE = 0
unless defined $HEADERS_ONCE;
# Set this to 1 to enable NPH scripts
$NPH = 0
unless defined $NPH;
# 0 => no debug, 1 => from @ARGV, 2 => from STDIN
$DEBUG = 0
unless defined $DEBUG;
# filter out null bytes in param - value pairs
$NO_NULL = 1
unless defined $NO_NULL;
# set behavior when cgi_err() called -1 => silent, 0 => carp, 1 => croak
$FATAL = -1
unless defined $FATAL;
}
# this is called by new, we will never directly reference the globals again
sub _store_globals {
my $self = shift;
$self->{'.globals'}->{'DISABLE_UPLOADS'} = $DISABLE_UPLOADS;
$self->{'.globals'}->{'POST_MAX'} = $POST_MAX;
$self->{'.globals'}->{'NO_UNDEF_PARAMS'} = $NO_UNDEF_PARAMS;
$self->{'.globals'}->{'USE_PARAM_SEMICOLONS'} = $USE_PARAM_SEMICOLONS;
$self->{'.globals'}->{'HEADERS_ONCE'} = $HEADERS_ONCE;
$self->{'.globals'}->{'NPH'} = $NPH;
$self->{'.globals'}->{'DEBUG'} = $DEBUG;
$self->{'.globals'}->{'NO_NULL'} = $NO_NULL;
$self->{'.globals'}->{'FATAL'} = $FATAL;
$self->{'.globals'}->{'USE_CGI_PM_DEFAULTS'} = $USE_CGI_PM_DEFAULTS;
$self->{'.globals'}->{'PARAM_UTF8'} = $PARAM_UTF8;
}
sub _read_parse {
my $self = shift;
my $data = '';
my $type = $ENV{'CONTENT_TYPE'} || 'No CONTENT_TYPE received';
my $length = $ENV{'CONTENT_LENGTH'} || 0;
my $method = $ENV{'REQUEST_METHOD'} || 'No REQUEST_METHOD received';
# first check POST_MAX Steve Purkis pointed out the previous bug
if ( ( $method eq 'POST' or $method eq "PUT" )
and $self->{'.globals'}->{'POST_MAX'} != -1
and $length > $self->{'.globals'}->{'POST_MAX'} )
{
$self->cgi_error(
"413 Request entity too large: $length bytes on STDIN exceeds \$POST_MAX!"
);
# silently discard data ??? better to just close the socket ???
while ( $length > 0 ) {
last unless _internal_read( $self, my $buffer );
$length -= length($buffer);
}
return;
}
if ( $length and $type =~ m|^multipart/form-data|i ) {
my $got_length = $self->_parse_multipart;
if ( $length != $got_length ) {
$self->cgi_error(
"500 Bad read on multipart/form-data! wanted $length, got $got_length"
);
}
return;
}
elsif ( $method eq 'POST' or $method eq 'PUT' ) {
if ($length) {
# we may not get all the data we want with a single read on large
# POSTs as it may not be here yet! Credit Jason Luther for patch
# CGI.pm < 2.99 suffers from same bug
_internal_read( $self, $data, $length );
while ( length($data) < $length ) {
last unless _internal_read( $self, my $buffer );
$data .= $buffer;
}
unless ( $length == length $data ) {
$self->cgi_error( "500 Bad read on POST! wanted $length, got "
. length($data) );
return;
}
if ( $type !~ m|^application/x-www-form-urlencoded| ) {
$self->_add_param( $method . "DATA", $data );
}
else {
$self->_parse_params($data);
}
}
}
elsif ( $method eq 'GET' or $method eq 'HEAD' ) {
$data =
$self->{'.mod_perl'}
? $self->_mod_perl_request()->args()
: $ENV{'QUERY_STRING'}
|| $ENV{'REDIRECT_QUERY_STRING'}
|| '';
$self->_parse_params($data);
}
else {
unless ($self->{'.globals'}->{'DEBUG'}
and $data = $self->read_from_cmdline() )
{
$self->cgi_error("400 Unknown method $method");
return;
}
unless ($data) {
# I liked this reporting but CGI.pm does not behave like this so
# out it goes......
# $self->cgi_error("400 No data received via method: $method, type: $type");
return;
}
$self->_parse_params($data);
}
}
sub cgi_error {
my ( $self, $err ) = @_;
if ($err) {
require Carp;
$self->{'.cgi_error'} = $err;
$self->{'.globals'}->{'FATAL'} == 1 ? croak $err
: $self->{'.globals'}->{'FATAL'} == 0 ? carp $err
: return $err;
}
return $self->{'.cgi_error'};
}
# This internal routine creates date strings suitable for use in
# cookies and HTTP headers. (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
sub expires {
my ( $time, $format ) = @_;
$format ||= 'http';
my (@MON) = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my (@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
# pass through preformatted dates for the sake of expire_calc()
$time = expire_calc($time);
return $time unless $time =~ /^\d+$/;
# make HTTP/cookie date string from GMT'ed time
# (cookies use '-' as date separator, HTTP uses ' ')
my ($sc) = ' ';
$sc = '-' if $format eq "cookie";
my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($time);
$year += 1900;
return sprintf( "%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
$WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec );
}
# This internal routine creates an expires time exactly some number of
# hours from the current time. It incorporates modifications from
# Mark Fisher.
sub expire_calc {
my ($time) = @_;
my (%mult) = (
's' => 1,
'm' => 60,
'h' => 60 * 60,
'd' => 60 * 60 * 24,
'M' => 60 * 60 * 24 * 30,
'y' => 60 * 60 * 24 * 365
);
# format for time can be in any of the forms...
# "now" -- expire immediately
# "+180s" -- in 180 seconds
# "+2m" -- in 2 minutes
# "+12h" -- in 12 hours
# "+1d" -- in 1 day
# "+3M" -- in 3 months
# "+2y" -- in 2 years
# "-3m" -- 3 minutes ago(!)
# If you don't supply one of these forms, we assume you are
# specifying the date yourself
my ($offset);
if ( !$time || ( lc($time) eq 'now' ) ) {
$offset = 0;
}
elsif ( $time =~ /^\d+/ ) {
return $time;
}
elsif ( $time =~ /^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/ ) {
$offset = ( $mult{$2} || 1 ) * $1;
}
else {
return $time;
}
return ( time + $offset );
}
sub header {
my $self = shift;
my %args = @_;
my $type = $args{-type};
my $charset = $args{-charset};
my $expires = $args{-expires};
push( @header, "Expires: " . expires( $expires, 'http' ) )
if $expires;
push( @header, "Date: " . expires( 0, 'http' ) ) if $expires;
if ( $type && $charset ) {
$type .= '; charset=' . $charset;
}
push @header, "Content-Type: $type" if $type;
return join( "\n", @header ), "\n\n";
}
sub _parse_params {
my ( $self, $data ) = @_;
return () unless defined $data;
unless ( $data =~ /[&=;]/ ) {
#$self->{'keywords'} = [ $self->_parse_keywordlist( $data ) ];
$self->{'keywords'} = [];
return;
}
my @pairs = split /[&;]/, $data;
for my $pair (@pairs) {
my ( $param, $value ) = split /=/, $pair, 2;
next unless defined $param;
$value = '' unless defined $value;
$self->_add_param( $self->url_decode($param),
$self->url_decode($value) );
}
}
# use correct encoding conversion to handle non ASCII char sets.
# we import and install the complex routines only if we have to.
BEGIN {
sub url_decode {
my ( $self, $decode ) = @_;
return () unless defined $decode;
$decode =~ tr/+/ /;
$decode =~ s/%([a-fA-F0-9]{2})/ pack "C", hex $1 /eg;
return $decode;
}
sub url_encode {
my ( $self, $encode ) = @_;
return () unless defined $encode;
$encode =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
$encode =~ tr/ /+/;
return $encode;
}
}
sub _add_param {
my ( $self, $param, $value, $overwrite ) = @_;
return () unless defined $param and defined $value;
$param =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
@{ $self->{$param} } = () if $overwrite;
@{ $self->{$param} } = () unless exists $self->{$param};
my @values = ref $value ? @{$value} : ($value);
for my $value (@values) {
next
if $value eq ''
and $self->{'.globals'}->{'NO_UNDEF_PARAMS'};
$value =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
$value = Encode::decode( utf8 => $value )
if $self->{'.globals'}->{PARAM_UTF8};
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
}
# from CGI::Simple 1.115
sub script_name { $ENV{'SCRIPT_NAME'} || $0 || '' }
sub server_name { $ENV{'SERVER_NAME'} || 'localhost' }
1;