berlindummyserver.pl

#!/usr/bin/perl -w

# ---------------------------

# Syntax:        berlindummyserver.pl [server [port]]

# ---------------------------

# 16 May 2010

#

# 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 IO::Socket::INET;

my $numinputs = 16;

my $numoutputs = 8;

my (@inputstate, @outputstate);

for (my $i = 0; $i < $numinputs; ++$i) {

       $inputstate[$i] = 0;

}

for (my $i = 0; $i < $numoutputs; ++$i) {

       $outputstate[$i] = 0;

}

# Special

$inputstate[2]=1;

$inputstate[5]=1;

$outputstate[2]=1;

my $port = shift || 5002; # Get (main) port number or supply default (default as per York Winter's email of 17/5/10).

my ($client, $command, $reply, $channel, $duration, $state, $hostinfo); # Declare other variables.

my $DEBUGNETWORK = 1; # Controls verbose printing of network communications

my $delimiter = "\n\r"; # CR (\n), LF (\r)

print "Berlin dummy server in Perl\n";

print "---------------------------\n";

# Open network connection.

# http://www.osix.net/modules/article/?id=101

# Listen = number of pending connections; SOMAXCON is a special symbol for the system maximum

# Reuse = restart the server manually

my $server = IO::Socket::INET->new( Proto => 'tcp', LocalPort => $port, Listen => SOMAXCONN, Reuse => 1);

die "can't setup server" unless $server;

print "[Server $0 is running]\n";

# Now wait for a connection. (Can telnet to this server as a test.)

while ($client = $server->accept()) {

       $client->autoflush(1);

       my ($name, $aliases, $addrtype, $length, @addrs);

       ($name, $aliases, $addrtype, $length, @addrs) = gethostbyaddr($client->peeraddr, AF_INET);

       printf "[Connect from %s]\n", $name;

       # Enter a loop to listen to messages from the server.

       while ($command = <$client>) {

               $command =~ s/\s+$//; # remove trailing rubbish

               $command =~ s/^\s+//; # remove leading rubbish

               # don't use chomp (which only removes \n); instead, remove CR, LF, any other trailing whitespace

               # http://www.wellho.net/forum/Perl-Programming/New-line-characters-beware.html

               if ($DEBUGNETWORK) {

                       print "CLIENT: $command\n"; # For info only.

                       # print "String length = " . length($command) . "\n";

               }

               if ($command =~ /^GetNumberOfInputChannels/) {

                       Send("NumberOfInputChannels 16");

               }

               if ($command =~ /^GetNumberOfOutputChannels/) {

                       Send("NumberOfOutputChannels 8");

               }

               if ($command =~ /^SetChannelOn (.+)/) {

                       $channel = $1;

                       if ($channel >= 0 && $channel < $numinputs) {

                               $outputstate[$channel] = 1;

                               print "Output channel " . $channel . " set ON\n";

                       }

                       # Now a silly debug bit

                       if ($channel == 5 || $channel == 6) {

                               $inputstate[4] = !$inputstate[4];

                               Send("SensorState 4 " . $inputstate[4]);

                       }

                       # No response

               }

               if ($command =~ /^SetChannelOnPulse (.+) (.+)/) {

                       $channel = $1;

                       $duration = $2;

                       if ($channel >= 0 && $channel < $numinputs) {

                               $outputstate[$channel] = 1;

                               print "Output channel " . $channel . " set ON for pulse of " . $duration . " (NOT REALLY IMPLEMENTED)\n";

                               # should set it off later, but never mind ***

                       }

                       # No response

               }

               if ($command =~ /^SetChannelOff (.+)/) {

                       $channel = $1;

                       if ($channel >= 0 && $channel < $numinputs) {

                               $outputstate[$channel] = 0;

                               print "Output channel " . $channel . " set OFF\n";

                       }

                       # No response

               }

               if ($command =~ /^GetSensorState (.+)/) {

                       $channel = $1;

                       if ($channel >= 0 && $channel < $numinputs) {

                               Send("SensorState " . $channel . " " . $inputstate[$channel]);

                       }

               }

               # Can also send SensorState messages spontaneously ***        

       }

       close ($client) || die "Error closing socket: $!";

       print "[Disconnected.]\n";

}

# use CTRL-C to shut down the server

exit;

sub Send {

       # Send something to the server on the main socket, with a trailing newline.

       if ($DEBUGNETWORK) { print STDOUT "Message to client: @_\n"; } # For info only.

       print $client "@_" . $delimiter;

}

# -----------------------------------------------------------

# --------------------------- User interface routines.

# -----------------------------------------------------------

sub AskUser {

       print "$_[0] [$_[1]]: ";

       my $rc = <>;

       chomp $rc;

       if($rc eq "") { $rc = $_[1]; }

       return $rc;

}