set() works. Testserver: implented "R" now.
--- a/examples/client Tue Jan 06 15:07:03 2009 +0100
+++ b/examples/client Tue Jan 06 22:33:39 2009 +0100
@@ -12,9 +12,11 @@
my $q = new Quancom $ARGV[0];
my $r;
+ $q->set(1, 8 => 1)->ok or die $q->last_result->error_message;
+ $q->set(2, 64 => 1)->ok or die $q->last_result->error_message;
# reset
- $q->full_reset->ok or die $q->last_result->error_message;
+ $q->full_reset->ok or warn "err: " . $q->last_result->error_message . "\n";
# does not work
#$q->cmd("RB 0007")->ok or die $q->last_result->error_message;
--- a/lib/Quancom.pm Tue Jan 06 15:07:03 2009 +0100
+++ b/lib/Quancom.pm Tue Jan 06 22:33:39 2009 +0100
@@ -81,9 +81,28 @@
$self->cmd("WB 0007 00");
}
+sub set {
+ my $self = shift;
+ my $value = pop @_ ? 1 : 0;
+ my @bits = map { $_ - 1 } @_;
+ my @groups = map { 0 } 0 .. 7;
+
+ # input is a list of bits to set and the value (0/1)
+ # we'll map it to SX 0100 xx.xx.xx.xx xx.xx.xx.xx
+ foreach (@bits) {
+ my $group = int($_ / 8);
+ my $bit = $_ % 8;
+ $groups[$group] |= (1 << $bit);
+ }
+ $_ = "SX 0100 " . join "", map { sprintf "%02x ", $_ } reverse @groups;
+ $self->cmd($_);
+}
+
sub set_timeout {
my $self = shift;
- my $to = shift;
+ my $to = shift;
+
+ carp "setting timeouts does not work!";
# timeout 3 (2.8s)
# [__--.-___]
@@ -134,6 +153,7 @@
local $/ = "\r"; # CR is the delimiter
local $_ = $self->{socket}->getline;
+
# chomp; warn "<<$_>>\n";
return $self->{last_result} = new Quancom::Result($_);
}
--- a/lib/Quancom/Result.pm Tue Jan 06 15:07:03 2009 +0100
+++ b/lib/Quancom/Result.pm Tue Jan 06 22:33:39 2009 +0100
@@ -59,11 +59,13 @@
sub error_message {
my $self = shift;
+ my $e = @_ ? shift : $self->{error_code};
return undef if !@_ and $self->{ok};
+ return "unknown error" if not defined $e or $e > 3;
return +("checksum error", "character error", "invalid command",
- "invalid width")[ defined $_[0] ? $_[0] : $self->{error_code} ];
+ "invalid width")[$e];
}
1;
--- a/lib/Quancom/Test/Server.pm Tue Jan 06 15:07:03 2009 +0100
+++ b/lib/Quancom/Test/Server.pm Tue Jan 06 22:33:39 2009 +0100
@@ -34,6 +34,7 @@
character => "E1",
command => "E2",
width => "E3",
+ internal => "E4", # non offical
);
sub new {
@@ -123,7 +124,7 @@
chomp $l;
$l = $self->_process($l);
$c->print($l . "\r");
- $self->show;
+ $self->show;
}
}
return;
@@ -133,7 +134,7 @@
while (<>) {
chomp;
print $self->_process($_), "\n";
- $self->show;
+ $self->show;
}
}
@@ -170,9 +171,14 @@
: $width eq "X" ? 8 # 64 bit
: 0;
- my @data = reverse ($data =~ /(..)/g); # msb
+ my @data = reverse($data =~ /(..)/g); # msb
my $offset = $addr - 0x100;
+ if ($addr < 0x100) {
+ carp "writing to registers <= 0x100 not supported\n";
+ return $ERROR{internal};
+ }
+
if ($cmd eq "W") {
return $ERROR{width} if @data != $width;
@@ -182,20 +188,27 @@
}
if ($cmd =~ /^[SC]$/) {
- # currently restricted to 4 byte (32bit)
- return $ERROR{command} if $width != 4;
- return $ERROR{width} if @data != 4;
+
+ # currently restricted to 4 and 8 byte (32 and 64bit)
+ return $ERROR{command} if not($width == 4 or $width == 8);
+ return $ERROR{width} if not(@data == 4 or @data == 8);
foreach (@{ $self->{outputs} }[ $offset .. $offset + $width - 1 ]) {
if ($cmd eq "S") {
$_ |= pack("C", hex(shift @data));
}
- else {
- $_ &= ~pack("C", hex(shift @data));
- }
+ else {
+ $_ &= ~pack("C", hex(shift @data));
+ }
}
return _with_checksum("O$jid");
}
+ if ($cmd eq "R") {
+ my @o =
+ map { sprintf "%02X", unpack "C", $_ } reverse @{ $self->{outputs} };
+ return _with_checksum("D$jid" . join "", @o);
+ }
+
warn "command \"$cmd\" not supported\n";
return $ERROR{command};
}
@@ -253,4 +266,8 @@
Bit-Set/Clear operations (works only on address 0x100 and 0x104) since
it always expects 32 bit!
+=item B<R>
+
+Reading the outputs 0x100 .. 0x107.
+
=back