#!/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 options
# are just for configuration.
#
# The following variable MUST only containt letters, numbers, or underscores:
#   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 are doing.
my @safe_types = qw/ hidden checkbox radio select submit /;

my %element;       # holds all of the form element types, names, and values
my %select;        # holds select form elements so we know if we've seen them
my @element_order; # order that elements appear in the form.  It's not really
                   # needed, but we do this so that variables in generated code
                   # appear roughly in the same order as the form.
my $select_token;  # holds the select token when parsing <select> values


# 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 '/select' ) ) {
                $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, clear 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, $type, '[$_]' ) .
                  "}\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, $multiple ) . " )\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 punctuation." ];\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 suitable for,
            # so we return separate regex tests for each value
            #my $offset = $multiple ? length( $taint_pfx ) + 17 : length( $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( $values[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 attribute 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 possible 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 appears 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 characters
    # with special meaning in a character class.  Otherwise, we'll escape 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 December/;
    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 write 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::VERSION, 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 underscores:\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 form 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.  This program will read
an HTML document and produce a series of files, one per form in the script.  

Each file will be the beginnings of the CGI script used to process each 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 interpreter 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 program, 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 section will be:

 use strict;
 use CGI;
 my $q = CGI->new;

The variable name for the CGI object is set with the C<$cgi_obj> variable.

=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 variable 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 (assumes 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 particular 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>/optionE<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<parse_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 form data should be
relatively simple to untaint.  These are elements for which the data is 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 create a regular expression
to match this data.  If the default values are all single character, it will use a character class
to match the data.  Otherwise, it will use alternation.  For the C<@_sports> 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 value for 'sports'.  Allowed characters are letters, numbers, or punctuation.";
 }

The first line is a comment listing the type of form element and any default values that were
provided by the form and a declaration of the variable to hold the untainted 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 expressions 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 something 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 slightly different.  This is 
to force the programmer to actually go through and add all of these regexes.  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 ensures 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 can 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 match /^\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 be skipped.

    my $shebang   = '#!/usr/bin/perl -wT';

=item C<$err_var>

Use this for the name of the hash that will contain the errors generated 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 routine.  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 elements 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>/optionE<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 document.</p>
         This is a line with no tags.
         <form action='C:\Inetpub\wwwroot\garban\cgi-bin\cookie.cgi' method=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 group 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 /> radio 1 group 1
             <input type="radio" name="radio1" value="^" checked /> radio 1 group 1
             <input type="radio" name="radio1" value="^" checked /> radio 1 group 1
             <input type="radio" name="radio1" value="\" checked /> radio 1 group 1
             <input type="radio" name="radio1" value="]" checked /> radio 1 group 1
             <input type="radio" name="radio1" value="1" checked /> radio 1 group 1
             <br>
             <input type="radio" NAME="radio1" value="2"> radio 2 group 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 /> radio 3 group 1
             <br>
              <input type="radio" NAME="radio1" value="4"> radio 4 group 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 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!!!
 
 # hidden values: asdf
 my ( $somename ) = ( $tainted_somename =~ /^(asdf)$/ )
         or $errors{ 'somename' } = [ "hidden", \$tainted_somename, "You 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 supply a proper value for 'name'.  Allowed characters are letters, numbers, 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 letters, numbers, or punctuation." ];
 }
 
 # password values: 
 my ( $pass ) = ( "" ), die  # could not auto-create regex #  )
         or $errors{ 'pass' } = [ "password", \$tainted_pass, "You must 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)$/ or 
                         $tainted_sports[$_] =~ /^(Twister)$/ or 
                         $tainted_sports[$_] =~ /^(Jello\ wrestling)$/ )
         or $errors{ 'sports' } = [ "select", \@tainted_sports, "You must supply a proper value for 'sports'.  Allowed characters are letters, 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 must 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 must supply a proper value for 'radio1'.  Allowed characters are letters, numbers, or punctuation." ];
 
 my @religions; # select values: Democrat,Republican
 foreach ( 0 .. $#tainted_religions ) {
     ( $religions[$_] ) = ( $tainted_religions[$_] =~ /^(Democrat)$/ or 
                            $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, numbers, 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 letters, 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 attribute 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 appears 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 for '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 it 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 this code
have a thorough understanding of Perl security issues.  The author accepts
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 intended 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 vary 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 space 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.  Naturally, bugs may exist and it's
possible that some form elements may not be properly dealt with by this 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 dealing with 'dirty' HTML, but
improperly formatted documents with overlapping E<lt>formE<gt> elements (amongst other things),
will cause unpredictable output.

=cut