# HG changeset patch # User heiko@jumper # Date 1231090966 -3600 # Node ID ad264ee5d5baeb4bb4002bd7b47f9325bb5f26f8 # Parent 352d5517f1f2f57add1b2e93cc01408b1ecc6e2f Implemented the Quancom::Test::Server. The Server should work for the W command. It communicates on STDIO and on a UNIX socket. The UNIX socket communication currently seems to hang for no obvisous reason. I've to debug it further. diff -r 352d5517f1f2 -r ad264ee5d5ba examples/client --- /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"; +} + diff -r 352d5517f1f2 -r ad264ee5d5ba examples/example --- 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"; -} - diff -r 352d5517f1f2 -r ad264ee5d5ba examples/test-server --- /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; diff -r 352d5517f1f2 -r ad264ee5d5ba lib/Quancom.pm --- 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( I ) +=item constructor B( I ) 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( I ) @@ -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 diff -r 352d5517f1f2 -r ad264ee5d5ba lib/Quancom/Test/.perltidyrc --- /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 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;