--- a/examples/client Mon Jan 05 21:44:56 2009 +0100
+++ b/examples/client Tue Jan 06 02:01:26 2009 +0100
@@ -1,5 +1,8 @@
#! /usr/bin/perl
+# should probably called on blib environment:
+# perl -Mblib examples/client ...
+
use strict;
use warnings;
use Quancom;
@@ -12,26 +15,34 @@
# switch on/off all lights on the first relais
$r = $q->cmd("WB0100FF");
- print $r->ok ? $r->data : $r->error, "\n";
+ print $r->ok ? $r->data : $r->error_message, "\n";
sleep 1;
$r = $q->cmd("WB010000");
- print $r->ok ? $r->data : $r->error, "\n";
+ print $r->ok ? $r->data : $r->error_message, "\n";
sleep 1;
$r = $q->cmd("WB010001"); # 1 bit setzen
- print $r->ok ? $r->data : $r->error, "\n";
+ print $r->ok ? $r->data : $r->error_message, "\n";
sleep 1;
$r = $q->cmd("WB010055"); # 0101|0101
- print $r->ok ? $r->data : $r->error, "\n";
+ print $r->ok ? $r->data : $r->error_message, "\n";
sleep 1;
$r = $q->cmd("WB0100AA"); # 1010|1010
- print $r->ok ? $r->data : $r->error, "\n";
+ print $r->ok ? $r->data : $r->error_message, "\n";
+
+ sleep 1;
+ $r = $q->cmd("WW0100AAAA"); # 1010|1010 1010|1010
+ print $r->ok ? $r->data : $r->error_message, "\n";
sleep 1;
- $r = $q->cmd("SL010000000055"); # + 0101|0101
- print $r->ok ? $r->data : $r->error, "\n";
+ $r = $q->cmd("SL010000550055"); # + 1010|1010 0000|0000 0101|0101
+ print $r->ok ? $r->data : $r->error_message, "\n";
+
+ sleep 1;
+ $r = $q->cmd("CL010000000055"); # - 0101|0101
+ print $r->ok ? $r->data : $r->error_message, "\n";
}
--- a/examples/test-server Mon Jan 05 21:44:56 2009 +0100
+++ b/examples/test-server Tue Jan 06 02:01:26 2009 +0100
@@ -3,6 +3,9 @@
# 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 :)
+#
+# should be called in blib environment:
+# perl -Mblib examples/test-server ...
use strict;
use warnings;
--- a/lib/Quancom.pm Mon Jan 05 21:44:56 2009 +0100
+++ b/lib/Quancom.pm Tue Jan 06 02:01:26 2009 +0100
@@ -104,7 +104,6 @@
local $/ = "\r"; # CR is the delimiter
local $_ = $self->{socket}->getline;
- #chomp; warn "got:<$_>\n";
$self->{last_result} = new Quancom::Result($_);
}
--- a/lib/Quancom/Result.pm Mon Jan 05 21:44:56 2009 +0100
+++ b/lib/Quancom/Result.pm Tue Jan 06 02:01:26 2009 +0100
@@ -27,7 +27,8 @@
$r =~ s/\s*$//; # should match any \r or \n too
# decode the status
- if (($self->{error_code}) = $r =~ /^E(.)/) {
+ if ((my $e) = $r =~ /^E(.)/) {
+ $self->{error_code} = unpack("C", $e);
$self->{ok} = 0;
}
elsif (my ($jobid, $data, $csum) = $r =~ /^[DO](..)(.*)(..)$/) {
@@ -62,8 +63,8 @@
return undef if !@_ and $self->{ok};
- return ("checksum error", "character error", "invalid command",
- "invalid width")[ @_ ? $_[0] : $self->{error_code} ];
+ return +("checksum error", "character error", "invalid command",
+ "invalid width")[ defined $_[0] ? $_[0] : $self->{error_code} ];
}
1;
--- a/lib/Quancom/Test/Server.pm Mon Jan 05 21:44:56 2009 +0100
+++ b/lib/Quancom/Test/Server.pm Tue Jan 06 02:01:26 2009 +0100
@@ -28,7 +28,13 @@
use IO::Socket;
use IO::Select;
-my $STX = "\x02";
+my $STX = "\x02";
+my %ERROR = (
+ checksum => pack("ac", "E", 0),
+ character => pack("ac", "E", 1),
+ command => pack("ac", "E", 2),
+ width => pack("ac", "E", 3),
+);
sub new {
my $class = ref $_ ? ref shift : shift;
@@ -75,7 +81,7 @@
sub show {
my $self = shift;
- printf STDERR "%0v8b\n", join "", @{ $self->{outputs} };
+ printf STDERR "%0v8b\n", join "", reverse @{ $self->{outputs} };
}
sub DESTROY {
@@ -117,6 +123,7 @@
chomp $l;
$l = $self->_process($l);
$c->print($l . "\r");
+ $self->show;
}
}
return;
@@ -126,6 +133,7 @@
while (<>) {
chomp;
print $self->_process($_), "\n";
+ $self->show;
}
}
@@ -140,7 +148,7 @@
warn "got: <STX>$line($1)\n" if $self->{debug};
- return pack("ac", "E", 1) # checksum error
+ return $ERROR{checksum}
if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line");
my ($jid, $cmd, $width, $addr, $data) = (
@@ -155,32 +163,45 @@
# 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
+ $width = $width eq "B"
+ ? 1 # 8 bit
+ : $width eq "W" ? 2 # 16 bit
+ : $width eq "L" ? 4 # 32 bit
+ : $width eq "X" ? 8 # 64 bit
: 0;
+ my @data = reverse ($data =~ /(..)/g); # msb
+ my $offset = $addr - 0x100;
+
if ($cmd eq "W") {
- my @data = $data =~ /(..)/g;
- return pack("ac", "E", 3) # width error
- if @data != $width;
-
- my $offset = $addr - 0x100;
+ return $ERROR{width} if @data != $width;
@{ $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 _with_checksum("O$jid");
}
- return $retval . sprintf("%02x", unpack("%8C*", $retval));
+ if ($cmd =~ /^[SC]$/) {
+ # currently restricted to 4 byte (32bit)
+ return $ERROR{command} if $width != 4;
+ return $ERROR{width} if @data != 4;
+ foreach (@{ $self->{outputs} }[ $offset .. $offset + $width - 1 ]) {
+ if ($cmd eq "S") {
+ $_ |= pack("C", hex(shift @data));
+ }
+ else {
+ $_ &= ~pack("C", hex(shift @data));
+ }
+ }
+ return _with_checksum("O$jid");
+ }
+
+ warn "command \"$cmd\" not supported\n";
+ return $ERROR{command};
+}
+
+sub _with_checksum {
+ $_[0] . sprintf("%02x", unpack("%8C*", $_[0]));
}
1;
@@ -215,3 +236,21 @@
will be removed afterwards)
=back
+
+=head1 BUGS
+
+Not all commands/registers are implemented. Currently the following
+operations are supported:
+
+=over
+
+=item B<W>
+
+Setting of outputs 0x100 .. 0x107
+
+=item B<S> and B<C>
+
+Bit-Set/Clear operations (works only on address 0x100 and 0x104) since
+it always expects 32 bit!
+
+=back