[SPOILER] Perl Quiz-of-the-Week #10

I decided to use a simple list of hashes data structure to store the questions
database and to use the Storable module to make it persistent.  I also added a
test mechansim that reads a file which can initialize the database as well as
iterate on any number of question/answer sessions.  So, running the test file
below results in the following output :

Does it fly? : no
Is it a Salmon? : no
I give up
What animal were you thinking of? : dog
What is a question that would distinguish a Dog from a Salmon? : does it have 
four legs?

Restarting ...

Does it fly? : No
Does it have four legs? : Yes
Is it a Dog? : No
I give up
What animal were you thinking of? : cow
What is a question that would distinguish a Cow from a Dog? : Can you milk it?

Restarting ...

Does it fly? : No
Does it have four legs? : Yes
Can you milk it? : Yes
Is it a Cow? : No
I give up
What animal were you thinking of? : Goat
What is a question that would distinguish a Goat from a Cow? : Can it climb 
mountains?

Restarting ...

Does it fly? : no
Does it have four legs? : Yes
Can you milk it? : Yes
Can it climb mountains? : No
Is it a Cow? : Yes

Yeah, got it!!

Restarting ...

Does it fly? : Y
Does it have feathers? : y
Is it a sparrow? : n
I give up
What animal were you thinking of? : parrot
What is a question that would distinguish a Parrot from a sparrow? : Can it 
talk?

-- Test 
------------------------------------------------------------------------------

## The following lines initialize the database ##
{ "question" => "Does it fly?",           "yes" => 1,         "no" => "Salmon"  
  }
{ "question" => "Does it have feathers?", "yes" => "sparrow", "no" => "Fruit 
bat" }

## Question set 1 ##
no
no
dog
does it have four legs?

## Question set 2 ##
No
Yes
No
cow
Can you milk it?

## Question set 3 ##
No
Yes
Yes
No
Goat
Can it climb mountains?

## Question set 4 ##
no   # fly?
Yes  # four legs?
Yes  # milk it?
No   # Climb?
Yes  # Cow?

## Question set 5 ##
Y
y
n
parrot
Can it talk?

-- Program 
------------------------------------------------------------------------------
#!/usr/bin/perl -w
use strict ;
use Getopt::Std ;
use Storable qw(nstore retrieve) ;
use Data::Dumper ;

my(%opts, @questions, @test, $answer, $guess, $question, $yesno, $animal) ;

die <<_Usage_ unless getopts('rdnq:t:', \%opts) ;

Usage: $0 <option>*

Supported options:

 -t {test_file}
 -r Restart with clean database
 -d Use Data::Dumper to dump database
 -n Don't update database
 -h Show this help message.

_Usage_

if (! $opts{r} and -f "questions.db") {
    @questions = @{retrieve("questions.db")} ;                ## Retrieve data 
from database
} else {
    ## Initialize the data structure with minimal set of questions and answers 
##
    $questions[0] = { "question" => "Does it fly?",           "yes" => 1,       
  "no" => "Salmon"    } ;
    $questions[1] = { "question" => "Does it have feathers?", "yes" => 
"sparrow", "no" => "Fruit bat" } ;
}

if ($opts{t}) {
    open(TEST, $opts{t}) or die "\n$0 : Cannot open test file : $opts{t}\n\n" ;
    @test = <TEST> ;                                          ## Read in the 
whole test file
    close(TEST) ;
    map(s/\s*\#.*$//, @test) ;                                ## Remove comments
    @test = grep(!/^\s*$/, @test) ;                           ## remove empty 
lines
    undef @questions if $test[0] =~ /^\{/ ;                   ## Initialize 
questions if data structure specified in test file
    while ($test[0] =~ /^\{/) {
        eval("push(\@questions, $test[0])") ;                 ## Create 
questions database from test file
        shift @test ;
    }
}

print "\n" . Dumper(\@questions) . "\n" if ($opts{d}) ;       ## Dump starting 
data structure
print "\n" ;
my $num = 0 ;                                                 ## Let's begin 
with the first question

while (1) {
    $yesno = get_yesno("$questions[$num]->{question} : ") ;   ## Ask the 
current question
    $guess = $questions[$num]{$yesno} ;                       ## Retrieve guess 
based on answer
    if ($guess !~ /^\d+$/) {                                  ## Are we at a 
guess?
        $answer = get_yesno("Is it a $guess? : ") ;           ## Yes, we must 
guess now
        if ($answer eq 'yes') {
            print "\nYeah, got it!!\n\n" ;                    ## We guessed 
correctly!
            next if restart() ;
            last ;
        }
        $animal   = get_answer("I give up\nWhat animal were you thinking of? : 
") ;       ## Bzzzt.  Wrong guess.
        $question = get_answer("What is a question that would distinguish a 
$animal from a $guess? : ") ;
        $question =~ s|([^\?])$|$1?| ;                                          
          ## Append '?' to question if missing
        push(@questions, { 'question' => $question, 'yes' => $animal, 'no' => 
$guess }) ; ## Save new question
        $questions[$num]{$yesno} = $#questions ;                                
          ## Update incorrect guess to new question
        next if restart() ;
        print "\n" ;
        last ;
    }
    $num = $guess ;                                           ## Point to new 
guess and try again
}

print "\n" . Dumper(\@questions) . "\n" if ($opts{d}) ;       ## Dump new data 
structure
nstore(\@questions, "questions.db") unless ($opts{n}) ;       ## Store data to 
questions database

sub get_yesno {                                               ## Get answer.  
Accept only yes/no.
    my $answer ;
    while ($answer = get_answer($_[0])) {
        last if $answer =~ s/y\S*/yes/i ;
        last if $answer =~ s/n\S*/no/i ;
        print "\nAnswer must be either yes or no :\n" ;
    }
    return $answer ;
}

sub get_answer {                                              ## Get answer ...
    my $answer ;
    print "$_[0]" ;
    if ($opts{t} and @test) {                                 ## from test 
script
        $answer = shift @test ;
        print $answer ;
    } else {
        $answer = <> ;                                        ## or else stdin
    }
    chomp($answer) ;
    return ucfirst $answer ;
}

sub restart {                                                 ## Restart the 
questioning if there are any more tests avail.
    if (@test) {
        print "\nRestarting ...\n\n\n" ;
        $num = 0 ;
        return 1 ;
    }
    return 0 ;
}