--- /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: <STX>$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;