#!/usr/bin/perl 
   use CGI qw( :all :nodebug);
   use Data::Dumper;
   $Data::Dumper::Indent=2;
   $Data::Dumper::Terse=1;
   $Data::Dumper::Deepcopy=1;
   print header;
   my $tree=$VAR1 = [
          {
            'tipo' => 'html',
            'html' => 'Enunciado: escreva uma função perl que calcule o factorial de um número passado como parámetro.'
          },
          {
            'tipo' => 'textarea',
            'columns' => '50',
            'name' => 'fact',
            'opt' => 0,
            'rows' => '10'
          },
          {
            'tipo' => 'html',
            'html' => 'Enunciado: escreva uma função que traduza quantias de escudos para euros
 -- (as quantias em escudos têm ...$..). Os Euros devem aparecer com 2 casa
decimais. <p>
  Exemplo de teste: esc2eur(\'os bolos custam 60$00\') deve dar:
 \'os bolos custam 0.30 euros\''
          },
          {
            'tipo' => 'textarea',
            'columns' => '50',
            'name' => 'esc2eur',
            'opt' => 0,
            'rows' => '10'
          },
          {
            'tipo' => 'textfield',
            'name' => 'nome',
            'opt' => 0
          },
          {
            'tipo' => 'textfield',
            'inv' => '\\&mail',
            'name' => 'email',
            'opt' => 0
          }
        ];

   my $act =$VAR1 = {
          'save' => {
                      'arg' => '/home/jj/inscritos2'
                    },
          'cginame' => '/home/jj/public_html/bin/_2',
          'mail' => {
                      'arg' => 'jj'
                    },
          'formtitle' => 'Trabalho prático 1 Factorial',
          'feedback' => 'f'
        };

   my $p;
   print start_html( -title=>'', -author=>'jj@di.uminho.pt');
   print h2($act->{formtitle}) if $act->{formtitle};

   if (param) {
     my %par = CGI::Vars();
     for(keys %par){delete $par{$_} unless ($par{$_} =~ /\w/)}
     my $error = validatepar($tree,\%par);
     $p = merge(\%par,$act);
     $error ||= &{$act->{inv}}($p) if $act->{inv};
     if ($error) { print red($error), geraForm($tree) }
     else        { 
                   if($act->{analyze}){ 
                       my $r=eval("&$act->{analyze}".'($p,$tree)');
                   }
                   react($tree,$p,$act);
                   if($act->{feedback}){ 
                       my $r=eval("&$act->{feedback}".'($p,$tree)');
                       if ($@){print red("Erro ($act->{feedback}) $@")} 
                       else {print $r;}
                   }
                   else                { print geraForm($tree,1);}
                 } }
   else{
     print geraForm($tree)
   } 
   
   print end_html;

sub addtosave{
 my $what=shift;
 open(F,">>$act->{save}{arg}") or print "Fix me: conf. Error: $!\n";
 print F "\n#__EOS__#\n$what\n";
 close F;
}

sub react{
  my ($t,$par2,$a)=@_;
  if(defined $a->{mail}){ 
      require Mail::Send;
      my $msg = new Mail::Send 
                       Subject=>'From CGI FormLang'. $a->{title}, 
                       To=> $a->{mail}{arg};
      my $fh = $msg->open;
      if($a->{mail}{feedback}){
         my $r=eval("&$a->{mail}{feedback}".'($par2)');
         if ($@){print red("Erro ($a->{mail}{feedback}) $@")}
         else {print $fh $r;}}
      else{print $fh Dumper($par2)};
      $fh->close;
  }
  if(defined $a->{save}){
      open(F,">>$a->{save}{arg}") or print "conf. Error: $!\n";
      if($a->{save}{feedback}){
         my $r=eval("&$a->{save}{feedback}".'($par2)');
         if ($@){print red("Erro ($a->{save}{feedback}) $@")}
         else {print F $r;}}
      else{print F "\n#__EOS__#\n",Dumper($par2)};
      close F;
  }
}

sub validatepar{
  my ($t,$p) = @_;
  my $err = "";
  for(@$t){ 
     next if (  $_->{tipo} eq "seq" 
              ||$_->{tipo} eq "map" 
              ||$_->{tipo} eq "mapline" 
              ||$_->{tipo} eq "html");
     if    ( $_->{tipo} ne "file" and ! $_->{opt} and ! $p->{$_->{name}} ){ 
        $err .= " (falta ". ($_->{prompt}||$_->{name}). ")" }
     elsif ( $_->{tipo} eq "file" and ! $_->{opt} and ! $p->{FFF.$_->{name}} ){ 
        $err .= " (falta ". ($_->{prompt}||$_->{name}). ")" }
     elsif( defined($_->{inv}) && defined($p->{$_->{name}})){
        my $r= eval($_->{inv});
        my $m = &$r($p->{$_->{name}});
        $err .= " (". ($_->{prompt}||$_->{name}).": $m)" if $m;
     }
  }
  $err = "Erro no preenchimento: $err" if $err;
}

sub red{ font({color=>"red"},@_)}

sub geraarea{
  my ($iscte,$a)=@_;
  my $r="";
  if( $a->{tipo} eq "seq"){
       geraFormContent([map { +{ name =>"$a->{name}-$_", 
                                 #prompt => $_, opt => 1,
                                 prompt => " ", opt => 1,
                                 %{$a->{of}}}}(1..$a->{card})], $iscte) }
  elsif( $a->{tipo} eq "mapline"){
       geraFormLineContent([map { +{%{$_},prompt=>$_->{name}, 
                                      name =>"$a->{name}-$_->{name}"}}
                            @{$a->{of}}], $iscte) }
  elsif( $a->{tipo} eq "map"){
       geraFormContent([map { +{%{$_},prompt=>$_->{name}, 
                                      name =>"$a->{name}-$_->{name}"}}
                            @{$a->{of}}], $iscte) }
  elsif( $iscte)                    {
       param( $a->{name}) }
  elsif( $a->{tipo} eq "textarea")  {
       textarea(-name => $a->{name}, 
                              -rows => $a->{rows}, 
                              -columns => $a->{columns} )}
  elsif( $a->{tipo} eq "file") {
       filefield(-name => "FFF$a->{name}",
                               -size => $a->{size} || 45)}
  elsif( $a->{tipo} eq "textfield") {
       textfield(-name => $a->{name},
                               -size => $a->{size} || 45)}
  elsif( $a->{tipo} eq "popup_menu"){
       popup_menu(-name =>$a->{name},
                                -values => $a->{values })}
}

sub geraForm{
  my $t= shift;
  my $isCte = shift || "";
  my $r = ($isCte ? "": start_multipart_form ) ;
  $r .= geraFormContent($t,$isCte);
  $r .= ($isCte ? "": submit().end_form);
  $r;
}

sub merge{   ## params 2 perl...
  my ($p,$a)=@_;
  my $changes=1;
  while($changes){
    $changes=0;
    for(keys %$p){
      $changes++;
      if(/FFF(.*)/){$p->{$1}={name=>$p->{$_},
                              tipo=>"uploadfile",
                              file=>saveupload($_,$a,$p->{$_})}; delete $p->{$_};}
      elsif(/(.*)\-(\d+)$/){ $p->{$1}[$2-1]= $p->{$_} ; delete $p->{$_};}
      elsif(/(.*)\-(\w+)$/){ $p->{$1}{$2}  = $p->{$_} ; delete $p->{$_};}
      else{$changes--} } }
  $p
}

sub geraFormContent{
  my $t= shift;
  my $isCte = shift || "";
  my $r=CGI::start_table({cellspacing =>"0",cellpadding=>"0",border=>"0"});
  for(@$t){
     if($_->{tipo} eq "html"){
       $r.= Tr( td({colspan=>2},$_->{"html"} ))}
     else {
       $r.= Tr(
         td({valign=>"top",align=>"right"},
            ($_->{opt}?"  ":red("*")).ucfirst($_->{prompt}||$_->{name})." "),
         td(geraarea($isCte,$_)));
     }
  }
  $r .= CGI::end_table();
  rect($r)
} 

sub geraFormLineContent{
  my $t= shift;
  my $isCte = shift || "";
  my $r="";
  for(@$t){
     if($_->{tipo} eq "html"){ $r.= $_->{"html"} }
     else {
       $r.= ($_->{opt}?"  ":red("*")).ucfirst($_->{prompt}||$_->{name})." ".
         geraarea($isCte,$_);
     }
  }
  rect($r)
} 

sub saveupload{
  my $f=shift;
  my $act=shift;
  my $name=shift;
  $name =~ s!.*[/\\]!!;
  my $dir=$act->{uploaddir} || "/tmp";
  my $file = upload($f);
  local $/;
  undef $/;
  my @time= ((localtime(time()))[5,4,3,2,1,0],$$);
  $time[0] += 1900;
  $time[1] ++;
  # my $localfilename= "$dir/". join("-",@time). "-$name";
  my $localfilename=sprintf('%s/%d-%02d-%02d-%02d-%02d-%02d-%d-%s',
                            ($dir,@time,$name));
  open (F,">$localfilename") or die;
  print F <$file>;
  close F;
  $localfilename;
}

sub rect{shift}
#sub rect{div({-style=>'padding: 3pt;'},@_)}



use warnings FATAL => qw(recursion) ;

sub mail { if( $_[0] =~ /\@/) {""} else { "Não parece ser um email"} }

sub f{
 join(";",
  testperlf( {timout=>2},"fact", $_[0]{fact},( 0 => 1, 3 => 6, 4 => 24)),
  testperlf( {timout=>2},"esc2eur", $_[0]{esc2eur},( 
    'os bolos custam 60$00' => 'os bolos custam 0.30 euros',
    'os bolos custam 60' => 'os bolos custam 60',
    'os bolos custam 60$00 e o café 55$00' => 'os bolos custam 0.30 euros e o café 0.28 euros' )
));
}

sub testperlf{
  my %opt =(timout => 1);                # tens um segundo para calculos...
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my ($name,$f,%tab)=@_;
  eval $f;
  if($@){ red("Erro $@\n")}
# elsif(not defined $main::{$name}){ red("Erro Não encontrei a função $name\n")}
  else  { testperlf1( \%opt,$main::{$name},%tab); }
}

sub testperlf1{
  my %opt =(timout => 1);                # tens um segundo para calculos...
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my ($f,%tab)=@_;
  my $i=0;
  my $ok=0;
  my $r="Resultados dos testes".CGI::start_ol();

  for(keys %tab){
    $i++;
    $SIG{'ALRM'} = sub {die "timeout\n"};
    eval{
      alarm($opt{timout});
      if(&$f($_) eq $tab{$_}){ $r.= li(" .. Ok");       $ok ++}
      else                   { $r.= li(red(" .. not ok
(",&$f($_),"),(",$tab{$_},")"));}
      alarm(0)
    };
    if($@){
      alarm(0);
      if   ( $@ =~ /timeout/ )   { $r.= li(red(" .. timeout")) }
      elsif( $@ =~ /recursion/i ){ $r.= li(red(" .. Recur. infinita(?)")); }
      else                       { $r.= li(red(" .. $@")); }
    }
  }
  $r.= CGI::end_ol(). p(sprintf("Total: %2d",int($ok*100/$i)));
  $r
}