WWW::TwentyQuestions - Perl interface to the classic 20 Questions game as provided by 20Q.net

  use WWW::TwentyQuestions;

  # Create a new object
  my $q = new WWW::TwentyQuestions;

  # Start a new game and get the first question
  # ("Is it an animal, vegetable, or mineral?")
  my $first = $q->start;

  # Print the first question and our options.
  print "$first\n"
    . $q->choices . "\n";

  # Loop while we're playing.
  while ($q->playing) {
    # Give the user a chance to answer.
    my $answer = <STDIN>;
    chomp $answer;

    # Send the answer into the game and get the next question
    # (or the same question if the answer was unacceptable)
    my $next = $q->answer ($answer);

    # Print the next question and our choices.
    print "$next\n"
      . $q->choices . "\n";

  }

  print "Game Over\n";

  Q1.  Is it classified as Animal, Vegetable or Mineral?

  20Q Won!
  You were thinking of a piranha.

  You won!
  You have stumped 20Q!

  - Several debug messages are printed to STDOUT.
  - The "Start New Game" page and all subsequent question pages have their HTML codes
    dumped into start.html or q.html, respectfully.
  - All internal hash data is dumped into core.txt on every game request.

  0.01  Sun Dec 24 19:54:46 2006
        - Original version.

package WWW::TwentyQuestions;

# Documentation is at the end of the module code.

use strict;
use warnings;
use LWP::UserAgent;

our $VERSION = '0.01';

our $URI = {
	'start_en-us'     => 'http://www.20q.net/startg_enUS.html',
	'startplay_en-us' => 'http://y.20q.net/gsew-en',
};

sub new {
	my $class = shift;

	my $self = {
		debug    => 0,
		agent    => new LWP::UserAgent,
		userid   => undef,
		passwd   => undef,
		playing  => 0,
		lang     => 'en-us',
		choices  => {}, # temporary answer options for last question asked
		answers  => [], # temporary array of options
		question => undef, # last question asked
		on_error => sub {
			my ($q,$err) = @_;

			warn "WWW::TwentyQuestions Error: $err";
		},
	};
	$self->{agent}->agent ('Mozilla/4.0');

	bless ($self,$class);
	return $self;
}

sub setErrorHandler {
	my ($self,$ref) = @_;

	$self->{on_error} = $ref;
}

sub callError {
	my ($self,$err) = @_;
	if (defined $self->{on_error}) {
		&{$self->{on_error}} ($self,$err);
	}
}

sub debug {
	my ($self,$msg) = @_;

	if ($self->{debug} == 1) {
		print "$msg\n";
	}
}

sub request {
	my ($self,$method,$url,$args) = @_;

	$self->debug ("Request $method $url...");

	my $reply = undef;
	if ($method eq 'GET') {
		$reply = $self->{agent}->get ($url);
	}
	elsif ($method eq 'POST') {
		$reply = $self->{agent}->post ($url,$args);
	}

	if (defined $reply) {
		if ($reply->is_success) {
			return $reply->content;
		}
		else {
			$self->callError ("Could not access $url: " . $reply->status_line . "\n");
		}
	}
	else {
		$self->callError ("Unsupported HTTP method $method ?");
		return undef;
	}
}

sub dump {
	my ($self,$file,$info) = @_;

	return unless $self->{debug} == 1;

	open (FILE, ">$file");
	print FILE $info;
	close (FILE);

	use Data::Dumper;
	open (CORE, ">core.txt");
	print CORE Dumper($self);
	close (CORE);
}

sub start {
	my $self = shift;

	my $inf = {
		language => 'en-us',
		game     => 'classic',
		@_,
	};
	$self->{lang} = $inf->{language};

	my $url = $URI->{ "start_" . $inf->{language} };
	if (not defined $url) {
		warn "No URL for language $inf->{language}!";
		return undef;
	}

	# Get a username and password.
	my $login = $self->request ('GET', $url);
	($self->{userid}) = $login =~ /<input type=hidden name="userid" value="(.+?)"/i;
	($self->{passwd}) = $login =~ /<input type=hidden name="password" value="(.+?)" >/i;
	#print "Got user: $self->{userid}:$self->{passwd}\n";

	# Start the game.
	$url = $URI->{ "startplay_" . $inf->{language} };

	my $reply = $self->request ('POST',$url, {
		userid => $self->{userid},
		password => $self->{passwd},
		scgend   => 77,    # male; 70 = female
		scage    => 20,    # age
		scccode  => 21333, # United States
	});

	$self->dump ("start.html",$reply);

	# Get the first question.
	my ($firstq) = $reply =~ /<big><b>Q1. &nbsp;(.+?)<br>/i;
	if (not defined $firstq) {
		$self->callError ("First question not found!");
		return undef;
	}
	$firstq = "Q1.  $firstq";
	$self->{question} = $firstq;

	$self->{playing} = 1;

	# Get the choices.
	$self->{choices} = {};
	$self->{answers} = [];
	while ($reply =~ /<a href="\/gsew\-en\?(.+?)" target="mainFrame">(.+?)<\/a>/i) {
		my $label = $2;
		if ($label ne '<font color="#000033"><font size="+3"><b>?</b></font></font>') {
			push (@{$self->{answers}}, $label);
			$label = lc($label);
			$label =~ s/ //g;
			$self->{choices}->{$label} = $1;
		}
		$reply =~ s/<a href="\/gsew\-en\?(.+?)" target="mainFrame">(.+?)<\/a>//i;
	}

	#print "Answers: " . join (", ", keys %{$self->{choices}}) . "\n";
	return $firstq;
}

sub answer {
	my ($self,$answer) = @_;
	$answer = lc($answer);
	$answer =~ s/ //g;

	# Was it a valid answer?
	if (defined $self->{choices}->{$answer}) {
		# Find this answer's ID.
		my $id = $self->{choices}->{$answer};
		my $url = $URI->{ "startplay_" . $self->{lang} };
		my $reply = $self->request ('GET', "$url?$id");

		#print "Answer Chosen: $answer (id: $id)\n";
		#print "Reply Length: " . length $reply;

		# Get the next question.
		my ($number,$question) = $reply =~ /<big><b>Q(\d+)\. &nbsp;(.+?)<br>/i;

		$self->dump ("q.html",$reply);

		# If 20Q just made a guess and we responded...
		if ($answer eq 'right') {
			# See if 20Q won or if WE won.
			my $winner = 'unknown';
			if ($reply =~ /<h2>20Q won!<\/h2>/i) {
				$winner = '20Q Won!';
			}
			else {
				$winner = 'You won!';
			}

			my ($thinking) = $reply =~ /<big><b>You were thinking (.+?)<\/b><\/big>/i;
			$thinking = "You were thinking $thinking";

			# Not playing anymore.
			$self->{playing} = 0;
			$self->{question} = 'Start a new game to play!';
			$self->{answers} = [];
			$self->{choices} = {};
			return "$winner\n$thinking";
		}

		# If 20Q has given up and we won...
		if ($reply =~ /<h2>You won!<\/h2>/i) {
			my $winner = 'You won!';

			# Not playing anymore.
			$self->{playing} = 0;
			$self->{question} = 'Start a new game to play!';
			$self->{answers} = [];
			$self->{choices} = {};
			return "$winner\nYou have stumped 20Q!";
		}

		# See if this is a regular question or a guess at the answer.
		if ($reply =~ /<a href="\/gsew-en\?(.+?)">Right<\/a>\, <a href="\/gsew-en\?(.+?)">Wrong<\/a>\, <a href="\/gsew-en\?(.+?)"> Close <\/a> <br>/i) {
			print "##### 20Q is making a guess!\n";
			my $right = $1;
			my $wrong = $2;
			my $close = $3;

			$self->{choices} = {
				right => $right,
				wrong => $wrong,
				close => $close,
			};
			$self->{answers} = [ qw(Right Wrong Close) ];

			$self->{question} = "Q$number.  $question";
			return $self->{question};
		}

		# Get the new answers.
		$self->{choices} = {};
		$self->{answers} = [];
		while ($reply =~ /<a href="\/gsew\-en\?(.+?)" target="mainFrame">(.+?)<\/a>/i) {
			my $id    = $1;
			my $label = $2;
			if ($label ne '<font color="#000033"><font size="+3"><b>?</b></font></font>') {
				#print "Found answer: $label (id: $id)\n";
				$label =~ s/&nbsp;//g;
				push (@{$self->{answers}}, $label);
				$label = lc($label);
				$label =~ s/ //g;
				$self->{choices}->{$label} = $id;
			}
			$reply =~ s/<a href="\/gsew\-en\?(.+?)" target="mainFrame">(.+?)<\/a>//i;
		}

		$self->{question} = "Q$number.  $question";
		return $self->{question};
	}
	else {
		warn "Invalid answer\n";
		return $self->question;
	}
}

sub playing {
	return shift->{playing};
}

sub question {
	return shift->{question};
}

sub choices {
	return join (", ", @{shift->{answers}});
}

1;