=head1 NAME

Xmas - Quiz Page handler

=head1 DESCRIPTION

This package provides the page handling for the Christmas Quiz
on the web site

=cut

package Xmas;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '0.01';

use IO::File;

my $last_content = "";
my $flag_dir = "/tmp/";
use Apache2::Const qw(FORBIDDEN DECLINED OK M_GET M_POST
	      MODE_READBYTES SERVER_ERROR 
	      HTTP_LOCKED HTTP_UNAUTHORIZED);

use APR::Const    qw(SUCCESS BLOCK_READ);

use Apache2::RequestRec;
use Apache2::RequestIO;
use Apache2::ServerUtil;
use Apache2::Directive;
use Apache2::ServerRec;
use Apache2::URI;
use Apache2::Connection;
use Apache2::Filter;
use Apache2::SubProcess ();

use APR::Brigade;
use APR::Bucket;
use APR::Table;

use constant IOBUFSIZE => 8192;

my %config;
my %query;

my @parts =
(
{
id => "morgan",
who => "ellie",
where => "xxxx",
answer => "1671",
question => "Mallet to crown, file to sceptre and orb down the trousers",
responces =>
  [
    '$check =~ /blood/i' => "What year?",
    '$check =~ /tower/i' => "What year?",
    '$check =~ /jewel/i && $check =~ /crown/i' => "What year?",
    '$check =~ /1671/i' => "Just the four digits",
  ],
},
{
id => "capital",
who => "ellie",
where => "xxxx",
answer => "tokyo",
question => "Shuffle a top Yank, OJ, and wipe out the country",
responces =>
  [
    '$check =~ /japan/i' => "Just the city name",
    '$check =~ /tokyo/i' => "Just a single word",
  ],
},
{
id => "mark",
who => "ellie",
where => "xxxx",
answer => "matt",
question => "Type of paint where Homer comes from",
responces =>
  [
    '$check =~ /springfield/i' => "Springfield is a type of paint?",
    '$check =~ /gr[ea]+[cs]/i' => "Greece is best on chips",
    '$check =~ /matt/i' => "Just a single word",
  ],
},
{
id => "metal",
who => "ellie",
where => "xxxx",
answer => "gun",
question => "<> - rock",
responces =>
  [
    '$check =~ /gunn/i' => "So Close... name of a thing, not a person",
    '$check =~ /gun/i' => "Just a single word",
  ],
},
{
id => "hulk",
who => "ellie",
where => "sumdim",
answer => "comic",
question => "Funny commedian like Batman",
responces =>
  [
    '$check =~ /rob[yi]n/i' => "A thing, not a bird",
    '$check =~ /comic/i' => "Just a single word",
  ],
},
{
id => "destroy",
who => "ellie",
where => "sumdim",
answer => "2353",
question => "When did the doomsday clock start?",
responces =>
  [
    '$check =~ /19[456]\d/i' => "Not the year, the time",
    '$check =~ /seven/i' => "Time in 24 hour clock?",
    '$check =~ /midnight/i' => "Time in 24 hour clock?",
    '$check =~ /11\:?53/i' => "Right time now in 24 hour clock?",
    '$check =~ /23\D+53/i' => "Just the four digits",
  ],
},
{
id => "adamant",
who => "ellie",
where => "sumdim",
answer => "strip",
question => "Take off type of poker",
responces =>
  [
    '$check =~ /the[\+\s]*strip/i' => "What about taking off?",
    '$check =~ /strip/i' => "Just a single word",
  ],
},
{
id => "gos",
who => "ellie",
where => "sumdim",
answer => "clair",
question => "<>",
responces =>
  [
    '$check =~ /gil/i' => "The song not the singer",
    '$check =~ /sul[ie]/i' => "The song not the singer",
    '$check =~ /clair/i' => "Just a single word",
  ],
},
{
id => "behind",
who => "rosie",
where => "xxxx",
answer => "hiro",
question => "Between the diamond age and the long summer",
responces =>
  [
    '$check =~ /snow/i' => "Right idea, who is the main character?",
    '$check =~ /crash/i' => "Right idea, who is the main character?",
    '$check =~ /n[aie]+l/i' => "Not the author the character",
    '$check =~ /st[ae](v|ph)[ae]ns[oea]n/i' => "Not the author the character",
    '$check =~ /hero/i' => "Wrong spelling",
    '$check =~ /hiro/i' => "Just his first name",
  ],
},
{
id => "texas",
who => "rosie",
where => "xxxx",
answer => "odessa",
question => "Between Moldovia and Mykolaviv",
responces =>
  [
    '$check =~ /^M[o-y]/i' => "Not between in the dictionary",
    '$check =~ /odessa/i' => "Just a single word",
  ],
},
{
id => "book",
who => "rosie",
where => "xxxx",
answer => "sword",
question => "Between the swot and switch",
responces =>
  [
    '$check =~ /sw/i' => "Looking for a thing",
    '$check =~ /sword/i' => "Just a single word",
  ],
},
{
id => "cooper",
who => "rosie",
where => "xxxx",
answer => "election",
question => "Between a candidate and an office holder",
responces =>
  [
    '$check =~ /select/i' => "Selection by the people",
    '$check =~ /election/i' => "A single word for the time",
  ],
},
{
id => "joey",
who => "rosie",
where => "sumdim",
answer => "manhattan",
question => "Where friends live",
responces =>
  [
    '$check =~ /new[\+\s]?york/i' => "A district in New York",
    '$check =~ /queens/i' => "A different district in New York",
    '$check =~ /bronx/i' => "A different district in New York",
    '$check =~ /broadway/i' => "Not a street, a district in New York",
    '$check =~ /times[\+\s]*square/i' => "Not a corner, a district",
    '$check =~ /manhattan/i' => "Just a single word",
  ],
},
{
id => "here",
who => "rosie",
where => "sumdim",
answer => "glasses",
question => "Drinking or looking?",
responces =>
  [
    '$check =~ /glasses/i' => "Just a single word",
    '$check =~ /glass/i' => "A word for the things",
  ],
},
{
id => "coffee",
who => "rosie",
where => "sumdim",
answer => "breakfast",
question => "Quick snap first meal",
responces =>
  [
    '$check =~ /lunch/i' => "Close",
    '$check =~ /breakfast/i' => "Just a single word",
  ],
},
{
id => "rome",
who => "rosie",
where => "sumdim",
answer => "peter",
question => "<> - gun",
responces =>
  [
    '$check =~ /pink/i' => "Try a different detective",
    '$check =~ /panther/i' => "Try a different detective",
    '$check =~ /[ck]l[oue]+s+[aeiou]/i' => "Try an American detective",
    '$check =~ /[cs][ea]+l+[ae]r?s/i' => "Coincidently close, but wrong detective",
    '$check =~ /peter/i' => "Just a single word",
    '1' => "Blake Edward's Detective",
  ],
},
);

sub got_error
{
my($msg) = @_;
Apache2::ServerRec->log_error($msg."\n");
return "<span class=\"error_msg\">$msg</span>";
}

sub unpack_var
{
my($r,$line) = @_;
return undef if(!defined $line || $line eq "");

if($line =~ m/^([\w\d_\-]+)(\s*=\s*|\s+)(\S.*)$/)
{
return($1,$3);
}
# Should give an error here really
return(got_error("Cannot unpick config variable from \"$line\""));
}

sub unpick_config
{
# In Apache2 the dir_config() method has been removed from 
# the request and replaced with per_dir_config() which 
# returns a class that has no documentation.

# The documentation says that you can call dir_config() on
# the Apache2::ServerUtil->server() object passing a key, 
# but you can't.  If you pass no key you get a APR::Table object
# which the documentation says is tied to a hash, but FIRSTKEY 
# is not implemented so the keys() function won't work.  The 
# documentation also claims that a do() method has been 
# created to iterate over the keys, but it hasn't.

# There is a Apache2::Directive method that returns the 
# configuration information.  So we use that and do it the 
# hard way
my $r = shift;
my %ret;
my $tree = Apache2::Directive::conftree();
my $hash = $tree->lookup('Location', $r->uri());
my $vars = ${$hash}{PerlSetVar};
if(ref($vars) eq "ARRAY")
{
foreach my $l (@{$vars})
  {
    next if(!defined $l || $l eq "");
    my($k1,$v1) = unpack_var($r,$l);
    $ret{$k1} = $v1
	     if(defined $v1);
  }
}
else
{
return () if(!defined $vars || $vars eq "");
my($k,$v) = unpack_var($r,$vars);
$ret{$k} = $v
	 if(defined $v);
}
return %ret;
}

sub content 
{
# From http://perl.apache.org/docs/2.0/user/handlers/filters.html
    #All_in_One_Filter
    # There must be a better way but I don't know what it is

    my $r = shift;
  
    my $bb = APR::Brigade->new($r->pool, $r->connection->bucket_alloc);
  
    my $data = '';
    my $seen_eos = 0;
    do{
        $r->input_filters->get_brigade($bb, Apache2::Const::MODE_READBYTES,
                                         APR::Const::BLOCK_READ, IOBUFSIZE);
  
        for (my $b = $bb->first; $b; $b = $bb->next($b))
          {
            if ($b->is_eos)
              {
                $seen_eos++;
                last;
              }
  
            if ($b->read(my $buf))
              {
                $data .= $buf;
              }
  
            $b->remove; # optimization to reuse memory
          }
      } while (!$seen_eos);
  
    $bb->destroy;

    $last_content = $data;  
    return $data;
  }

sub fill_query
  {
    # Extract any query args into the %query hash
    my $r = shift;

    # Clear out the current query vals
    %query = ();

    my $args = $r->args();
    if(defined $args)
      {
        # Extract parameters from the query
        my @q = split(/[\&]/,$args);
        while(@q)
          {
            my($var,$val) = split(/\=/,shift(@q));

            # Don't do any escape translation, we are just going to
            # send it on anyway

            if(defined $query{$var})
              {
                # Must have multiple values for a single param.  Angler 
                # uses this technique when creating [array] attributes

                # We shove such attributes into an array
                $query{$var} = [$query{$var}]
                               if(ref($query{$var}) ne "ARRAY");
                push @{$query{$var}},$val;
              }
            else
              {
                $query{$var} = $val;
              }
          }
      }
    return if($r->method_number() == M_GET);
    if($r->method_number() != M_POST)
      {
        Apache2::ServerRec->log_error("Handler cannot deal with ".
                            $r->method." (".$r->method_number().")");
        return;
      }
    # There are two types of request we could have, a 
    # set of var=val pairs or a multipart form
    # The first line tells us if this is a multipart form
    my $buffer = content($r);
    if($buffer =~ /^(\-{20,50}[0-9a-zA-Z]+)[\n\r]+/)
      {
        # This is a multipart form with a marker between each part
        my $marker = $1;
        $query{_multipart_marker} = $marker;

        while($buffer)
          {
            if($buffer =~ /$marker/)
              {
                my $chunk = $`;
                $buffer = $';

                $chunk =~ s/^\r\n//;
                next if($chunk eq "");
                my $attrib_name = "bad_spec";
    
                while($chunk)
                  {
                    if($chunk =~ s/^Content-Disposition\s*\:\s*form-data; name="
([^\"]+)"; filename="([^\"]+)"[\n\r]+//i)
                      {
                        $attrib_name = $1;

                        $query{$1."_filename"} = $2;
                      }
                    elsif($chunk =~ s/^Content-Disposition\s*\:\s*form-data; nam
e="([^\"]+)"[\n\r]+//i)
                      {
                        $attrib_name = $1;
                      }
                    elsif($chunk =~ s/^Content-Type\s*\:\s*(.*)[\n\r]+//)
                      {
                      }
                    elsif($chunk =~ s/^[\n\r]+//)
                      {
                        last;
                      }
                    else
                      {
                        last;
                      }
                  }
                # I think that the value has an extra CRLF on it
                $chunk =~ s/\r\n$//;
                $query{$attrib_name} = $chunk;
              }
            else
              {
                last;
              }
          }
      }
    else
      {
        # This is a set of var=val pairs, unpick it
        my @q = split(/[\&]/,$buffer);
        while(@q)
          {
            my($var,$val) = split(/\=/,shift(@q));
    
            # Don't do any escape translation, we are just going to
            # send it on anyway
    
            if(defined $query{$var})
              {
                # Must have multiple values for a single param.  Angler 
                # uses this technique when creating [array] attributes
    
                # We shove such attributes into an array
                $query{$var} = [$query{$var}]
                                   if(ref($query{$var}) ne "ARRAY");
                push @{$query{$var}},$val;
              }
            else
              {
                $query{$var} = $val;
              }
          }
      }
  }


sub pose_question
  {
    my($r,$question,$name,$prev_answer,$is_correct) = @_;

    print <<"EndQuestion";
<tr><td class="question_pane"><p class="question">$question</p></td>
    <td class="input_pane">
EndQuestion
    if($is_correct)
      {
        print "$prev_answer is correct<input type=\"hidden\" name=\"$name\" ".
                                      "value=\"$prev_answer\"/>";
      }
    else
      {
        print "<input type=\"text\" name=\"$name\" value=\"$prev_answer\"/>";
      }
    print "</td></tr>\n";
  }

sub question_page
  {
    my($r,$who,$where) = @_;

    my $question_num = 0;    
    my $unanswered = 0;
    
    print <<"EndHeader";
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html>
  <head>
    <title>Christmas Quiz</title>
    <meta name="author" content="Tsort"/>
    <style type="text/css">
table.form_layout
  {
    width: 95%;
    text-align: center;
    vertical-align: middle;
  }

.top
  {
    text-align: center;
    font-weight: bold;
  }

h1
  {
    color: #0000ff;
  }

p.question
  {
    text-align: right;
    color: #0000ff;
    vertical-align: middle;
  }

img
  {
    border: none;
    vertical-align: middle;
  }

.question
  {
    vertical-align: middle;
  }

.question_pane
  {
    width: 60%;
    text-align: right;
    vertical-align: middle;
  }

td.question_pane
  {
    vertical-align: middle;
  }

.input_pane
  {
    width: 100%;
    text-align: left;
  }


table.tim
  {
    width: 50%;
    text-align: center;
  }
    </style>
  </head>
  <body class="quiz_page">
<h1>Christmas Quiz</h1>
<form action="index.htm" method="post">
<p class="top">
This quiz comes in four parts:
</p>
<table class="form_layout">
EndHeader
    for(my $i=0;$i<=$#parts;$i++)
      {
        if($parts[$i]->{who} eq $who && $parts[$i]->{where} eq $where)
          {
            $question_num++;
            my $id = $parts[$i]->{id};
            if(defined $query{$id} && lc($query{$id}) eq $parts[$i]->{answer})
              {
                pose_question($r,$parts[$i]->{question},$id,
                                    $query{$id},1);
                next;
              }
            $unanswered++;
            if(defined $query{$id} && $query{$id} ne "")
              {
                my $got_match = 0;
                my $check = $query{$id};
                for(my $j=0;$j<=$#{$parts[$i]->{responces}};$j+=2)
                  {
                    if(eval($parts[$i]->{responces}->[$j]))
                      {
                        pose_question($r,"$parts[$i]->{question} ($parts[$i]->{responces}->[$j+1])",
                                         $id,$query{$id},0);
                        $got_match = 1;
                        last;
                      }
                  }
                next if($got_match);
              }
            pose_question($r,$parts[$i]->{question},$id,"",0);
          }
      }
    print "<tr><td class=\"question_pane\">&nbsp;</td>\n";
    print "    <td class=\"input_pane\"><input type=\"submit\" value=\"Try Answers\"/></td></tr>\n";
    print "</table></form><hr/>\n";
    
    if($unanswered == 0)
      {
        # touch /tmp/${who}_${where}
    
        my $ofh = IO::File->new(">$flag_dir${who}_${where}");

        print " ";
        $ofh->close();
    
        my $total_time = 0;

        print "<p>Answers correct, result values are...</p>\n";
        print "<table class=\"tim\">\n<tr>\n";
        my $time = time;
        for my $wh ("ellie", "rosie")
          {
            for my $er ("xxxx", "sumdim")
              {
                my $t = "$flag_dir${wh}_${er}";
                if(!-r $t)
                  {
                    print "<td>XXXX</td>\n";
                    $total_time += 9999;
                    next;
                  }
                my @st = stat($t);
                if($time - $st[9] < 9999)
                  {
                    printf "<td>%4d</td>\n",$time - $st[9];
                    $total_time += $time - $st[9];
                  }
                else
                  {
                    print "<td>----</td>\n";
                    $total_time += 9999;
                  }
              }
          }
        print "</tr></table>\n";
        if($total_time > 9999)
          {
            print "<p>Find other answers</p>\n"
          }
        elsif($total_time > 10)
          {
            print "<p>Total is $total_time (need below 10)</p>\n"
          }
        else
          {
            print "<p>Tell us what it is and we will tell you where</p>\n"
          }
      }
    print "</body></html>";
  }

sub handler
  {
    my $r = shift;

    return DECLINED;
    $r->content_type('text/html');
    return OK if($r->header_only());

    my %config = unpick_config($r);
    # First we have to populate the %query hash
    fill_query($r);

    my $this_path = $r->uri();
    my $this_ip = $r->connection()->remote_ip();

    my $who = "unknown";
    my $where = "unknown";

    $who = "ellie" if($this_path =~ /xmas_quiz/);
    $who = "rosie" if($this_path =~ /xmas\-quiz/);
    $where = "xxxx" if($this_ip eq "192.168.71.203");
    $where = "sumdim" if($this_ip eq "192.168.254.4");

    if($who ne "unknown" && $where ne "unknown")
      {
        question_page($r,$who,$where);
        return OK;
      }
    return DECLINED;
  }

1;