#!/usr/bin/perl

use CGI ':standard', '-debug', 'start_dl', 'end_dl';
use DB_File;
use Fcntl ':flock';

my $CONFIG = '/home/mjd/perl/qotw/e006/quiz-questions';
my $RESULTS = '/home/mjd/perl/qotw/e006/W/survey-results';

if (param('display')) {
  display_survey($CONFIG, $RESULTS);
} elsif (param()) {
  accumulate_results($RESULTS);
  print header(), start_html({BGCOLOR => 'white'});
  print h1("Thanks!"), end_html;
} else {
  display_survey($CONFIG);
}

exit;

sub display_survey {
  my $config = shift;
  my $results = shift;
  my $qn = 1;
  my %r;
  print header(), start_html({BGCOLOR => 'white'});

  if ($results) {
    print h1("Survey Results"),       start_dl();
    %r = get_results($results);
  } else {
    print h1("Survey"), start_form(), start_dl();
  }

  for (questions($config)) {
    local ($\, $,) = ("\n", "\n");
    my $q = $_->{Q};
    my @a = @{$_->{A}};
    my %opt = %{$_->{OPTION}};
    my $question_key = question_key($qn++);
    print dt(b("$q?"));

    if ($opt{ALLOW_OTHER}) {
      $a[$_->{OTHER_N}] = textfield("$question_key:other");
    }

    my @vals = 0 .. $#a;
    my $cols = @a < 3 ? 1 : @a < 6 ? 2 : 3;

    if ($results) {
      my %qres = %{$r{$question_key}}; # responses for this question
      my $total = delete $qres{'total'};
      print dt(), "($total total respondents)\n", "<table cellspacing=0 cellpaddng=5>";
      for (sort {$qres{$b} <=> $qres{$a}} @vals) {
        my $pct = sprintf("%.1f", $qres{$_}*100/$total);
        print Tr({align=>'right'}, 
                 td({align => 'left'}, "<b>$a[$_]</b>"), 
                 td($qres{$_}+0), 
                 td("$pct%")
                );
      }
      print "</table>\n";
    } else {
      @checked = $opt{OPTIONAL} ? (-default => $_->{NO_RESPONSE_N}) : ();
      my $oae = CGI::autoEscape(0);
      print dd(radio_group(-name => $question_key,
                           @checked,
                           -values => \@vals,
                           -labels => {map {$_ => " $a[$_]"} @vals},
                           -columns => $cols,
                          ));
      CGI::autoEscape($oae);
    }
  }

  if ($results) {
    print end_dl(),                                         end_html();
  } else {
    print end_dl(), submit("Submit Responses"), end_form(), end_html();
  }
}

sub question_key { "q$_[0]" }

sub accumulate_results {
  my $db = shift;
  flock *DATA, LOCK_EX or die "flock: $!";
  tie my %r => 'DB_File', $db, O_RDWR | O_CREAT
    or die "$db: $!";
  for my $q (param()) {
    my $a = param($q);
    if ($q =~ /:other$/) {
      $r{$q} .= "$a\0";
    } else {
      $r{"$q:$a"} += 1;
      $r{"$q:total"} += 1;
    }
  }
}

sub get_results {
  my ($db) = @_;
  flock *DATA, LOCK_SH or die "flock: $!";
  tie my %r => 'DB_File', $db, O_RDONLY
    or die "$db: $!";
  my %rr;
  for my $k (keys %r) {
    my ($q, $a) = split /:/, $k;
    $rr{$q}{$a} = $r{$k};
  }
  %rr;
}

sub questions {
  my $FILE = shift;
  open my $c, "<", $FILE or die "$FILE: $!";
  my @quiz;
  while (<$c>) {
    chomp;
    ($_, my $options) = split /;;\s*/, $_, 2;
    my %option = map {uc($_) => 1} split(/,\s*/, $options);
    my ($q, $a) = split /\?\s*/, $_, 2;
    my @a = split /;\s*/, $a;
    my %h;
    if ($option{ALLOW_OTHER}) {
      push @a, "other";
      $h{OTHER_N} = $#a;
    }
    if ($option{OPTIONAL}) {
      push @a, "(no response)";
      $h{NO_RESPONSE_N} = $#a;
        
    }
    push @quiz, {Q => $q, A =>\@a, 
                 OPTION => \%option, 
                 %h
                };
  }
  @quiz;
}

__DATA__
