#!/usr/bin/perl -w
# whisker_perl_demo.pl
# 7 Feb 2010
# ---------------------------
# Syntax:	whisker_perl_demo.pl [server [port]]
#
# Note that Perl comments are preceded by a hash (#)

require 5.002; # Require this version of Perl.
use strict; # Enable strict syntax checking.
use Socket; # Use the Socket module for TCP/IP communications.
use IO::Handle; # IO::Handle provides the autoflush command.
use DBI; # Database access functions.
use DBI qw(:sql_types); # Use SQL keywords.
# use DBI qw(:get_info); # for DBI::SQL_DBMS_NAME; not yet supported; see http://www.mail-archive.com/dbi-dev@perl.org/msg00624.html

my $server = shift || 'localhost'; # Get server name or supply default.
my $mainport = shift || 3233; # Get (main) port number or supply default.
my ($immport, $line, $event, $reply); # Declare other variables.
my $DEBUGNETWORK = 1; # Controls verbose printing of network communications
my $DEBUGDATABASE = 1; # Controls verbose printing of database communications

print "Whisker demo in Perl\n";
print "--------------------\n";

# Declare handles
our ($OUTFILE, $MAINSOCK, $IMMSOCK);

# Open text file.
print "--- Enter text-based results file details.\n";
my $textfile = AskUser("Text results file", "whiskertemp.txt");
open($OUTFILE, ">$textfile");

# Open database connection.
print "--- Enter database details.\n";
my $driver = AskUser("Database driver for DBI (e.g. mysql, ODBC) (NB case-sensitive)", "ODBC");
my $database = AskUser("Name of database", "testdb");
my $username = AskUser("Database username", "root");
my $password = AskUserPassword("Database password");
my $dbh = ConnectToDatabase($driver, $database, $username, $password);

# Open network connection.
$immport = ConnectBothPorts($server, $mainport);

# Initial commands to server: claiming lines and setting up the task.
Send("ReportName Whisker Perl demo program");
Send("ReportStatus Absolutely fine.");
Send("WhiskerStatus"); 
$reply = SendImmediate("TimerSetEvent 1000 9 TimerFired");
$reply = SendImmediate("TimerSetEvent 12000 0 EndOfTask"); 
Send("TestNetworkLatency");

# Enter a loop to listen to messages from the server.
while (chomp($line = <$MAINSOCK>)) {
	if ($DEBUGNETWORK) { print "SERVER: $line\n"; } # For info only.
	if ($line =~ /^Ping/) {
		# If the server has sent us a Ping, acknowledge it.
		Send("PingAcknowledged");
	} 
	if ($line =~ /^Event: (.+)/) {
		# The server has sent us an event.
		$event = $1;
		if ($DEBUGNETWORK) { print "EVENT RECEIVED: $event\n"; } # For info only.

		# Event handling for the behavioural task is dealt with here.
		if ($event =~ /^EndOfTask$/) { last; } # Exit the while loop.
	}
}

# Create some sample data.
# For arrays of arrays, see http://perldoc.perl.org/perldsc.html#ARRAYS-OF-ARRAYS
# For passing array references to functions, see http://www.cs.cf.ac.uk/Dave/PERL/node61.html
my $table = "table1";
my @fields = ("field1","field2","field3");
my @values = (
		[ "data1","data2","data3" ],
		[ "data4","data5","data6" ],
		[ "data7","data8","data9" ],
	);

# Write data to disk/database. Do these separately, disk first, in case there are database problems.
foreach my $i (0..$#values) {
	my @record = @{$values[$i]}; # Long-winded for illustration
	WriteRecordToCSVFile($OUTFILE, ($i == 0), \@fields, \@record);
}
foreach my $i (0..$#values) {
	SQLInsertRecord($dbh, $table, \@fields, \@{$values[$i]});
}

LogOut();
print "----------------\n";
print "Finished.\n";
exit;
 
# -----------------------------------------------------------
# --------------------------- Networking routines.
# -----------------------------------------------------------

sub ConnectBothPorts {
	my $server = shift; # Fetch first parameter
	my $mainport = shift; # Fetch next parameter

	my ($immport, $code, $line); # Declare other local variables.
	ConnectMain($server, $mainport); # Log in to the server.
	# Listen to the server until we can connect the immediate socket.
	while (chomp($line = <$MAINSOCK>)) { # chomp removes the trailing newline
		# The server has sent us a message via the main socket.
		if ($DEBUGNETWORK) { print "SERVER: $line\n"; } # Print the message, for info only.
		if ($line =~ /^ImmPort: (\d+)/) { $immport = $1; }
		if ($line =~ /^Code: (\w+)/) {
			$code = $1;
			ConnectImmediate($server, $immport, $code);
			last; # Exit the while loop.
		}
	}

	return $immport;
}

sub ConnectMain {
	my $server = shift; # Fetch first parameter.
	my $port = shift; # Fetch next parameter.

	print "Connecting main port to server.\n";
	if ($port =~ /\D/) { $port = getservbyname($port, 'tcp'); }
	die "No port" unless $port;
	my $iaddr = inet_aton($server) || die "No host: $server";
	my $paddr = sockaddr_in($port, $iaddr);
	my $proto = getprotobyname('tcp');
	socket($MAINSOCK, PF_INET, SOCK_STREAM, $proto) || die "Can't make socket: $!";
	connect($MAINSOCK, $paddr) || die "Can't connect: $!";
	print "Connected to main port $port on " . inet_ntoa($iaddr) . "\n";
	use Socket qw(IPPROTO_TCP TCP_NODELAY);
	setsockopt($MAINSOCK, IPPROTO_TCP, TCP_NODELAY, 1); # Disable the Nagle algorithm.
	$MAINSOCK->autoflush(1); # Ensure that output to the socket gets sent immediately.
}

sub ConnectImmediate {
	my $server = shift;
	my $port = shift;
	my $code = shift;

	print "Connecting immediate port to server.\n";
	if ($port =~ /\D/) { $port = getservbyname($port, 'tcp'); }
	die "No port" unless $port;
	my $iaddr = inet_aton($server) || die "No host: $server";
	my $paddr = sockaddr_in($port, $iaddr);
	my $proto = getprotobyname('tcp');
	socket($IMMSOCK, PF_INET, SOCK_STREAM, $proto) || die "Can't make socket: $!";
	connect($IMMSOCK, $paddr) || die "Can't connect: $!";
	print "Connected to immediate port $port on " . inet_ntoa($iaddr) . "\n";
	use Socket qw(IPPROTO_TCP TCP_NODELAY);
	setsockopt($IMMSOCK, IPPROTO_TCP, TCP_NODELAY, 1);
	$IMMSOCK->autoflush(1);
	SendImmediate("Link $code");
}
 
sub LogOut {
	close ($MAINSOCK) || die "Error closing main socket: $!";
	close ($IMMSOCK) || die "Error closing immediate socket: $!";
}
 
sub Send {
	# Send something to the server on the main socket, with a trailing newline.
	if ($DEBUGNETWORK) { print STDOUT "Main socket command: @_\n"; } # For info only.
	print $MAINSOCK "@_\n";
}

sub SendImmediate {
	# Send a command to the server on the immediate socket, and retrieve its reply.
	if ($DEBUGNETWORK) { print STDOUT "Immediate socket command: @_\n"; } # For info only.
	print $IMMSOCK "@_\n";
	chomp(my $reply = <$IMMSOCK>);
	if ($DEBUGNETWORK) { print STDOUT "Immediate socket reply: $reply\n"; } # For info only.
	return $reply;
}

# -----------------------------------------------------------
# --------------------------- User interface routines.
# -----------------------------------------------------------

sub AskUser {
	print "$_[0] [$_[1]]: ";
	my $rc = <>;
	chomp $rc;
	if($rc eq "") { $rc = $_[1]; }
	return $rc;
}

sub AskUserPassword {
	# http://www.perlmonks.org/?node_id=352298
	$|=1; #Turn on AutoFlush
	use Term::ReadKey;
	ReadMode('noecho');
	ReadMode('raw');
	my $pass = '';
	print "$_[0]: ";
	while (1) {
		my $c;
		1 until defined($c = ReadKey(-1));
		last if (($c eq "\n") || ($c eq "\r")); # Windows machines: Enter gives \r, not \n!
		print "*";
		$pass .= $c;
	}
	ReadMode('restore');
	print "\n";

	return $pass;
}

# -----------------------------------------------------------
# --------------------------- Database routines, using ODBC.
# -----------------------------------------------------------

sub ConnectToDatabase {
	my $driver = shift;
	my $database = shift;
	my $username = shift;
	my $password = shift;

	print "Connecting to database.\n";
	my $dbh = DBI->connect('DBI:'.$driver.':'.$database,$username,$password) or die "Failed to connect to database: $database\n"; # *** weaken "die"
	my $dbtype = $dbh->get_info(17); # 17 is DBI::SQL_DBMS_NAME
	print "Connected to database: $driver:$database. Database type is: $dbtype\n";

	return $dbh;
}

sub SQLInsertRecord {
	my $dbh = shift;
	my $table = shift;
	my $ref_fields = shift; my @fields = @{$ref_fields};
	my $ref_values = shift; my @values = @{$ref_values};

	my $fields_size = @fields;
	my $values_size = @values;
	if ($fields_size != $values_size) { die "SQLInsertRecord failed: size of fields array differs from size of values array\n"; }
	# SQL ultimately e.g. INSERT INTO table (field1, field2, field3) VALUES (value1, value2, value3);
	# but we start with INSERT INTO table (field1, field2, field3) VALUES (?, ?, ?);
	my $sqlstring = "INSERT INTO $table (";
	foreach my $i (0..$#fields) {
		if ($i > 0) { $sqlstring .= ", "; }
		$sqlstring .= $fields[$i];
	}
	$sqlstring .= ") VALUES (";
	foreach my $i (0..$#values) {
		if ($i > 0) { $sqlstring .= ", "; }
		$sqlstring .= "?";
	}
	# if ($DEBUGDATABASE) { print "SQL so far: $sqlstring\n"; }
	$sqlstring .= ");";
	my $insert_sql = $dbh->prepare($sqlstring);
	foreach my $i (0..$#values) {
		$insert_sql->bind_param($i+1, $values[$i]); # refers to the i'th ? in the query; bind_param indexed from 1, not 0
	}
    $insert_sql->execute(); # excute the SQL statement
}

# -----------------------------------------------------------
# --------------------------- Textfile results storage.
# -----------------------------------------------------------

sub WriteRecordToCSVFile {
	my $OUTFILE = shift;
	my $firstrecord = shift;
	my $ref_fields = shift; my @fields = @{$ref_fields};
	my $ref_values = shift; my @values = @{$ref_values};

	my $fields_size = @fields;
	my $values_size = @values;
	if ($fields_size != $values_size) { die "WriteRecordToCSVFile failed: size of fields array differs from size of values array\n"; }
	if ($firstrecord) { # For the first record, print the field names
		foreach my $i (0..$#fields) {
			if ($i > 0) { print $OUTFILE ","; }
			print $OUTFILE $fields[$i];
		}
		print $OUTFILE "\n";
	}
	# Print the values in comma-separated format
	# could use (0..($values-1)) or (0..$#values) to iterate through
	foreach my $i (0..$#values) {
		if ($i > 0) { print $OUTFILE ","; }
		print $OUTFILE $values[$i];
	}
	print $OUTFILE "\n";
}
