#!/usr/bin/perl
# Filename:	former
# Author:	David Ljung Madison <DaveSource.com>
# See License:	http://MarginalHacks.com/License
# Version:	1.00
# Description:	Creates self-validating form CGI code
# See ePerl:	http://MarginalHacks.com/Hacks/ePerl
use strict;

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0;
$PROGNAME =~ s|.*/||;

##################################################
# Usage
##################################################
sub usage {
  my $msg;
  foreach $msg (@_) { print "ERROR:  $msg\n"; }
  print "\n";
  print "Usage:\t$PROGNAME [-d] <file.fd>\n";
  print "\tGenerates form perl code from a .fd (form description)\n";
  print "\t-d\tSet debug mode\n";
  print "\n";
  exit -1;
}

sub parse_args {
  my $file;
  while ($#ARGV>=0) {
    my $arg=shift(@ARGV);
    if ($arg =~ /^-h$/) { usage(); }
    if ($arg =~ /^-d$/) { $MAIN::DEBUG=1; next; }
    if ($arg =~ /^-/) { usage("Unknown option: $arg"); }
    usage("Too many files specified [$arg and $file]") if (defined($file));
    $file=$arg;
  }
  usage("No file defined") if (!defined($file));

  $file;
}

sub pfatal { die("[$PROGNAME, line $.] @_\n"); }
sub fatal { die("[$PROGNAME] @_\n"); }

##################################################
# Read form descriptor
##################################################
# We start/end forms with:  <form name> .. </form>
#
# And fill it with fields:
#
#   name;Prompt;type type_opts;[err msg];checking expression
#
# And selects/radio buttons:
#   <select>
#     name;value;optional check
#   </select>
#
# Example:
# <form page1>
#   form_number;1;hidden
#   first_name;First Name:;input size='25' maxsize='100';1;
#   email;Email:;input size='25' maxsize='100';/\S\@\S+\.\S+/;email must be of form <i>login@somewhere.com</i>
#   cost;Cost:;input size='5' maxsize='10';/^\d+$/ && $_;cost must be a number
#   <select airport;Airport:>
#     none;Where are you flying into?;0
#     sfo;SFO
#     oak;OAK;$query->{first_name} =~ /mike/;Mike lives in oak
#     sjc;SJC
#   </select>
#   <radio fav_color;Favorite color>
#     red;Red;$query->{first_name} =~ /mike/;Only people named Mike like the color red
#     green;Green
#     blue;Of course, Blue is my favorite color
#   </radio>
#   next;Next page;submit
# </form>
#
# "checking expression" of 1 means the field needs any string entry
#
##################################################
sub read_fd {
  my ($fd) = @_;

  open(FILE,$fd) || usage("Couldn't open file: $fd");

  my %forms;

  my ($form,$select,$radio,$srprompt);
  while(<FILE>) {
    s/#.*//;		# Ignore comments
    s/^\s+//;
    s/\s+$//;
    next if /^$/;	#   and whitespace

    # Start a form?
    unless ($form) {
      pfatal("Expected <form ..>") unless (/^<form\s*(\S+)>$/);
      $form = $1;
      pfatal("Saw form [$form] twice") if ($forms{$form});
      next;
    }

    # Start or stop something?
    if (/^<(\/)?(\S+)(\s+(\S.*))?>$/) {
      my ($stop,$what,$name) = ($1 ? 1 : 0, $2, $4);
      if ($stop) {
        if ($what eq "select") {
          pfatal("Saw </select> when not in <select>") unless $select;
          undef $select;
        }
        if ($what eq "radio") {
          pfatal("Saw </radio> when not in <radio>") unless $radio;
          undef $radio;
        }
        if ($what eq "form") {
          fatal("Never saw </select>") if ($select);
          fatal("Never saw </radio>") if ($radio);
          undef $form;
        }
        next;
      }
      $srprompt = $name;
      ($name,$srprompt) = ($1,$2) if $name =~ /(.+);(.+)/;
      pfatal("No name for <$what>") unless $name;
      pfatal("Didn't finish <radio $radio> when entering <select $select>")
        if ($what eq "select" && $radio);
      pfatal("Didn't finish <select $select> when entering <radio $radio>")
        if ($what eq "radio" && $select);
      $select = $name if ($what eq "select");
      $radio = $name if ($what eq "radio");
      next;
    }

    if ($select || $radio) {
      my @a = split(/;/,$_,4);
      my %f;
      ($f{name},$f{string},$f{check},$f{err}) = @a;
      $f{string} =~ s/([\$])/\\$1/g;
      $f{type} = $select ? "select" : "radio";
      $f{type_opt} = $select || $radio;
      $f{prompt} = $srprompt;
      push(@{$forms{$form}}, \%f);
      next;
    }

    my @a = split(/;/,$_,5);
    pfatal("Couldn't parse line:\n  $_") if $#a < 2;
    my %f;
    ($f{name},$f{prompt},$f{type_str},$f{check},$f{err}) = @a;
    ($f{type},$f{type_opt}) = split(/\s+/,$f{type_str},2);
    pfatal("Unknown field type [$f{type}]")
      unless (grep($f{type} eq $_, ("input","hidden","submit")));
    # Add to the forms array
    push(@{$forms{$form}}, \%f);
  }
  close(FILE);

  fatal("Never saw </select>") if ($select);
  fatal("Never saw </radio>") if ($radio);
  fatal("Never saw </form>") if ($form);

  \%forms;
}

sub display_forms {
  my ($forms) = @_;

  foreach my $form ( keys %$forms ) {
    print "FORM: $form\n";
    foreach my $field ( @{$forms->{$form}} ) {
      print "  $field->{type}: \"$field->{prompt}\"\t\t[$field->{name}]\n";
    }
  }
}

##################################################
# Write the CGI/HTML
##################################################
sub do_print {
  my ($str) = @_;
  $str =~ s/"/\\"/g;
  $str =~ s/\n/\\n/g;
  print "  print \"$str\";\n";
}

sub write_utils {
  my ($forms) = @_;


  print <<'END_UTILS';
# Unquote form data
sub unhtml {
  my ($str) = @_;
  $str =~ s/%([0-9a-f]{2})/chr(hex($1))/eig;
  $str =~ s/\+/ /g;
  $str;
}

# Make strings safe for form values
sub html_safe {
  my ($str) = @_;
  $str =~ s/"/&quot;/g;
  $str;
}

sub parse_query {
  my $QUERY_STRING;
  if ($ENV{REQUEST_METHOD} eq "POST") {
    read(STDIN,$QUERY_STRING,$ENV{CONTENT_LENGTH});
  } else {
    $QUERY_STRING = $ENV{QUERY_STRING};
  }
  chomp($QUERY_STRING);
  # $QUERY_STRING is of the form:  "variable=value&var2=val2&.."
  my @querys=split(/[\&\?]/,$QUERY_STRING);
  my (%query,$var,$val);
  foreach my $str (@querys) {
    $var=$str if (!(($var,$val) = ($str =~ /([^=]*)=(.*)/)));
    $val=unhtml($val);
    $query{$var}=$val;
  }

  \%query;
}

END_UTILS

  # Write checkers for each form
  foreach my $form ( keys %$forms ) {
    print "sub check_form_$form {\n";
    print "  my (\$query) = \@_;\n";
    print "  my \@bad;\n";
    my $last_select;
    foreach my $field ( @{$forms->{$form}} ) {
      my $chk = $field->{check};
      next unless $chk || $chk eq "0";
      $chk = "/\\S/" if ($chk == 1);
      my $name = $field->{name};
      my $err = $field->{err};
      $err =~ s/\@/\\@/g;
      $err =~ s/\$/\\\$/g;
      if ($field->{type} eq "select" || $field->{type} eq "radio") {
        $name = $field->{type_opt};
        if ($last_select ne $name) {
          print "  push(\@bad,[$name,\"Must select one of the $field->{prompt} options\"])\n";
          print "    unless (\$query->{$name});\n";
          $last_select = $name;
        }
        print "  \$_ = \$query->{$name};  push(\@bad,[$name,\"$err\"])\n";
        print "    unless (\$_ ne $field->{name} || $chk);\n";
      } else {
        print "  \$_ = \$query->{$name};  push(\@bad,[$name,\"$err\"])\n";
        print "    unless ($chk);\n";
      }
    }

    # Print errors?
    print "  return unless \@bad;\n";
    do_print "<h2>Error: fields are missing or invalid (marked in red)</h2>\n";
    print "  my \@bad_fields;\n";
    print "  foreach ( \@bad ) {\n";
    print "    push(\@bad_fields,\$_->[0]);\n";
    print "    print \"<li> <font color=red>\$_->[1]</font>\\n\" if (\$_->[1]);\n";
    print "  }\n";
    print "  \@bad_fields;\n";
    print "}\n\n";
  }
}

sub write_forms {
  my ($forms) = @_;

  foreach my $form ( keys %$forms ) {
    my ($select,$radio);
    print "sub form_$form {\n";
    print "  my (\$query,\@bad_fields) = \@_;\n";
    print "  my \%did_fields;\n";
    do_print "<form method=POST>\n";
    #do_print "  <table width=100% cellspacing=0 cellpadding=0>\n";
    do_print "  <table>\n";
    foreach my $field ( @{$forms->{$form}} ) {
      if ($select && $field->{type} ne "select") {
        do_print "    </select></td></tr>\n";
        undef $select;
      }
      undef $radio if ($radio && $field->{type} ne "radio");

      if ($field->{type} eq "input") {
        print "  \$did_fields{$field->{name}} = 1;\n";
        do_print "    <tr>\n";
        print    "  if (grep($field->{name} eq \$_, \@bad_fields)) {\n";
        do_print "    <td align=left><font color='red'>$field->{prompt}</font></td>\n";
        print    "  } else {\n";
        do_print "    <td align=left>$field->{prompt}</td>\n";
        print    "  }\n";
        do_print "    <td align=left><$field->{type} name='$field->{name}' value=";
        print    "  print '\"'.html_safe(\$query->{$field->{name}}).'\"';\n";
        do_print " $field->{type_opt}></td>\n";
        do_print "    </tr>\n";

      } elsif ($field->{type} eq "submit" || $field->{type} eq "hidden") {
        print "  \$did_fields{$field->{name}} = 1;\n";
        do_print "    <tr>\n";
        do_print "    <td align=left colspan=2><input type=$field->{type} name='$field->{name}' value='$field->{prompt}' $field->{type_opt}></td>\n";
        do_print "    </tr>\n";

      } elsif ($field->{type} eq "select") {
        unless ($select) {
          print "  \$did_fields{$field->{type_opt}} = 1;\n";
          do_print "    <tr>\n";
          $select = $field->{type_opt};
          print    "  if (grep($select eq \$_, \@bad_fields)) {\n";
          do_print "    <td align=left><font color='red'>$field->{prompt}</font></td>\n";
          print    "  } else {\n";
          do_print "    <td align=left>$field->{prompt}</td>\n";
          print    "  }\n";
          do_print "    <td align=left>\n";
          do_print "    <select name='$select'>\n";
        }

        do_print "<option value='$field->{name}'";
        print "  print \" selected\" if (\$query->{$select} eq \"$field->{name}\");\n";
        do_print ">$field->{string}</option>\n";

      } elsif ($field->{type} eq "radio") {
        unless ($radio) {
          print "  \$did_fields{$field->{type_opt}} = 1;\n";
          do_print "    <tr>\n";
          $radio = $field->{type_opt};
          print    "  if (grep($radio eq \$_, \@bad_fields)) {\n";
          do_print "    <td align=left><font color='red'>$field->{prompt}</font></td>\n";
          print    "  } else {\n";
          do_print "    <td align=left>$field->{prompt}</td>\n";
          print    "  }\n";
          do_print "    <td align=left>\n";
        }
        do_print "    <input type='radio' name='$radio' value='$field->{name}'";
        print "  print \" checked\" if (\$query->{$radio} eq \"$field->{name}\");\n";
        do_print "> $field->{string}\n";

      } else {
        fatal("write_forms() Unknown field type?? [$field->{type}]");
      }
    }
    do_print "  </table>\n";

    # Add hidden any fields that were in the query that weren't in the form
    print "  foreach my \$k ( keys \%\$query ) {\n";
    print "    next if (\$did_fields{\$k});\n";
    do_print "    <input type='hidden' name='\$k' value=";
    print    "  print '\"'.html_safe(\$query->{\$k}).'\"';\n";
    do_print ">\n";
    print "  }\n";

    do_print "</form>\n";
    print "}\n\n";
  }
}

##################################################
# Main code
##################################################
sub main {
  my $fd = parse_args();

  my $forms = read_fd($fd);
  #display_forms($forms);
  write_utils($forms);
  write_forms($forms);
  print "\n1;\n";
}
main();