# HG changeset patch # User heiko@jumper # Date 1231203686 -3600 # Node ID 2d41fac09084207b97515ec57e38dfc914a10130 # Parent 7ccc679ac5db343912a41b9a429f0b36acfb7050 Bit SET/CLEAR works now! diff -r 7ccc679ac5db -r 2d41fac09084 examples/client --- 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"; } diff -r 7ccc679ac5db -r 2d41fac09084 examples/test-server --- 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; diff -r 7ccc679ac5db -r 2d41fac09084 lib/Quancom.pm --- 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($_); } diff -r 7ccc679ac5db -r 2d41fac09084 lib/Quancom/Result.pm --- 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; diff -r 7ccc679ac5db -r 2d41fac09084 lib/Quancom/Test/Server.pm --- 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: $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 + +Setting of outputs 0x100 .. 0x107 + +=item B and B + +Bit-Set/Clear operations (works only on address 0x100 and 0x104) since +it always expects 32 bit! + +=back