#!/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;

#######################################################################################
# The following variables should be set by the user to control                        #
# the output of the code generator                                                    #
#                                                                                     #
my $cgi_std  = 0; # set this to false to have OO cgi code written out.                #
my $cgi_obj  = 'q'; # 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 $shebang  = '#!/usr/bin/perl -wT'; # This is the shebang line that will be used.   #
                                    # If left blank, it will be skipped.              #
#######################################################################################

my ( %element, %select, @element_order, $select_token );

if ( $HTML::Parser::VERSION < 3.25 ) {
    warn "\n\tYou have HTML::Parser version $HTML::Parser::VERSION, which is out of date.".
         "\n\tXHTML may not parse correctly\n\n";
}

# walk through document and get each tag
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)
}

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

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;
    }
    my $multiple = exists $select_token->[1]->{ 'multiple' } ? 1 :
                   exists $select{ $name }                   ? 1 :
                                                               0 ;
    update_element_hash( $name, 'select', $value, $multiple );
}

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

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;
        }
    }
}
    
sub usage {
    print <<"    END_HERE";
    Usage:  form_parse.pl some.html
    END_HERE
    exit;
}

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 "use strict;\n";
    print OUT $cgi_line;

    if ( ! $cgi_std ) {
        print OUT "my \$$cgi_obj = CGI->new;\n";
    }

    print OUT "\n# Grab all data\n";

    # Here's where we print param() calls
    foreach my $element ( @element_order ) {
        my $var_name  = $element;
        $var_name     =~ s/\W/_/g; # nice and safe variable names
        my $data_type = $element{ $element }{ 'multiple' } ? '@' : '$';
        print OUT qq/my ${data_type}_${var_name} / .
                  ' ' x ( $max_var_length - length $var_name ) .
                  qq/= ${cgi_var}param( '$element' );/ .
                  ' ' x ( $max_var_length - length $var_name ) .
                  qq/ # $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!!!

    # These are NOT efficient regexes.  For large forms with many similar data values
    # for the same name, this could be quite slow.  I had considered making these more
    # efficient by having separate regex tests for each value, but since the user still
    # needs to go in and tweak them, I didn't see the point.
    
    END_HERE
    # here's where we print the untainting template
    foreach my $element ( @element_order ) {
        my $var_name  = $element;
        $var_name     =~ s/\W/_/g; # nice and safe variable names
        my $type      = $element{ $element }{ 'type' };

        print OUT "# $type values: ". join( ",", @{ $element{ $element }{ 'value' } } ) . "\n";
        if ( $element{ $element }{ 'multiple' } ) {
            # Ooh, multiple values.  Need to untaint an array.
            print OUT qq!my \@${var_name};\n!;
            print OUT qq!( \$${var_name}\[\$_] ) ! .
                  ' ' x ( $max_var_length - length $var_name ) .
                  qq!= ( \$_${var_name}\[\$_] =~ /^(! . create_regex( $element ) . qq!)\$/ ) foreach ( 0 .. \$#_${var_name} );\n\n!;
        } else {
            # Untainting a scalar.
            print OUT qq!my ( \$${var_name} ) ! .
                      ' ' x ( ( $max_var_length - length $var_name ) + 1 ) .
                      qq!= ( \$_${var_name} =~ /^(! . create_regex( $element ) . qq!)\$/ );\n\n!;
        }
    }
    close OUT or die "Can't close $filename: $!";
}

sub create_regex {
    my $element = shift;
    my $type    = $element{ $element }{ 'type' };

    my @safe_types = qw/ hidden checkbox radio select submit /;
    return ' # could not auto-create regex # ' 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 = 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 .. $#values ) {
                # quote ']', '\', and '-' in character class
                if ( $values[ $_ ] =~ /[\]\\\-]/ ) {
                    $values[ $_ ] = '\\' . $values[ $_ ];
                }
            }
        } else {
            @values = map { quotemeta( $_ ) } @values;
        }

        my $regex = $all_length_of_one ? '['. join( '', @values ) .']' : join( '|', @values );
        return $regex;
    } else {
        if ( $values[0] ) {
            return quotemeta $values[0];
        }
    }
}

sub return_unique_items {
    my %seen;
    grep { ! $seen{ $_ }++ } @_;
}