--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/client	Sun Jan 04 18:42:46 2009 +0100
@@ -0,0 +1,38 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+use Quancom;
+use Data::Dumper;
+# use blib;
+
+MAIN: {
+    my $q = new Quancom $ARGV[0];
+
+    my $r;
+
+    # switch on/off all lights on the first relais
+    $r = $q->cmd("WB0100FF");
+    print $r->ok ? $r->data : $r->error, "\n";
+
+    sleep 1;
+    $r = $q->cmd("WB010000");
+    print $r->ok ? $r->data : $r->error, "\n";
+
+    sleep 1;
+    $r = $q->cmd("WB010001");	# 1 bit setzen
+    print $r->ok ? $r->data : $r->error, "\n";
+
+    sleep 1;
+    $r = $q->cmd("WB010055");	# 0101|0101
+    print $r->ok ? $r->data : $r->error, "\n";
+
+    sleep 1;
+    $r = $q->cmd("WB0100AA");	# 1010|1010
+    print $r->ok ? $r->data : $r->error, "\n";
+
+    sleep 1;
+    $r = $q->cmd("SL010000000055");	# + 0101|0101
+    print $r->ok ? $r->data : $r->error, "\n";
+}
+

--- a/examples/example	Thu Dec 25 11:23:35 2008 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-#! /usr/bin/perl
-
-use strict;
-use warnings;
-use Quancom;
-use Data::Dumper;
-# use blib;
-
-MAIN: {
-    my $q = new Quancom $ARGV[0];
-
-    my $r;
-
-    # switch on/off all lights on the first relais
-    $r = $q->cmd("WB0100FF");
-    print $r->ok ? $r->data : $r->error, "\n";
-
-    sleep 1;
-    $r = $q->cmd("WB010000");
-    print $r->ok ? $r->data : $r->error, "\n";
-
-    sleep 1;
-    $r = $q->cmd("WB010001");	# 1 bit setzen
-    print $r->ok ? $r->data : $r->error, "\n";
-
-    sleep 1;
-    $r = $q->cmd("WB010055");	# 0101|0101
-    print $r->ok ? $r->data : $r->error, "\n";
-
-    sleep 1;
-    $r = $q->cmd("WB0100AA");	# 1010|1010
-    print $r->ok ? $r->data : $r->error, "\n";
-
-    sleep 1;
-    $r = $q->cmd("SL010000000055");	# + 0101|0101
-    print $r->ok ? $r->data : $r->error, "\n";
-}
-

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/test-server	Sun Jan 04 18:42:46 2009 +0100
@@ -0,0 +1,23 @@
+#! /usr/bin/perl
+
+# This is no real example, it is just for testing the
+# server. And the server is just for testing the Quancom.pm.
+# So - it's almost of no use for you :)
+
+use strict;
+use warnings;
+use POSIX qw(tmpnam);
+use Getopt::Long;
+
+use blib;
+use Quancom::Test::Server;
+
+$SIG{INT} = sub { warn "got INT, exit now\n"; exit 0; };
+
+my $opt_socket = 0;
+
+GetOptions("socket!" => \$opt_socket)
+  or die "wrong option!\n";
+
+my $server = new Quancom::Test::Server $opt_socket ? tmpnam() : ();
+$server->run;

--- a/lib/Quancom.pm	Thu Dec 25 11:23:35 2008 +0100
+++ b/lib/Quancom.pm	Sun Jan 04 18:42:46 2009 +0100
@@ -21,7 +21,8 @@
 use strict;
 use warnings;
 use Carp;
-use IO::Socket::INET;
+use IO::Socket::INET;    # FIXME: shold be loaded conditionally
+use IO::Socket::UNIX;    # FIXME: shold be loaded conditionally
 
 use Quancom::Result;
 
@@ -34,13 +35,21 @@
     my $self = bless {} => $class;
 
     $self->{peer} = shift or croak "need a peer address!";
-    $self->{peer} .= ":$DEFAULT_PORT"
-      unless $self->{peer} =~ /:\d+$/;
+
+    if ($self->{peer} !~ /\//) {
+        $self->{peer} .= ":$DEFAULT_PORT"
+          unless $self->{peer} =~ /:\d+$/;
 
-    $self->{socket} = new IO::Socket::INET(
-        Proto    => "tcp",
-        PeerAddr => $self->{peer}
-    );
+        $self->{socket} = new IO::Socket::INET(
+            Proto    => "tcp",
+            PeerAddr => $self->{peer}
+        );
+    }
+    else {
+        $self->{socket} = new IO::Socket::UNIX(Peer => $self->{peer});
+    }
+
+    $self->{socket} or croak "Can't create socket to $self->{peer}: $!\n";
 
     $self->{job} = 0;
     $self->{ok}  = undef;
@@ -60,6 +69,23 @@
     return $self->{last_result};
 }
 
+sub TIESCALAR {
+    my $class = shift;
+    my ($ip)  = @_;
+    my $self  = bless {} => $class;
+    warn "tied to ip $ip\n";
+
+    return $self;
+}
+
+sub STORE {
+    my $self = shift;
+    my ($key, $value) = @_;
+
+    #croak "invalid value \"$value\" (should be 0 or 1)\n";
+    warn "Set $key to $value\n";
+}
+
 sub _tx {
     my $self = shift;
     my $cmd  = shift;
@@ -68,7 +94,7 @@
     $cmd = "\x02" . sprintf("%02x", $self->{job}) . $cmd;   # add STX and job id
     $cmd .= sprintf("%02x", unpack("%8C*", $cmd));          # add checksum
 
-    warn "sending $cmd | " . unpack("H*", $cmd) . "\n";
+    warn "sending $cmd\n";
     $self->{socket}->print($cmd . "\r");
 }
 
@@ -91,7 +117,7 @@
 
     use Quancom;
 
-    my $quancom = new Quancom 172.16.0.22;
+    my $quancom = new Quancom "172.16.0.22";
     my $result  = $q->cmd("xxxxxx");
     if ($result->error) { die $result->error_message } 
     else { print $result->data }
@@ -101,10 +127,12 @@
 
 =over
 
-=item constructor B<new>( I<ip> )
+=item constructor B<new>( I<ip or socket name> )
 
 This method returns a new Quancom object if the connection was
-successfully established.
+successfully established. For testing you may use "0.0.0.0" as address,
+this disables the socket communication and just simulates the Quancom
+module.
 
 =item B<cmd>( I<string> )
 
@@ -126,7 +154,7 @@
 =head1 MORE EXAMPLES
 
     use Quancom;
-    my $quancom = new Quancom(172.20.20.1);
+    my $quancom = new Quancom("172.20.20.1");
     die "Sorry" if $quancom->cmd("xxxx")->error;
 
 =head1 SEE ALSO

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/Quancom/Test/.perltidyrc	Sun Jan 04 18:42:46 2009 +0100
@@ -0,0 +1,1 @@
+../../.perltidyrc
\ No newline at end of file

--- /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;