#!/usr/bin/perl -w
require 5.004;
use strict;
use CGI;
use File::Basename;
use HTML::TokeParser;
my $doc = shift or &usage;
my $basename = basename( $doc );
$basename =~ s/\..*$//;
my $p = HTML::TokeParser->new($doc) || die "Can't open: $!";
my $formnum = 1;
######--------------------------------------######
# Begin user config section #
######--------------------------------------######
# The following variables should be set by the user to control
+
# the output of the code generator
#
# The only thing you *need* to set it the shebang line. The other opt
+ions
# are just for configuration.
#
# The following variable MUST only containt letters, numbers, or under
+scores:
# qw/ $taint_pfx $cgi_obj $err_var $err_sub $log_sub /
# If you slip up, the script will die rather than produce bad code.
# This is the prefix of all variables that need to be untainted.
# should be letters, numbers, or underscores.
my $taint_pfx = 'tainted_';
# set this to false to have OO cgi code written out.
my $cgi_std = 0;
# if $cgi_std is set to false, use this to specify the variable
# name of the CGI object (e.g. 'q' becomes 'my $q = CGI->new;')
my $cgi_obj = 'q';
# This is the shebang line that will be used.
# If left blank, it will be skipped.
my $shebang = '#!/usr/bin/perl -wT';
# use this for the name of the hash that contains the errors
my $err_var = 'errors';
# set this to true to have the program print the &error stub
my $print_err = 1;
# set this to the name of your error handling routine
my $err_sub = 'error';
# if $err_sub is true, this will be the stub of your security
# log routine. If the form has been tampered with (i.e. data
# in @safe_types does not untaint), the use this to log the info.
my $log_sub = 'sec_log';
# set this to true for lower case variable names
# If your forms elements that have the same name except
# for case, this could cause problems.
my $lc_names = 1;
######--------------------------------------######
# End user config section #
######--------------------------------------######
# These are the form elements for which we can *safely* create regular
+ expressions
# for untainting. Do not change this array unless you know what you a
+re doing.
my @safe_types = qw/ hidden checkbox radio select submit /;
my %element; # holds all of the form element types, names, and v
+alues
my %select; # holds select form elements so we know if we've se
+en them
my @element_order; # order that elements appear in the form. It's not
+ really
# needed, but we do this so that variables in gener
+ated code
# appear roughly in the same order as the form.
my $select_token; # holds the select token when parsing <select> valu
+es
# walk through document and get each tag
# we're building a list of form elements here
while (my $token = $p->get_tag) {
my $tag = $token->[0];
if ( my $form_pos = ( $tag eq 'form' .. $tag eq '/form' ) ) {
# Oh! We're in a form. Start looking for stuff.
if ( $form_pos != 1 and substr( $form_pos, -2 ) ne 'E0' ) {
add_input_element( $token ) if $tag eq 'input';
# <select> is a pain, so we need to handle it differently
if ( my $select_pos = ( $tag eq 'select' .. $tag eq '/sele
+ct' ) ) {
$select_token = $token if $tag eq 'select';
if ( $select_pos != 1 and substr( $select_pos, -2 ) ne
+ 'E0' ) {
add_select_element( $token, $p, $select_token ) if
+ $tag eq 'option';
} elsif ( substr( $select_pos, -2 ) eq 'E0' ) {
# we've finished the <select>, so add it to
# %select so we knows we've seen it.
$select{ $select_token->[1]->{ 'name' } } = '';
}
} # end if (select)
foreach ( qw/ textarea button / ) {
add_generic_element( $token ) if $tag eq $_;
}
} elsif ( substr( $form_pos, -2 ) eq 'E0' ) {
# we've finished the form, so let's write the document, cl
+ear the vars,
# and start looking for more forms.
&write_template;
%element = ();
@element_order = ();
$formnum++;
}
} # end if (form)
}
# This is to extract necessary data from form element
# that will later be added to %element
sub add_generic_element {
my $token = shift;
my $tag = $token->[0];
my $name = $token->[1]->{ 'name' } || '';
my $value = $token->[1]->{ 'value' } || '';
# I don't want to pass 'text' defaults as they can often be huge
if ( $tag eq 'textarea' ) {
$value = '';
}
update_element_hash( $name, $tag, $value, 1 );
}
# <select> needs to be handled different.
sub add_select_element {
my ( $token, $p, $select_token ) = @_;
my $name = $select_token->[1]->{ 'name' } || '';
my $value = $token->[1]->{ 'value' } || '';
# The following is because an <option> with a select will
# assume the value of the text if no value is specified
if ( ! $value ) {
$value = $p->get_trimmed_text;
}
# If <select> has the 'multiple' attribute or we've previously
# encountered a <select> with the same name, set multiple to true
my $multiple = exists $select_token->[1]->{ 'multiple' } ? 1 :
exists $select{ $name } ? 1 :
0 ;
update_element_hash( $name, 'select', $value, $multiple );
}
# Need to format the data from the input element
sub add_input_element {
my $token = shift;
my $type = $token->[1]->{ 'type' } || '';
my $name = $token->[1]->{ 'name' } || '';
my $value = $token->[1]->{ 'value' } || '';
my $multiple = $type eq 'radio' ? 0 : 1;
update_element_hash( $name, $type, $value, $multiple );
}
# here's where the formatted form element data is actually added
# to the element hash.
sub update_element_hash {
my ( $name, $type, $value, $multiple ) = @_;
return if $type eq 'reset'; # This only affects the form, not the
+script
$value =~ s/\n/\\n/g;
if ( $name ) {
if ( ! exists $element{ $name } ) {
$element{ $name }{ 'multiple' } = 0;
$element{ $name }{ 'type' } = $type;
$element{ $name }{ 'value' } = $value ? [ $value ] : []
+;
push @element_order, $name;
} else {
$element{ $name }{ 'multiple' } += $multiple;
push @{ $element{ $name }{ 'value' } }, $value if $value;
}
}
}
# Duh!
sub usage {
print <<" END_HERE";
Usage: formparse.pl some.html
END_HERE
exit;
}
# Oh, goody! We actually get to start writing the code :)
sub write_template {
my $filename = "${basename}_form_${formnum}.cgi";
my $cgi_var = $cgi_std ? '' : "\$${cgi_obj}->";
my $cgi_line = 'use CGI';
$cgi_line .= $cgi_std ? " qw/:standard/;\n" : ";\n";
my $max_var_length = 1;
foreach ( keys %element ) {
$max_var_length = length if length > $max_var_length;
}
open OUT, "> $filename" or die "Can't open $filename for writing:
+$!";
print OUT $shebang."\n" if $shebang;
print OUT &template;
print OUT "use strict;\n";
print OUT $cgi_line;
if ( ! $cgi_std ) {
print OUT "my \$$cgi_obj = CGI->new;\n";
}
print OUT "my \%$err_var;\n";
print OUT "\n# Grab all data\n";
# Here's where we print param() calls
foreach my $element ( @element_order ) {
my $var_name = get_var_name( $element );
my $data_type = $element{ $element }{ 'multiple' } ? '@' : '$
+';
my $default = $element{ $element }{ 'multiple' } ? '()' : "'
+'";
print OUT qq/my ${data_type}${taint_pfx}${var_name} / .
' ' x ( $max_var_length - length $var_name ) .
qq/= ${cgi_var}param( '$element' )/ .
' ' x ( $max_var_length - length $var_name ) .
qq/ || $default; # $element{ $element }{ 'type' }\n/
+;
}
print OUT <<" END_HERE";
# The following is just a rough "fill in" template for untainting your
+ data.
# It will need to be customized to suit your particular needs. You'll
+ need
# to create regular expressions to untaint your data and if you skimp
+on this,
# it's at your peril!!!
END_HERE
# here's where we print the untainting template
foreach my $element ( @element_order ) {
my $var_name = get_var_name( $element );
my $type = $element{ $element }{ 'type' };
my $multiple = $element{ $element }{ 'multiple' };
if ( $multiple ) {
# Ooh, multiple values. Need to untaint an array.
print OUT qq!my \@${var_name}; # $type values: ! . join( "
+,", @{ $element{ $element }{ 'value' } } ) . "\n";
print OUT "foreach ( 0 .. \$#${taint_pfx}${var_name} ) {\n
+".
qq! ( \$${var_name}\[\$_] ) ! .
untainting_code( $element, $var_name, $multiple, $ty
+pe, '[$_]' ) .
"}\n\n";
} else {
# Untainting a scalar.
print OUT qq!# $type values: ! . join( ",", @{ $element{ $
+element }{ 'value' } } ) . "\n";
print OUT qq!my ( \$${var_name} ) ! .
untainting_code( $element, $var_name, $multiple,
+ $type, '' ) . "\n";
}
}
print OUT err_stub() if $print_err;
close OUT or die "Can't close $filename: $!";
}
# return the code that will actually go in the untainting routine
sub untainting_code {
my ( $element, $var_name, $multiple, $type, $index ) = @_;
my $var_prefix = $multiple ? '@' : '$';
return qq!= ( ! . untainting_regexes( $element, $var_name, $multip
+le ) . " )\n" .
qq! or \$${err_var}\{ '$var_name' } = [ "$type", \\$
+{var_prefix}${taint_pfx}${var_name}, "You must supply a proper value
+for '$var_name'. Allowed characters are letters, numbers, or punctua
+tion." ];\n!;
}
# need to create the regexes for untainting.
sub untainting_regexes {
my ( $element, $var_name, $multiple ) = @_;
my $type = $element{ $element }{ 'type' };
my $code;
# Can't create a safe regex, so we insert code to kill the script
+unless
# the programmer creates his or her own regex
$code = '"" ), die # could not auto-create regex # ';
return $code if ! grep { /$type/ } @safe_types;
my @values = @{ $element{ $element }{ 'value' } };
@values = return_unique_items( @values ) if @values;
if ( scalar @values > 1 ) {
my ( $all_length_of_one, $formatted_values ) = escape_values(
+\@values );
my $array_index = $multiple ? '[$_]' : '';
if ( $all_length_of_one ) {
# we're returning a character class
$code = qq!\$${taint_pfx}${var_name}$array_index =~ /^(! .
+ '['. join( '', @$formatted_values ) .'])$/';
} else {
# we have multiple values that a character class is not su
+itable for,
# so we return separate regex tests for each value
#my $offset = $multiple ? length( $taint_pfx ) + 17 : leng
+th( $taint_pfx ) + 12;
my $offset = $multiple ? 18 : 13;
$code = qq!\$${taint_pfx}${var_name}$array_index =~ /^(! .
+ $$formatted_values[0] . ")\$/ or \n";
for ( 1 .. scalar @$formatted_values - 1 ) {
$code .= ' ' x ( $offset + length $var_name );
$code .= qq!\$${taint_pfx}${var_name}$array_index =~ /
+^(! . $values[$_] . ")\$/";
$code .= " or \n" if $_ < scalar @$formatted_values -
+1;
}
}
} else {
$code = qq!\$${taint_pfx}${var_name} =~ /^(! . quotemeta( $val
+ues[0] ) . ')$/';
}
return $code;
}
###############################################################
# if you want to maintain this, please note that this appears #
# to have subs within subs. Look closer: HERE docs. Rather #
# tricky. #
###############################################################
sub err_stub {
my $code =<<END_CODE;
$err_sub( \\\%$err_var ) if \%$err_var;
sub $err_sub {
my \$err_hash = shift;
# \$err_hash is a reference to an anoymous hash. Keys are form at
+tribute names and values
# are an anonymous array: [ element type, value, error_message ]
# Example:
# \$err_hash = {
# 'username' => [ 'text', '????', "You must supply a proper
+value for 'username'..." ]
# }
# Might be generated from: <input type="text" name="username">
END_CODE
$code .= " my \@safe_elements = qw/ ";
foreach ( @safe_types ) {
$code .= "$_ " if $_ ne 'checkbox'; # skip checkbox as it's po
+ssible for no data to be sent
}
$code .= "/;\n";
$code .=<<'END_CODE';
foreach my $key ( keys %$err_hash ) {
if ( grep { /$$err_hash{ $key }->[0]/ } @safe_elements ) {
# The value of an element whose value shouldn't change app
+ears to be wrong
sec_log( $$err_hash{ $key }, $key );
} else {
# insert error handling code here
}
}
}
END_CODE
$code .= "sub $log_sub {\n";
$code .=<<'END_CODE';
my ( $bad_data, $element_name ) = @_;
# $bad_data is a reference to an anoymous array.
# [ element type, value, error_message ]
# Example: [ 'text', '%#$!#$', "You must supply a proper value for
+ 'username'..." ]
# Might be generated from: <input type="text" name="username">
}
END_CODE
}
##########################
# End 'HERE' doc section #
##########################
# return a safe variable name based upon the element name
sub get_var_name {
my $var_name = shift;
$var_name = lc $var_name if $lc_names;
$var_name =~ s/\W/_/g; # nice and safe variable names
return $var_name;
}
# escape data for created regexes
sub escape_values {
# if all values are only one character in length, we'll escape cha
+racters
# with special meaning in a character class. Otherwise, we'll esc
+ape all
# non-word characters.
my $values = shift;
my $all_length_of_one = 1;
foreach ( @$values ) {
$all_length_of_one = 0, last if length > 1;
}
if ( $all_length_of_one ) {
# We don't want a negated character class!
if ( $$values[0] eq '^' ) {
$$values[0] = '\^';
}
for ( 1 .. scalar @$values - 1 ) {
# quote ']', '\', and '-' in character class
if ( $$values[ $_ ] =~ /[\]\\\-]/ ) {
$$values[ $_ ] = '\\' . $$values[ $_ ];
}
}
} else {
@$values = map { quotemeta( $_ ) } @$values if @$values;
}
return ( $all_length_of_one, $values );
}
# remove duplicates from array
sub return_unique_items {
my %seen;
grep { ! $seen{ $_ }++ } @_;
}
# This is the 'comment' template written at the top of the code
sub template {
my ( $day, $month, $year ) = (localtime)[3..5];
$year += 1900;
my @months = qw/January February March April May June
July August September October November Decemb
+er/;
return <<END_HERE;
#
# Program:
# Author:
# Date Created:
# Purpose:
#
# Inputs:
#
# Outputs:
#
# --------------- Maintenance log ------------------------
# Date: $months[ $month ] $day, $year
# Programmer: parse_form.pl
# Action: automatic code generation template
# --------------------------------------------------------
# Date:
# Programmer:
# Action:
# --------------------------------------------------------
END_HERE
}
# If the user config information is bad, kill the script rather than w
+rite bad code
sub validate {
unless( $taint_pfx =~ /^\w+$/ ) { bad_config( '$taint_pfx' ) };
unless( $cgi_obj =~ /^\w+$/ ) { bad_config( '$cgi_obj' ) };
unless( $err_var =~ /^\w+$/ ) { bad_config( '$err_var' ) };
unless( $err_sub =~ /^\w+$/ ) { bad_config( '$err_sub' ) };
unless( $log_sub =~ /^\w+$/ ) { bad_config( '$log_sub' ) };
if ( $HTML::Parser::VERSION < 3.25 ) {
warn "\n You have HTML::Parser version $HTML::Parser::VERSI
+ON, which is out of date.\n".
" XHTML may not parse correctly\n".
" If you cannot upgrade \$HTML::Parser, you will need
+to carefully double-check\n".
" that all form elements have been included.";
}
}
# This is where the script is actually killed
sub bad_config {
my $config_var = shift;
die "$config_var must only containt letters, numbers, or underscor
+es:\n\t".
"$config_var =~ /^\\w+\$/ or die;";
}
__END__
=head1 NAME
parse_form.pl Quick and easy form handling code
=head1 USAGE
parse_form.pl some.html
=head1 DESCRIPTION
One of the most tedious tasks of writing CGI scripts is creating the f
+orm handling routines.
The larger the form, the more tedious this can be. Typically, this is
+ a series of 'param'
calls followed by a bunch of rather boring untainting expressions. Th
+is program will read
an HTML document and produce a series of files, one per form in the sc
+ript.
Each file will be the beginnings of the CGI script used to process eac
+h form in the HTML
document. Each file has several logical sections:
=over 4
=item Shebang Line
The programmer sets the C<$shebang> variable to point to the Perl inte
+rpreter and add
necessary switches:
my $shebang = '/usr/bin/perl -wT';
If C<$shebang> is set to a false value (e.g., the empty string), then
+the shebang line will
not be included.
=item Header Template
The C<&template> subroutine should be altered to fit the programmer's
+shop standards. This
template is a series of comments added to the beginning of the output
+files, after the
shebang line, which identify the programmer, author, purpose of the pr
+ogram, etc.
=item C<use> Statements
After the template, it is assumed the the programmer will C<use strict
+> and C<use CGI>.
If the programmer sets the C<$cgi_std> variable to false, then this se
+ction will be:
use strict;
use CGI;
my $q = CGI->new;
The variable name for the CGI object is set with the C<$cgi_obj> varia
+ble.
=item Grabbing Form Data
The next section will be a series of C<CGI::param> calls. These will
+grab in all data from
the CGI form the variable name set to whatever value is assigned to C<
+$taint_pfx> followed
by the C<name> attribute in each CGI element. To ensure that safe var
+iable names are created,
the C<name> attribute will be parsed through the following regex:
$var_name = s/\W/_/g;
Here is an example of a text field and the resulting C<param> call (as
+sumes using the
function-oriented version of CGI.pm:
<input type="text" name="first name">
my $_first_name = param( 'first name' ); # text
Note the the type of form element generating the data is appended as a
+ comment. If
C<parse_form.pl> determines that more than one value could be for a pa
+rticular name,
it will use an array instead of a scalar:
<select name="sports" multiple>
<option>Football
<option>Basketball</option>
<option>Other
</select>
my @_sports = param( 'sports' ); # select
Note that the HTML is sloppy. "Basketball" has a closing E<lt>/option
+E<gt>, while the
other options do not. C<parse_form.pl> does not care.
=item Untainting the data
Untainting the form data is perhaps one of the most onerous tasks and
+it's an easy one
to skip (whether through false laziness or genuine oversight). C<pars
+e_for.pl> creates
a series of stub untainting methods. These B<are not fully functional
+>!!! Blindly
untainting data is foolish. Instead, we create generic routines that
+the programmer will
need to complete. However, for certain types of form elements, the fo
+rm data should be
relatively simple to untaint. These are elements for which the data i
+s already specified
and should not change:
=over 4
=item *
hidden
=item *
checkbox
=item *
radio
=item *
select
=item *
submit
=back
For these five items, the program will read the default values and cre
+ate a regular expression
to match this data. If the default values are all single character, i
+t will use a character class
to match the data. Otherwise, it will use alternation. For the C<@_s
+ports> example above, the
following untainting code will be created:
my @sports; # select values: Football,Basketball,Other
foreach ( 0 .. $#_sports ) {
( $sports[$_] ) = ( $_sports[$_] =~ /^(Football)$/ or
$_sports[$_] =~ /^(Basketball)$/ or
$_sports[$_] =~ /^(Other)$/ )
or push @{ $errors{ 'sports' } }, "You must supply a proper v
+alue for 'sports'. Allowed characters are letters, numbers, or punct
+uation.";
}
The first line is a comment listing the type of form element and any d
+efault values that were
provided by the form and a declaration of the variable to hold the unt
+ainted data. The subsequent
lines represent the untainting code that's generated..
If you prefer, you could use alternation for the regex:
( $sports[$_] ) = ( $_sports[$_] =~ /^(Football|Basketball|Other)
+$/ )
I have elected not to do this as alternation is much less efficient.
+If you have many values,
particularly with larger forms, this could have a a significant impact
+ on your script's performance.
For simple alternation, however, you I<probably> wouldn't notice much
+of a speed difference.
It is recommended, however, that you go through the regular expression
+s manually and optimize them.
The untainting code for days of the month might be something like:
my ( $user_datesuse2_day ) = ( $tainted_user_datesuse_day =~ /^(01)$/
+ or
$tainted_user_datesuse_day =~ /^(02)$/
+ or
$tainted_user_datesuse_day =~ /^(03)$/
+ or
...
$tainted_user_datesuse_day =~ /^(31)$/
+ )
Needless to say, that's a waste! A quick optimization produces someth
+ing like:
my ( $user_datesuse_day ) = ( $tainted_user_datesuse_day =~ /^([0-2]\
+d|3[01])$/ )
For form elements other than the five listed above, the code will be s
+lightly different. This is
to force the programmer to actually go through and add all of these re
+gexes. In the C<$_first_name>
example above, the following untainting code will be created:
# text values:
my ( $first_name ) = ( "" ), die # could not auto-create regex # )
What this does is set C<$first_name> to the empty string and kill the
+script. This is to force the
programmer to create the regex manually. Also, with large forms, it e
+nsures that you are less likely
to overlook the untainting.
=back
=head1 User Configuration
No point in having auto-generated code unless you have some control of
+ the output. At the beginning
of the program is a 'user config' section. The following variables ca
+n be changed by the user to
affect the output of the script.
=over 4
=item C<$taint_pfx>
This is the prefix of all variables that need to be untainted. Must m
+atch /^\w+$/
my $taint_pfx = 'tainted_';
=item C<$cgi_std>
Set this to false to have OO cgi code written out.
my $cgi_std = 0;
=item C<$cgi_obj>
If C<$cgi_std> is set to false, use this to specify the variable name
+of the CGI object
(e.g. 'q' becomes C<my $q = CGI->new;>). Must match /^\w+$/
my $cgi_obj = 'q';
=item C<$shebang>
This is the shebang line that will be used. If left blank, it will b
+e skipped.
my $shebang = '#!/usr/bin/perl -wT';
=item C<$err_var>
Use this for the name of the hash that will contain the errors generat
+ed by scalars that
do not untaint. Must match /^\w+$/
my $err_var = 'errors';
=item C<$print_err>
Set this to true to have the program print the C<&error> stub.
my $print_err = 1;
=item C<$err_sub>
Set this to the name of your error handling routine. Must match /^\w+
+$/
my $err_sub = 'error';
=item C<$log_sub>
If C<$err_sub> is true, this will be the stub of your security log rou
+tine. If the form has
been tampered with (i.e. data in C<@safe_types> does not untaint), the
+ use this to log the info.
Must match /^\w+$/
my $log_sub = 'sec_log';
=item C<$lc_names>
Set this to true for lower case variable names. If your forms element
+s that have the same name
except for case, this could cause problems.
my $lc_names = 1;
=back
=head1 Sample Input and Output
=head2 Input: HTML document named test.html
Note the the following document has very poorly-formed HTML. Not all
+element attributes are quoted.
The case varies on input elements and whether or not a closing E<lt>/o
+ptionE<gt> tag has been used
varies.
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html>
<head>
<title>This is for a form parsing test</title>
</head>
<body>
<p>I don't think anyone will even <em>look</em> at this docum
+ent.</p>
This is a line with no tags.
<form action='C:\Inetpub\wwwroot\garban\cgi-bin\cookie.cgi' m
+ethod=post enctype='multipart/form-data'>
<input type='hidden' name=somename value="asdf">
<input type=text name=name value=Ovid size="30" maxsize="
+30">
<br />
<br>
<input type="checkbox" name="group1" value="1" checked />
+ box 1 group 1
<br>
<input type="checkbox" NAME="group1" value="2"> box 2 gro
+up 1
<br>
<input type="password" name="pass"> Password
<br />
<select name="sports">
<option>Tiddly winks
<option>Mud wrestling</option>
</select>
<br>
<textarea name="test">Some text</textarea>
<br>
<input type="radio" name="radio1" value="^" checked /> ra
+dio 1 group 1
<input type="radio" name="radio1" value="^" checked /> ra
+dio 1 group 1
<input type="radio" name="radio1" value="^" checked /> ra
+dio 1 group 1
<input type="radio" name="radio1" value="\" checked /> ra
+dio 1 group 1
<input type="radio" name="radio1" value="]" checked /> ra
+dio 1 group 1
<input type="radio" name="radio1" value="1" checked /> ra
+dio 1 group 1
<br>
<input type="radio" NAME="radio1" value="2"> radio 2 grou
+p 1
<!-- a comment -->
<br />
<SELEct name="religions" multiple>
<option>Democrat
<option>Republican</option>
</select>
<textarea name="test">Some text</textarea>
<br />
<select name="asdf">
<option>Dasdfsdf
<option>asfdasdfasdf</option>
</select>
<br>
<select name="sports">
<option>Twister
<option>Jello wrestling</option>
</select>
<br>
<input type="submit" name=".submit" value="why bother?">
<br>
<input type="radio" name="radio1" value="3" checked /> ra
+dio 3 group 1
<br>
<input type="radio" NAME="radio1" value="4"> radio 4 gro
+up 1
</form>
</body>
</html>
=head2 Output: document named test_form_1.cgi
Note that from a 60 line HTML document, we have instantly generated a
+124 line Perl script.
#!/usr/bin/perl -wT
#
# Program:
# Author:
# Date Created:
# Purpose:
#
# Inputs:
#
# Outputs:
#
# --------------- Maintenance log ------------------------
# Date: June 14, 2001
# Programmer: parse_form.pl
# Action: automatic code generation template
# --------------------------------------------------------
# Date:
# Programmer:
# Action:
# --------------------------------------------------------
use strict;
use CGI;
my $q = CGI->new;
my %errors;
# Grab all data
my $tainted_somename = $q->param( 'somename' ) || ''; # hidden
my $tainted_name = $q->param( 'name' ) || ''; # text
my @tainted_group1 = $q->param( 'group1' ) || (); # checkbox
my $tainted_pass = $q->param( 'pass' ) || ''; # password
my @tainted_sports = $q->param( 'sports' ) || (); # select
my @tainted_test = $q->param( 'test' ) || (); # textarea
my $tainted_radio1 = $q->param( 'radio1' ) || ''; # radio
my @tainted_religions = $q->param( 'religions' ) || (); # select
my $tainted_asdf = $q->param( 'asdf' ) || ''; # select
my $tainted__submit = $q->param( '.submit' ) || ''; # submit
# The following is just a rough "fill in" template for untainting you
+r data.
# It will need to be customized to suit your particular needs. You'l
+l need
# to create regular expressions to untaint your data and if you skimp
+ on this,
# it's at your peril!!!
# hidden values: asdf
my ( $somename ) = ( $tainted_somename =~ /^(asdf)$/ )
or $errors{ 'somename' } = [ "hidden", \$tainted_somename, "Y
+ou must supply a proper value for 'somename'. Allowed characters are
+ letters, numbers, or punctuation." ];
# text values: Ovid
my ( $name ) = ( "" ), die # could not auto-create regex # )
or $errors{ 'name' } = [ "text", \$tainted_name, "You must su
+pply a proper value for 'name'. Allowed characters are letters, numb
+ers, or punctuation." ];
my @group1; # checkbox values: 1,2
foreach ( 0 .. $#tainted_group1 ) {
( $group1[$_] ) = ( $tainted_group1[$_] =~ /^([12])$/ )
or $errors{ 'group1' } = [ "checkbox", \@tainted_group1, "You
+ must supply a proper value for 'group1'. Allowed characters are let
+ters, numbers, or punctuation." ];
}
# password values:
my ( $pass ) = ( "" ), die # could not auto-create regex # )
or $errors{ 'pass' } = [ "password", \$tainted_pass, "You mus
+t supply a proper value for 'pass'. Allowed characters are letters,
+numbers, or punctuation." ];
my @sports; # select values: Tiddly winks,Mud wrestling,Twister,Jello
+ wrestling
foreach ( 0 .. $#tainted_sports ) {
( $sports[$_] ) = ( $tainted_sports[$_] =~ /^(Tiddly\ winks)$/ or
+
$tainted_sports[$_] =~ /^(Mud\ wrestling)$/ o
+r
$tainted_sports[$_] =~ /^(Twister)$/ or
$tainted_sports[$_] =~ /^(Jello\ wrestling)$/
+ )
or $errors{ 'sports' } = [ "select", \@tainted_sports, "You m
+ust supply a proper value for 'sports'. Allowed characters are lette
+rs, numbers, or punctuation." ];
}
my @test; # textarea values:
foreach ( 0 .. $#tainted_test ) {
( $test[$_] ) = ( "" ), die # could not auto-create regex # )
or $errors{ 'test' } = [ "textarea", \@tainted_test, "You mus
+t supply a proper value for 'test'. Allowed characters are letters,
+numbers, or punctuation." ];
}
# radio values: ^,^,^,\,],1,2,3,4
my ( $radio1 ) = ( $tainted_radio1 =~ /^([\^\\\]1234])$/ )
or $errors{ 'radio1' } = [ "radio", \$tainted_radio1, "You mu
+st supply a proper value for 'radio1'. Allowed characters are letter
+s, numbers, or punctuation." ];
my @religions; # select values: Democrat,Republican
foreach ( 0 .. $#tainted_religions ) {
( $religions[$_] ) = ( $tainted_religions[$_] =~ /^(Democrat)$/ o
+r
$tainted_religions[$_] =~ /^(Republican)$/
+ )
or $errors{ 'religions' } = [ "select", \@tainted_religions,
+"You must supply a proper value for 'religions'. Allowed characters
+are letters, numbers, or punctuation." ];
}
# select values: Dasdfsdf,asfdasdfasdf
my ( $asdf ) = ( $tainted_asdf =~ /^(Dasdfsdf)$/ or
$tainted_asdf =~ /^(asfdasdfasdf)$/ )
or $errors{ 'asdf' } = [ "select", \$tainted_asdf, "You must
+supply a proper value for 'asdf'. Allowed characters are letters, nu
+mbers, or punctuation." ];
# submit values: why bother?
my ( $_submit ) = ( $tainted__submit =~ /^(why\ bother\?)$/ )
or $errors{ '_submit' } = [ "submit", \$tainted__submit, "You
+ must supply a proper value for '_submit'. Allowed characters are le
+tters, numbers, or punctuation." ];
error( \%errors ) if %errors;
sub error {
my $err_hash = shift;
# $err_hash is a reference to an anoymous hash. Keys are form at
+tribute names and values
# are an anonymous array: [ element type, value, error_message ]
# Example:
# $err_hash = {
# 'username' => [ 'text', '????', "You must supply a proper
+ value for 'username'..." ]
# }
# Might be generated from: <input type="text" name="username">
my @safe_elements = qw/ hidden radio select submit /;
foreach my $key ( keys %$err_hash ) {
if ( grep { /$$err_hash{ $key }->[0]/ } @safe_elements ) {
# The value of an element whose value shouldn't change ap
+pears to be wrong
sec_log( $$err_hash{ $key }, $key );
} else {
# insert error handling code here
}
}
}
sub sec_log {
my ( $bad_data, $element_name ) = @_;
# $bad_data is a reference to an anoymous array.
# [ element type, value, error_message ]
# Example: [ 'text', '%#$!#$', "You must supply a proper value fo
+r 'username'..." ]
# Might be generated from: <input type="text" name="username">
}
=head1 COPYRIGHT
Copyright (c) 2001 Curtis A. Poe. All rights reserved.
This program is free software; you may redistribute it and/or modify i
+t under
the same terms as Perl itself. The author does not warranty this code
+ for any
particular purpose and strongly recommends that the programmer using t
+his code
have a thorough understanding of Perl security issues. The author acc
+epts
absolutely no responsibility for problems arising from this code. If
+you do
not agree to these terms, please do not use this code.
=head1 AUTHOR
Curtis A. Poe <poec@yahoo.com>
Address bug reports and comments to: poec@yahoo.com. When sending bug
+ reports,
please provide the HTML the program was run against.
=head1 MISCELLANEOUS
This program does not produce production-ready code. It is merely int
+ended to simplify the
process of creating code to read in form data. The untainting section
+ will need to be reviewed
carefully and modified to suit the programmer's needs. Further, no I<
+actual> error handling is
provided in the event that a regex fails to match. As the needs can v
+ary widely, I have
not tried to implement this. You have the error stubs that will have
+an error hash passed. The
rest is up to you.
Note that code is generated with spaces for indenting instead of tabs.
+ As different editors render
tabs at different widths, I felt it prudent to go for safety, as a spa
+ce is a space is a space.
Use of C<$HTML::Parser::VERSION> which is less than 3.25 may result in
+ incomplete output as older
versions do not always handle XHTML correctly. It is the programmer's
+ responsibility to verify
that the output of this code matches the programmer's needs. Naturall
+y, bugs may exist and it's
possible that some form elements may not be properly dealt with by thi
+s code.
The author strongly recommends that you use a validator such as Tidy (
+L<http://www.w3.org/People/Raggett/tidy/>)
to validate your HTML. C<HTML::Parser> does an excellent job of deali
+ng with 'dirty' HTML, but
improperly formatted documents with overlapping E<lt>formE<gt> element
+s (amongst other things),
will cause unpredictable output.
=cut
|
