#! /usr/bin/perl
#
# Test dungeon for SE-3, VWA, SoSe 2004
# B. Ulmann fecit, 02-MAY-2004
#
# Be sure to warn on undeclared variables, etc.
use strict;
#use warnings;
use DBI;
# $debug = 1 results in some debug output - this is a global variable! :-)
my $debug = 0;
# Connect to database
sub conn
{
my ($driver, $database, $hostname, $port, $user, $password) = @_;
if ($debug)
{
print "DEBUG: conn ()
\n";
}
my $dsn = "DBI:$driver:database=$database;host=$hostname;port=$port";
my $dbh = DBI -> connect ($dsn, $user, $password); # Connect to database
die "conn (): Could not connect to database!" unless $dbh; # Did not work
die "conn (): Connection error: ", $dbh -> errstr if $dbh -> err;
print "
\n" if $debug;
return $dbh;
}
# Print all information about a location specified by a location number $lnr
sub display_location
{
my ($dbh, $lnr, $picture_prefix) = @_;
if ($debug)
{
print "DEBUG: display_location ()
- lnr = $lnr
- picture_prefix: $picture_prefix
\n";
}
my $statement = "select name, description, picture from locations where lnr = $lnr";
my $sth = $dbh -> prepare ($statement);
$sth -> execute;
die "display_location (): Error: ", $sth -> errstr if ($sth -> err);
my ($name, $description, $picture);
$sth -> bind_columns (\$name, \$description, \$picture);
die "display_location (): Nothing to fetch!" if !($sth -> fetch);
$sth -> finish;
$picture = $picture_prefix . $picture if $picture;
print "$name
\n";
print "![](\"$picture\")
\n" if $picture;
print "$description
\n";
}
# Create a button for each possible direction to go to
sub display_directions
{
my ($dbh, $lnr, $cgi) = @_;
if ($debug)
{
print "DEBUG: display_directions ()
\n";
}
my $statement = "select d.name
from connections c, directions d
where c.from_lnr = $lnr
and c.from_dnr = d.dnr";
my $sth = $dbh -> prepare ($statement);
$sth -> execute;
die "display_directions (): Error: ", $sth -> errstr if ($sth -> err);
my $direction;
$sth -> bind_columns (\$direction);
print "\n";
print "
\n" if $debug;
}
# Get next location number. This is determined from the current location number
# and the name of the direction to go to.
sub get_lnr
{
my ($dbh, $lnr, $direction) = @_;
if ($debug)
{
print "DEBUG: get_lnr ()
- lnr = $lnr
- direction = $direction
\n";
}
my $statement = "select c.to_lnr
from connections c, directions d
where c.from_dnr = d.dnr
and d.name = \"$direction\"
and c.from_lnr = $lnr";
my $sth = $dbh -> prepare ($statement);
$sth -> execute;
die "get_lnr (): Error: ", $sth -> errstr if ($sth -> err);
my $next_location;
$sth -> bind_columns (\$next_location);
die "display_location (): Nothing to fetch!" if !($sth -> fetch);
$sth -> finish;
return $next_location;
}
#########################################################################################
#
# main program
#
#########################################################################################
# Set access parameters:
my $driver = "mysql";
my $database = "dungeon";
my $hostname = "localhost";
my $port = 3306;
my $user = "dungeon";
my $password = "keeper";
my $picture_prefix = '';
my $cgi = "d1.pl"; # Name of the cgi to be called
# Some more variables
my $lnr = 19; # Initial location number
# first_run = 1 denotes that the script was called for the first time
my $first_run = 1;
# Prepare the output of HTML code:
print "Content-type: text/html
";
if ($debug) # We are running in debug mode!
{
print "Running in debug mode!
\n";
}
# Read parameters from GET or POST access:
my ($buffer, @pairs, $pair, $name, $value, %FORM);
# Read in text
$ENV{'REQUEST_METHOD'} =~ tr/a-z/A-Z/;
if ($ENV{'REQUEST_METHOD'} eq "POST")
{
read (STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
}
else # Not POST -> GET :-)
{
$buffer = $ENV{'QUERY_STRING'};
}
# Split information into name/value pairs
@pairs = split(/&/, $buffer);
foreach $pair (@pairs)
{
($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%(..)/pack("C", hex($1))/eg;
$FORM{$name} = $value;
$first_run = 0;
}
# Dump parameters:
if ($debug)
{
print "DEBUG: Parameters:
- first_run = $first_run\n";
foreach my $key (keys %FORM)
{
print "
- $key = $FORM{$key}\n";
}
print "
\n";
}
# Connect to database
my $dbh = conn ($driver, $database, $hostname, $port, $user, $password);
if (!$first_run) # Not the first run - so determine the actual room number
{
$lnr = get_lnr ($dbh, $FORM{'lnr'}, $FORM{'direction'});
}
display_location ($dbh, $lnr, $picture_prefix);
display_directions ($dbh, $lnr, $cgi);
print "
";
$dbh -> disconnect;