#!/usr/bin/perl
# ================================================================================
# $Rev: 235 $ $URL: svn://localhost/PlayChess/trunk/cgi/register.cgi $
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Author: $Author: ts $
# Modified: $Date: 2006-10-13 01:52:39 +0200 (Fr, 13 Okt 2006) $
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Copyright at playchess.de - all rights reserved
# ================================================================================
use lib "../cgi-bin";
use PCGI;
use CGI;
use PCPlayer;
use PC;
use PCLeagueUtil;
use PCSession;
use Template;
use Util;
use ChessConfig;
use MyDbi;
##--------------------------------------------------------------------------
## LOCAL CONFIGURATION
##--------------------------------------------------------------------------
local $config = getConfig();
$URL = $ENV{DOCUMENT_URI}; # url of your domain
$err = ''; # error message
$min = 0;
$max = 0;
local $cgi = PCGI->new();
local $sobj = PCSession->new($cgi);
local $debug = (0 || Util::isDebug());
local $action = $cgi->getParam('action') || 'regintro';
local $name = $cgi->getParam('name');
local $last = $cgi->getParam('last');
local $first = $cgi->getParam('first');
local $email = $cgi->getParam('email');
local $homepage = $cgi->getParam('homepage');
local $image = $cgi->getParam('image');
local $passwd = $cgi->getParam('passwd');
local $isengine = $cgi->getParam('isengine');
local $player = $cgi->getParam('player');
#local $class = $cgi->getParam('class');
local $elo = $cgi->getParam('elo');
local $min = $cgi->getParam('min');
local $max = $cgi->getParam('max');
local $cflag = $cgi->getParam('cflag');
local $language = $cgi->getParam('language');
local ($flag,$country) = split('-',$cflag) if $cflag;
# normalize parameters
$email =~ s/^\s+//; $email =~ s/\s+$//;
$name =~ s/^\s+//; $name =~ s/\s+$//;
$last =~ s/^\s+//; $last =~ s/\s+$//;
$first =~ s/^\s+//; $first =~ s/\s+$//;
$passwd =~ s/^\s+//; $passwd =~ s/\s+$//;
# debug output
if( $debug )
{
print "
action = '$action'
\n";
print "name = '$name'
\n";
print "last = '$last'
\n";
print "first = '$first'
\n";
}
#-------------------- Register Intro ---------------------------
if( $action eq 'regintro' )
{
showIntroPage();
}
#-------------------- Register Dialog ---------------------------
elsif( $action eq 'register' )
{
print RegisterDialog( 'edit', $config, $cgi, "" );
}
# Following actions require database access
#------------------------------------------
$dbh = dbiConnect() or exit(1);
#-------------------- Register Confirm ---------------------------
if( $action eq 'regextro' )
{
# Check if entered data are okay
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
$err = CheckPlayerData();
if( $err )
{
print RegisterDialog( "edit", $config, $cgi, $err );
exit(0);
}
print RegisterDialog( 'confirm', $config, $cgi, "" );
}
#-------------------- Create Player ---------------------------
elsif( $action eq 'new' )
{
$err = CheckPlayerData();
if( $err )
{
print RegisterDialog( "edit", $config, $cgi, $err );
exit(0);
}
my ($pobj,$passwd) = Register( $cgi );
$pobj->Save();
# Display compiled player information
my $tpl = Template->new( "register-success.tpl" );
$pobj->addMakros( $tpl );
$tpl->addMakro( 'passwd', $passwd );
print $tpl->Expand($sobj);
$pobj->MailMessage( 'register' );
}
# ===============================================
sub showIntroPage
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create entry page of registration
# ===============================================
{
# No more than MAXREG registrations per day
#------------------------------------------
my( $isClosed );
my $MAXREG = 50;
if( 0 )
{
print "Connection to database...
\n" if( $debug );
$dbh = MyDbi::dbiConnect() or exit(1);
my $stmt = " select count(*) from tbl_player
where since > ?
";
my $n = MyDbi::getValue( $stmt, time()-86400 );
$isClosed = ($n > $MAXREG);
}
my $file = ($isClosed) ? 'register-closed' : 'register';
my $tpl = Template->new( "$file.tpl" );
$tpl->addMakro( "URL", $URL );
$tpl->addMakro( "MAXREG", $MAXREG );
#$tpl->addMakro( "LASTREG", $n );
print $tpl->Expand($sobj);
exit(0);
}
#------------------------------------
sub RegisterDialog
#------------------------------------
{
my( $mode, $config, $cgi, $errstr ) = @_;
my $tpl;
my $ext;
if( $mode eq 'edit' )
{
$ext = ($player eq 'human') ? 'h' : 'c';
$tpl = Template->new( "register-$ext.tpl" );
$tpl->addMakro( "COUNTRY", $country );
$tpl->addMakro( "FLAG", $flag );
$tpl->addMakro( "ELO", $elo );
#TODO: prüfen TITLE
#$tpl->addMakro( "TITLE", $title );
$tpl->addRadioMakro( "gender", $cgi->getParam('gender') );
$tpl->addCheckMakro( "privacy", $cgi->getParam('privacy') );
$tpl->addSelectMakro( "elo", $cgi->getParam('elo') );
$tpl->addSelectMakro( "cflag", $cflag );
$tpl->addSelectMakro( "language", $language );
}
else
{
$tpl = Template->new( "register-confirm.tpl" );
$tpl->addMakro( "COUNTRY", $country );
$tpl->addMakro( "FLAG", $flag );
$tpl->addMakro( "gender", $cgi->getParam('gender') );
$tpl->addMakro( "privacy", ($cgi->getParam('privacy')) ? 'yes' : 'no' );
my $isEngine = $cgi->getParam('isengine');
my( $class );
# human players only
unless( $isEngine )
{
$tpl->addMakro( "TYPE", 'human' );
$tpl->addMakro( "HCLELO", $cgi->getParam('elo') );
for $class (@CLASSES)
{
$tpl->addMakro( "HCLCLASS", $class )
if $cgi->getParam('elo') >= $MINELO{$class};
}
$tpl->addMakro( "ACLELO", 1500 );
$tpl->addMakro( "ACLCLASS", 'A');
}
# chess engines only
if( $isEngine )
{
$tpl->addMakro( "TYPE", 'computer' );
$tpl->addMakro( "CCLCLASS", 'E');
$tpl->addMakro( "CCLELO", 2000 );
}
}
$tpl->addMakro( "URL", $URL );
$tpl->addMakro( "language", $language );
$tpl->addMakro( "NAME", $name );
$tpl->addMakro( "EMAIL", $email );
$tpl->addMakro( "PASSWD", $passwd );
$tpl->addMakro( "FIRST", $first );
$tpl->addMakro( "LAST", $last );
$tpl->addMakro( "AGE", $cgi->getParam('age') );
$tpl->addMakro( "GENDER", $cgi->getParam('gender') );
$tpl->addMakro( "PRIVACY", $cgi->getParam('privacy') );
$tpl->addMakro( "HOMEPAGE", HTTP($cgi->getParam('homepage')) );
$tpl->addMakro( "IMAGE", HTTP($cgi->getParam('image')) );
$tpl->addMakro( "ERR", $errstr );
#-------------- Engines ----------------------------
DBG(__FILE__,__LINE__, $name );
$tpl->addMakro( "ISENGINE", $cgi->getParam('isengine') );
$tpl->addMakro( "HUMAN", !$cgi->getParam('isengine') );
$tpl->addMakro( "COMPUTER", $cgi->getParam('computer') );
$tpl->addMakro( "OPSYSTEM", $cgi->getParam('opsystem') );
$tpl->addMakro( "PROCESSORS", $cgi->getParam('processors') );
$tpl->addMakro( "CYCLES", $cgi->getParam('cycles') );
$tpl->addMakro( "PROGRAM", $cgi->getParam('program') );
$tpl->addMakro( "COMPANY", $cgi->getParam('company') );
$tpl->addMakro( "VERSION", $cgi->getParam('version') );
$tpl->addMakro( "PROGRAMMER", $cgi->getParam('programmer') );
$tpl->addMakro( "OPERATOR", $cgi->getParam('operator') );
DBG(__FILE__,__LINE__, $name );
return $tpl->Expand($sobj);
}
#------------------------------------
sub Register
#------------------------------------
{
my $name = $cgi->getParam('name');
my $pobj = PCPlayer->new( $name );
my $elo = $cgi->getParam('elo');
my $isEngine = $cgi->getParam('isengine');
my( $class );
my ($flag,$country) = split( "-", $cgi->getParam('Country'), 2 );
$pobj->Country ( $country );
$pobj->Flag ( $flag );
$pobj->Email ( $cgi->getParam('email') );
$pobj->FirstName( $cgi->getParam('first') );
$pobj->LastName ( $cgi->getParam('last') );
$pobj->Name ( $cgi->getParam('name') );
$pobj->Age ( $cgi->getParam('age') );
$pobj->Gender ( $cgi->getParam('gender') );
$pobj->Privacy ( $cgi->getParam('privacy') or '' );
$pobj->Homepage ( $cgi->getParam('homepage') );
$pobj->Image ( $cgi->getParam('image') );
$pobj->Title ( $cgi->getParam('title') );
#-------------- Engines ----------------------------
DBG(__FILE__,__LINE__, $name );
$pobj->IsEngine ( "".$cgi->getParam('isengine') );
$pobj->Computer ( $cgi->getParam('computer') );
$pobj->OpSystem ( $cgi->getParam('opsystem') );
$pobj->Processors ( $cgi->getParam('processors') );
$pobj->Cycles ( $cgi->getParam('cycles') );
$pobj->Program ( $cgi->getParam('program') );
$pobj->Company ( $cgi->getParam('company') );
$pobj->Version ( $cgi->getParam('version') );
$pobj->Programmer ( $cgi->getParam('programmer') );
$pobj->Operator ( $cgi->getParam('operator') );
DBG(__FILE__,__LINE__, $name );
# Calculate preliminary password
srand (time|$$);
my $passwd = sprintf( "%s%03d", lc $pobj->Name, rand(1000) );
$pobj->Passwd ( $passwd, 1 );
$pobj->Since ( time );
# Storing the changed data
#-------------------------
my( $stmt, $rv, $pid );
$stmt = "
insert into tbl_player
(name,passwd,email,homepage,image,country,flag,privacy,
shortstmt,longstmt,title,emaillevel,isengine,since,lastvisit,deleted,type,state)
values(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,0,'evaluation','active')
";
$rv = MyDbi::doStmt( $stmt, $name, $pobj->Passwd,
$pobj->Email, $pobj->Homepage, $pobj->Image, $pobj->Country, $pobj->Flag,
$pobj->Privacy, $pobj->ShortStmt, $pobj->LongStmt, $pobj->Title,
$pobj->Emaillevel, $pobj->IsEngine, time, time );
$pid = $dbh->{mysql_insertid};
$pobj->Id( $pid );
printf( "pid=%d name=%s rv='%s'
\n", $pid, $name, $rv ) if( $debug );
dbError(__FILE__,__LINE__,$rv, $pobj->Name, $pobj->Email, $pobj->IsEngine, $pid )
unless( $rv && $pid > 0 );
# Human Player
#-------------
if( ! $pobj->IsEngine )
{
# human attributes
$stmt = "
insert into tbl_humanplayer
(pid,firstname,lastname,age,gender)
values(?,?,?,?,?)
";
my $genderShort = ($pobj->Gender eq 'male') ? 'm' : 'w';
$rv = MyDbi::doStmt( $stmt, $pid, $pobj->FirstName, $pobj->LastName, 0+$pobj->Age, $genderShort );
printf( "HUMAN first=%s last=%s age=%d gender='%s'
\n",
$pobj->FirstName, $pobj->LastName, 0+$pobj->Age, $genderShort ) if( $debug );
printf( "HUMAN pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
# rating and class
for $class (@CLASSES)
{
$pobj->Class('HCL',$class) if $elo >= $MINELO{$class};
}
$pobj->Class('ACL','A');
$pobj->Elo('ACL',1500);
$pobj->Elo( 'HCL', $cgi->getParam('elo') );
$rv = MyDbi::doStmt( "insert into tbl_rating (pid,league,class,rating,ratedgames) values(?,?,?,?,?)",
$pid, 'HCL', $pobj->Class('HCL'), $pobj->Elo('HCL'), 0 );
printf( "RATING HCL pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
dbError(__FILE__,__LINE__,$rv, $pobj->Name, 'HCL', $pid, $pobj->Class('HCL'), $pobj->Elo('HCL') )
unless $rv;
$rv = MyDbi::doStmt( "insert into tbl_rating (pid,league,class,rating,ratedgames) values(?,?,?,?,?)",
$pid, 'ACL', $pobj->Class('ACL'), $pobj->Elo('ACL'), 0 );
printf( "RATING ACL pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
dbError(__FILE__,__LINE__,$rv, $pobj->Name, 'ACL', $pid, $pobj->Class('ACL'), $pobj->Elo('ACL') )
unless $rv;
}
# Computer Player
#----------------
else
{
# computer attributes
$stmt = "
insert into tbl_computerplayer
(pid,computer,opsystem,operator,program,company, programmer,version,processors,speed)
values(?,?,?,?,?,?,?,?,?,?)
";
$rv = MyDbi::doStmt( $stmt, $pid, $pobj->Computer, $pobj->OpSystem, $pobj->Operator, $pobj->Program,
$pobj->Company, $pobj->Programmer, $pobj->Version, $pobj->Processors,
$pobj->Cycles );
printf( "HUMAN pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
dbError(__FILE__,__LINE__,$rv, $pobj->Name, 'CCL', $pid, $pobj->Class('CCL'), $pobj->Elo('CCL') )
unless $rv;
# rating and class
$pobj->Class('CCL','E');
$pobj->Elo('CCL',2000);
$rv = MyDbi::doStmt( "insert into tbl_rating (pid,league,class,rating,ratedgames) values(?,?,?,?,?)",
$pid, 'CCL', $pobj->Class('CCL'), $pobj->Elo('CCL'), 0 );
printf( "RATING CCL pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
dbError(__FILE__,__LINE__,$rv, $pobj->Name, 'CCL', $pid, $pobj->Class('CCL'), $pobj->Elo('CCL') )
unless $rv;
}
# Store ip address into login table for fraud detections
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my $ip = $ENV{REMOTE_ADDR};
MyDbi::doStmt( "insert into tbl_login (pid,ip) values(?,?)", $pid, $ip );
#doStmt( "insert delayed into tbl_login (pid,ip) values(?,?)", $pid, $ip );
# Store language preference
# ~~~~~~~~~~~~~~~~~~~~~~~~~
if( $cgi->param('language') )
{
my $rv = MyDbi::doStmt( "insert into tbl_options (pid,choice,value) values(?,?,?)",
$pid, 'language', $cgi->param('language') );
printf( "OPTIONS pid=%d rv='%s'
\n", $pid, $rv ) if( $debug );
}
return ($pobj,$passwd);
}
#------------------------------------
sub CheckPlayerData
#------------------------------------
{
#$name =~ s/^\s*(\S*)\s*$/$1/;
return 'Nickname contains blank characters. Use "_" instead.' if $name =~ /\s/;
return 'Nickname not allowed' if $name !~ /^[A-Za-z][\w]+$/;
return 'Nickname too long' if length($name) > 20;
return 'Nickname is required' unless $name;
return 'Email is required' unless $email;
return 'Invalid email address' unless PCPlayer->checkEmail( $email );
return 'Last Name is required' unless $isengine || $last;
return 'First Name is required' unless $isengine || $first;
return 'Program is required' unless !$isengine || $cgi->getParam('program');
return 'Homepage not valid' if( $homepage && ($homepage =~ /\s/ || $homepage !~ /\S+\.\S+/) );
return 'Image not valid' if $image && $image !~ /.+\..+\/.+\.(gif|jpg|png)$/i;
return 'Rating out of bounds' if $elo > 2100;
# Check if player name is still free
#-----------------------------------
my $rc = PCPlayer->Exists( $name );
return "Nickname $name is already in use" if $rc && $action ne 'update';
return "Player $name is unknown" if !$rc && $action eq 'update';
# Check for existing aliases
# Allowed are no more than 1 accounts per email address
#------------------------------------------------------
my $engine = ($player eq 'computer') ? "isengine is not NULL and isengine <> ''"
: "(isengine is NULL or isengine = '')";
my $stmt = "
select name from tbl_player
where email=?
and $engine
and (deleted is NULL or deleted <> 1)";
#and name <> ?
#my $alias = MyDbi::getValue( $stmt, $email, $name );
my $alias = MyDbi::getValue( $stmt, $email );
#print "stmt=$stmt
";
#print "alias=$alias
";
#print "name=$name
";
#print "email=$email
";
#return "Too many aliases.
No more than two accounts per email address allowed (there are already $aliases)."
#if( $aliases >= 2 );
return "Alias accounts are not allowed.
You are registered already as '$alias'."
if( $alias );
return "";
}