package CGI::Simple; require 5.004; # this module is both strict (and warnings) compliant, but they are only used # in testing as they add an unnecessary compile time overhead in production. use strict; use warnings; use Carp; use vars qw( $VERSION $USE_CGI_PM_DEFAULTS $DISABLE_UPLOADS $POST_MAX $NO_UNDEF_PARAMS $USE_PARAM_SEMICOLONS $PARAM_UTF8 $HEADERS_ONCE $NPH $DEBUG $NO_NULL $FATAL *in ); $VERSION = "1.106"; # you can hard code the global variable settings here if you want. # warning - do not delete the unless defined $VAR part unless you # want to permanently remove the ability to change the variable. 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; } # I happen to disagree with many of the default global settings in CGI.pm # This sub is called if you set $CGI::Simple::USE_CGI_PM_GLOBALS = 1; or # invoke the '-default' pragma via a use CGI::Simple qw(-default); sub _use_cgi_pm_global_settings { $USE_CGI_PM_DEFAULTS = 1; $DISABLE_UPLOADS = 0 unless defined $DISABLE_UPLOADS; $POST_MAX = -1 unless defined $POST_MAX; $NO_UNDEF_PARAMS = 0 unless defined $NO_UNDEF_PARAMS; $USE_PARAM_SEMICOLONS = 1 unless defined $USE_PARAM_SEMICOLONS; $HEADERS_ONCE = 0 unless defined $HEADERS_ONCE; $NPH = 0 unless defined $NPH; $DEBUG = 1 unless defined $DEBUG; $NO_NULL = 0 unless defined $NO_NULL; $FATAL = -1 unless defined $FATAL; $PARAM_UTF8 = 0 unless defined $PARAM_UTF8; } # 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; } # use the automatic calling of the import sub to set our pragmas. CGI.pm compat sub import { my ( $self, @args ) = @_; # arguments supplied in the 'use CGI::Simple [ARGS];' will now be in @args foreach ( @args ) { $USE_CGI_PM_DEFAULTS = 1, next if m/^-default/i; $DISABLE_UPLOADS = 1, next if m/^-no.?upload/i; $DISABLE_UPLOADS = 0, next if m/^-upload/i; $HEADERS_ONCE = 1, next if m/^-unique.?header/i; $NPH = 1, next if m/^-nph/i; $DEBUG = 0, next if m/^-no.?debug/i; $DEBUG = defined $1 ? $1 : 2, next if m/^-debug(\d)?/i; $USE_PARAM_SEMICOLONS = 1, next if m/^-newstyle.?url/i; $USE_PARAM_SEMICOLONS = 0, next if m/^-oldstyle.?url/i; $NO_UNDEF_PARAMS = 1, next if m/^-no.?undef.?param/i; $FATAL = 0, next if m/^-carp/i; $FATAL = 1, next if m/^-croak/i; croak "Pragma '$_' is not defined in CGI::Simple\n"; } } # used in CGI.pm .t files sub _reset_globals { _use_cgi_pm_global_settings(); } binmode STDIN; binmode STDOUT; # 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; } if ( "\t" ne "\011" ) { eval { require CGI::Simple::Util }; if ( $@ ) { croak "Your server is using not using ASCII, you must install CGI::Simple::Util, error: $@"; } # hack the symbol table and replace simple encode/decode subs *CGI::Simple::url_encode = sub { CGI::Simple::Util::escape( $_[1] ) }; *CGI::Simple::url_decode = sub { CGI::Simple::Util::unescape( $_[1] ) }; } } ################ The Guts ################ sub new { my ( $class, $init ) = @_; $class = ref( $class ) || $class; my $self = {}; bless $self, $class; if ( $self->_mod_perl ) { if ( $init ) { $self->{'.mod_perl_request'} = $init; undef $init; # otherwise _initialize takes the wrong path } $self->_initialize_mod_perl(); } $self->_initialize_globals; $self->_store_globals; $self->_initialize( $init ); return $self; } sub _mod_perl { return ( exists $ENV{MOD_PERL} or ( $ENV{GATEWAY_INTERFACE} and $ENV{GATEWAY_INTERFACE} =~ m{^CGI-Perl/} ) ); } # Return the global request object under mod_perl. If you use mod_perl 2 # and you don't set PerlOptions +GlobalRequest then the request must be # passed in to the new() method. sub _mod_perl_request { my $self = shift; my $mp = $self->{'.mod_perl'}; return unless $mp; my $req = $self->{'.mod_perl_request'}; return $req if $req; $self->{'.mod_perl_request'} = do { if ( $mp == 2 ) { Apache2::RequestUtil->request; } else { Apache->request; } }; } sub _initialize_mod_perl { my ( $self ) = @_; eval "require mod_perl"; if ( defined $mod_perl::VERSION ) { if ( $mod_perl::VERSION >= 2.00 ) { $self->{'.mod_perl'} = 2; require Apache2::RequestRec; require Apache2::RequestIO; require Apache2::RequestUtil; require Apache2::Response; require APR::Pool; my $r = $self->_mod_perl_request(); if ( defined $r ) { $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; $r->pool->cleanup_register( \&CGI::Simple::_initialize_globals ); } } else { $self->{'.mod_perl'} = 1; require Apache; my $r = $self->_mod_perl_request(); if ( defined $r ) { $r->register_cleanup( \&CGI::Simple::_initialize_globals ); } } } } 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 _internal_read($\$;$) { my ( $self, $buffer, $len ) = @_; $len = 4096 if !defined $len; if ( $self->{'.mod_perl'} ) { my $r = $self->_mod_perl_request(); $r->read( $$buffer, $len ); } else { read( STDIN, $$buffer, $len ); } } 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 _parse_params { my ( $self, $data ) = @_; return () unless defined $data; unless ( $data =~ /[&=;]/ ) { $self->{'keywords'} = [ $self->_parse_keywordlist( $data ) ]; 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 ) ); } } 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 } sub _parse_keywordlist { my ( $self, $data ) = @_; return () unless defined $data; $data = $self->url_decode( $data ); $data =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'}; my @keywords = split /\s+/, $data; return @keywords; } sub _parse_multipart { my $self = shift; # TODO: See 14838. We /could/ have a heuristic here for the case # where no boundary is supplied. my ( $boundary ) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; unless ( $boundary ) { $self->cgi_error( '400 No boundary supplied for multipart/form-data' ); return 0; } # BUG: IE 3.01 on the Macintosh uses just the boundary, forgetting the -- $boundary = '--' . $boundary unless exists $ENV{'HTTP_USER_AGENT'} && $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+3\.0[12];\s*Mac/i; $boundary = quotemeta $boundary; my $got_data = 0; my $data = ''; my $length = $ENV{'CONTENT_LENGTH'} || 0; my $CRLF = $self->crlf; READ: while ( $got_data < $length ) { last READ unless _internal_read( $self, my $buffer ); $data .= $buffer; $got_data += length $buffer; BOUNDARY: while ( $data =~ m/^$boundary$CRLF/ ) { ## TAB and high ascii chars are definitivelly allowed in headers. ## Not accepting them in the following regex prevents the upload of ## files with filenames like "Espaņa.txt". # next READ unless $data =~ m/^([\040-\176$CRLF]+?$CRLF$CRLF)/o; next READ unless $data =~ m/^([\x20-\x7E\x80-\xFF\x09$CRLF]+?$CRLF$CRLF)/o; my $header = $1; ( my $unfold = $1 ) =~ s/$CRLF\s+/ /og; my ( $param ) = $unfold =~ m/form-data;\s+name="?([^\";]*)"?/; my ( $filename ) = $unfold =~ m/name="?\Q$param\E"?;\s+filename="?([^\"]*)"?/; if ( defined $filename ) { my ( $mime ) = $unfold =~ m/Content-Type:\s+([-\w\/]+)/io; $data =~ s/^\Q$header\E//; ( $got_data, $data, my $fh, my $size ) = $self->_save_tmpfile( $boundary, $filename, $got_data, $data ); $self->_add_param( $param, $filename ); $self->{'.upload_fields'}->{$param} = $filename; $self->{'.filehandles'}->{$filename} = $fh if $fh; $self->{'.tmpfiles'}->{$filename} = { 'size' => $size, 'mime' => $mime } if $size; next BOUNDARY; } next READ unless $data =~ s/^\Q$header\E(.*?)$CRLF(?=$boundary)//s; $self->_add_param( $param, $1 ); } unless ( $data =~ m/^$boundary/ ) { ## In a perfect world, $data should always begin with $boundary. ## But sometimes, IE5 prepends garbage boundaries into POST(ed) data. ## Then, $data does not start with $boundary and the previous block ## never gets executed. The following fix attempts to remove those ## extra boundaries from readed $data and restart boundary parsing. ## Note about performance: with well formed data, previous check is ## executed (generally) only once, when $data value is "$boundary--" ## at end of parsing. goto BOUNDARY if ( $data =~ s/.*?$CRLF(?=$boundary$CRLF)//s ); } } return $got_data; } sub _save_tmpfile { my ( $self, $boundary, $filename, $got_data, $data ) = @_; my $fh; my $CRLF = $self->crlf; my $length = $ENV{'CONTENT_LENGTH'} || 0; my $file_size = 0; if ( $self->{'.globals'}->{'DISABLE_UPLOADS'} ) { $self->cgi_error( "405 Not Allowed - File uploads are disabled" ); } elsif ( $filename ) { eval { require IO::File }; $self->cgi_error( "500 IO::File is not available $@" ) if $@; $fh = new_tmpfile IO::File; $self->cgi_error( "500 IO::File can't create new temp_file" ) unless $fh; } # read in data until closing boundary found. buffer to catch split boundary # we do this regardless of whether we save the file or not to read the file # data from STDIN. if either uploads are disabled or no file has been sent # $fh will be undef so only do file stuff if $fh is true using $fh && syntax $fh && binmode $fh; while ( $got_data < $length ) { my $buffer = $data; last unless _internal_read( $self, $data ); # fixed hanging bug if browser terminates upload part way through # thanks to Brandon Black unless ( $data ) { $self->cgi_error( '400 Malformed multipart, no terminating boundary' ); undef $fh; return $got_data; } $got_data += length $data; if ( "$buffer$data" =~ m/$boundary/ ) { $data = $buffer . $data; last; } # we do not have partial boundary so print to file if valid $fh $fh && print $fh $buffer; $file_size += length $buffer; } $data =~ s/^(.*?)$CRLF(?=$boundary)//s; $fh && print $fh $1; # print remainder of file if valid $fh $file_size += length $1; return $got_data, $data, $fh, $file_size; } # Define the CRLF sequence. You can't use a simple "\r\n" because of system # specific 'features'. On EBCDIC systems "\t" ne "\011" as the don't use ASCII sub crlf { my ( $self, $CRLF ) = @_; $self->{'.crlf'} = $CRLF if $CRLF; # allow value to be set manually unless ( $self->{'.crlf'} ) { my $OS = $^O || do { require Config; $Config::Config{'osname'} }; $self->{'.crlf'} = ( $OS =~ m/VMS/i ) ? "\n" : ( "\t" ne "\011" ) ? "\r\n" : "\015\012"; } return $self->{'.crlf'}; } ################ The Core Methods ################ 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]; } #1; ############### The following methods only loaded on demand ############### ############### Move commonly used methods above the __DATA__ ############### ############### token if you are into recreational optimization ############### ############### You can not use Selfloader and the __DATA__ ############### ############### token under mod_perl, so comment token out ############### #__DATA__ # a new method that provides access to a new internal routine. Useage: # $q->add_param( $param, $value, $overwrite ) # $param must be a plain scalar # $value may be either a scalar or an array ref # if $overwrite is a true value $param will be overwritten with new values. sub add_param { _add_param( @_ ); } sub param_fetch { my ( $self, $param, @p ) = @_; $param = ( defined $param and $param =~ m/^-name$/i ) ? $p[0] : $param; return undef unless defined $param; $self->_add_param( $param, [] ) unless exists $self->{$param}; return $self->{$param}; } # Return a parameter in the QUERY_STRING, regardless of whether a POST or GET sub url_param { my ( $self, $param ) = @_; return () unless $ENV{'QUERY_STRING'}; $self->{'.url_param'} = {}; bless $self->{'.url_param'}, 'CGI::Simple'; $self->{'.url_param'}->_parse_params( $ENV{'QUERY_STRING'} ); return $self->{'.url_param'}->param( $param ); } sub keywords { my ( $self, @values ) = @_; $self->{'keywords'} = ref $values[0] eq 'ARRAY' ? $values[0] : [@values] if @values; my @result = defined( $self->{'keywords'} ) ? @{ $self->{'keywords'} } : (); return @result; } sub Vars { my $self = shift; $self->{'.sep'} = shift || $self->{'.sep'} || "\0"; my ( %hash, %tied ); for my $param ( $self->param ) { $hash{$param} = join $self->{'.sep'}, $self->param( $param ); } tie %tied, "CGI::Simple", $self; return wantarray ? %hash : \%tied; } sub TIEHASH { $_[1] ? $_[1] : new $_[0] } sub STORE { my ( $q, $p, $v ) = @_; $q->param( $p, split $q->{'.sep'}, $v ); } sub FETCH { my ( $q, $p ) = @_; ref $q->{$p} eq "ARRAY" ? join $q->{'.sep'}, @{ $q->{$p} } : $q->{$p}; } sub FIRSTKEY { my $a = scalar keys %{ $_[0] }; each %{ $_[0] } } sub NEXTKEY { each %{ $_[0] } } sub EXISTS { exists $_[0]->{ $_[1] } } sub DELETE { $_[0]->delete( $_[1] ) } sub CLEAR { %{ $_[0] } = () } sub append { my ( $self, $param, @p ) = @_; return () unless defined $param; # set values using $q->append(-name=>'foo',-value=>'bar') syntax # also allows for $q->append( 'foo', 'some', 'new', 'values' ) syntax ( $param, undef, @p ) = @p if $param =~ m/^-name$/i; # undef represents -value token $self->_add_param( $param, ( ( defined $p[0] and ref $p[0] ) ? $p[0] : [@p] ) ); return $self->param( $param ); } sub delete { my ( $self, $param ) = @_; return () unless defined $param; $param = $param =~ m/^-name$/i ? shift : $param; # allow delete(-name=>'foo') syntax return undef unless defined $self->{$param}; delete $self->{$param}; delete $self->{'.fieldnames'}->{$param}; $self->{'.parameters'} = [ grep { $_ ne $param } @{ $self->{'.parameters'} } ]; } sub Delete { CGI::Simple::delete( @_ ) } # for method style interface sub delete_all { my $self = shift; undef %{$self}; $self->_store_globals; } sub Delete_all { $_[0]->delete_all } # as used by CGI.pm sub upload { my ( $self, $filename, $writefile ) = @_; unless ( $filename ) { $self->cgi_error( "No filename submitted for upload to $writefile" ) if $writefile; return $self->{'.filehandles'} ? keys %{ $self->{'.filehandles'} } : (); } unless ( $ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|i ) { $self->cgi_error( 'Oops! File uploads only work if you specify ENCTYPE="multipart/form-data" in your