set() works. Testserver: implented "R" now.
authorHeiko Schlittermann <hs@schlittermann.de>
Tue, 06 Jan 2009 22:33:39 +0100
changeset 19 6acf8ea44e0a
parent 18 a6bc8818d069
child 20 94281ba012c8
set() works. Testserver: implented "R" now.
examples/client
lib/Quancom.pm
lib/Quancom/Result.pm
lib/Quancom/Test/Server.pm
--- 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