diff -r 352d5517f1f2 -r ad264ee5d5ba lib/Quancom/Test/Server.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Quancom/Test/Server.pm Sun Jan 04 18:42:46 2009 +0100 @@ -0,0 +1,157 @@ +package Quancom::Test::Server; + +# This package is for internal use only - for testing the +# Quancom.pm module and should work like the real USB-OPTO device of +# Quancom. + +use strict; +use warnings; +use Carp; +use IO::Socket::UNIX; +use IO::Select; + +my $STX = "\x02"; + +sub new { + my $class = ref $_ ? ref shift : shift; + + my $self = bless {} => $class; + + # if there's a filename passed, then we assume it as + # the UNIX socket for communication, otherwise we communicate + # via STDIN/STDOUT + if (@_) { + $self->{fifo} = shift; + $self->{socket} = new IO::Socket::UNIX( + Listen => 1, + Local => $self->{fifo} + ) or croak "Can't create IO::Socket::UNIX: $!\n"; + warn "listening on: $self->{fifo}\n"; + } + else { + warn "listening on: stdio\n"; + } + + # we can't use 64bit as Vector (vec()), since not all platforms support it + @{ $self->{outputs} } = map { pack "c", $_ } (0, 0, 0, 0, 0, 0, 0, 0); + $self->show; + + return $self; +} + +sub show { + my $self = shift; + printf STDERR "%0v8b\n", join "", @{ $self->{outputs} }; +} + +sub DESTROY { + my $self = shift; + unlink $self->{fifo} if $self->{fifo}; +} + +sub run { + my $self = shift; + + if ($self->{socket}) { + + # It's a quick and dirty runner! + # This runner lives with the assumption, that the client always + # sends a line terminated by "\r" in one chunk. No other processing + # takes place between the first character and the final "\r", + # especially no accepting of new connections or reading of other + # connection data or sending data! + # BUT: This socket based server can talk to more than one + # client. + + my $s = new IO::Select $self->{socket}; + while (my @ready = $s->can_read) { + foreach my $c (@ready) { + + # create a new connection or process incoming + # data + + if ($c == $self->{socket}) { + my $n = $self->{socket}->accept; + $n->autoflush(1); + $s->add($n); + next; + } + + local $/ = "\r"; # quancom sends CR as line terminator + my $l = <$c>; + $s->remove($c), next if not defined $l; + chomp $l; + $l = $self->_process($l); + warn "sending $l\n"; + $self->{socket}->print($l . "\r"); + warn "done\n"; + } + } + return; + } + + # STDIO communication + while (<>) { + chomp; + print $self->_process($_), "\n"; + } +} + +sub _process { + my $self = shift; + my $line = shift; + my $retval; + + # some fixups + $line =~ s/^$STX//; # cut STX, if any + $line =~ s/(..)$//; # cut checksum + + warn "got: $line($1)\n"; + + return pack("ac", "E", 1) # checksum error + if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line"); + + my ($jid, $cmd, $width, $addr, $data) = ( + $line =~ / + ([\da-f]{2}) # jid + ((?-i)[RWSC]) # cmd + ((?-i)[BWLX]) # width + ([\da-f]{4}) # addr + (.*?) # data + $/xi + ); + + # some transformations for more easy use + $addr = hex($addr); + $width = + $width eq "B" ? 1 + : $width eq "W" ? 2 + : $width eq "L" ? 3 + : $width eq "X" ? 4 + : 0; + + if ($cmd eq "W") { + my @data = $data =~ /(..)/g; + return pack("ac", "E", 3) # width error + if @data != $width; + + my $offset = $addr - 0x100; + + warn "@data\n"; + + $self->show; + @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] = + map { pack "C", hex($_) } @data; + $self->show; + + $retval = "O$jid"; + } + else { + warn "command \"$cmd\" not supported\n"; + $retval = pack("ac", "E", 2); + } + + return $retval . sprintf("%02x", unpack("%8C*", $retval)); +} + +1;