whisker_perl_demo.pl

#!/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";

}