lib/Quancom/Test/Server.pm
changeset 19 6acf8ea44e0a
parent 17 ecc10b50b7a6
equal deleted inserted replaced
18:a6bc8818d069 19:6acf8ea44e0a
    32 my %ERROR = (
    32 my %ERROR = (
    33     checksum  => "E0",
    33     checksum  => "E0",
    34     character => "E1",
    34     character => "E1",
    35     command   => "E2",
    35     command   => "E2",
    36     width     => "E3",
    36     width     => "E3",
       
    37     internal  => "E4",    # non offical
    37 );
    38 );
    38 
    39 
    39 sub new {
    40 sub new {
    40     my $class = ref $_ ? ref shift : shift;
    41     my $class = ref $_ ? ref shift : shift;
    41 
    42 
   121                 my $l = <$c>;
   122                 my $l = <$c>;
   122                 $s->remove($c), next if not defined $l;
   123                 $s->remove($c), next if not defined $l;
   123                 chomp $l;
   124                 chomp $l;
   124                 $l = $self->_process($l);
   125                 $l = $self->_process($l);
   125                 $c->print($l . "\r");
   126                 $c->print($l . "\r");
   126 		$self->show;
   127                 $self->show;
   127             }
   128             }
   128         }
   129         }
   129         return;
   130         return;
   130     }
   131     }
   131 
   132 
   132     # STDIO communication
   133     # STDIO communication
   133     while (<>) {
   134     while (<>) {
   134         chomp;
   135         chomp;
   135         print $self->_process($_), "\n";
   136         print $self->_process($_), "\n";
   136 	$self->show;
   137         $self->show;
   137     }
   138     }
   138 }
   139 }
   139 
   140 
   140 sub _process {
   141 sub _process {
   141     my $self = shift;
   142     my $self = shift;
   168       : $width eq "W" ? 2    # 16 bit
   169       : $width eq "W" ? 2    # 16 bit
   169       : $width eq "L" ? 4    # 32 bit
   170       : $width eq "L" ? 4    # 32 bit
   170       : $width eq "X" ? 8    # 64 bit
   171       : $width eq "X" ? 8    # 64 bit
   171       :                 0;
   172       :                 0;
   172 
   173 
   173     my @data = reverse ($data =~ /(..)/g); # msb
   174     my @data = reverse($data =~ /(..)/g);    # msb
   174     my $offset = $addr - 0x100;
   175     my $offset = $addr - 0x100;
       
   176 
       
   177     if ($addr < 0x100) {
       
   178         carp "writing to registers <= 0x100 not supported\n";
       
   179         return $ERROR{internal};
       
   180     }
   175 
   181 
   176     if ($cmd eq "W") {
   182     if ($cmd eq "W") {
   177         return $ERROR{width} if @data != $width;
   183         return $ERROR{width} if @data != $width;
   178 
   184 
   179         @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =
   185         @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =
   180           map { pack "C", hex($_) } @data;
   186           map { pack "C", hex($_) } @data;
   181         return _with_checksum("O$jid");
   187         return _with_checksum("O$jid");
   182     }
   188     }
   183 
   189 
   184     if ($cmd =~ /^[SC]$/) {
   190     if ($cmd =~ /^[SC]$/) {
   185         # currently restricted to 4 byte (32bit)
   191 
   186         return $ERROR{command} if $width != 4;
   192         # currently restricted to 4 and 8 byte (32 and 64bit)
   187         return $ERROR{width}   if @data != 4;
   193         return $ERROR{command} if not($width == 4 or $width == 8);
       
   194         return $ERROR{width}   if not(@data == 4  or @data == 8);
   188         foreach (@{ $self->{outputs} }[ $offset .. $offset + $width - 1 ]) {
   195         foreach (@{ $self->{outputs} }[ $offset .. $offset + $width - 1 ]) {
   189             if ($cmd eq "S") {
   196             if ($cmd eq "S") {
   190                 $_ |= pack("C", hex(shift @data));
   197                 $_ |= pack("C", hex(shift @data));
   191             }
   198             }
   192 	    else {
   199             else {
   193 		$_ &= ~pack("C", hex(shift @data));
   200                 $_ &= ~pack("C", hex(shift @data));
   194 	    }
   201             }
   195         }
   202         }
   196         return _with_checksum("O$jid");
   203         return _with_checksum("O$jid");
       
   204     }
       
   205 
       
   206     if ($cmd eq "R") {
       
   207         my @o =
       
   208           map { sprintf "%02X", unpack "C", $_ } reverse @{ $self->{outputs} };
       
   209         return _with_checksum("D$jid" . join "", @o);
   197     }
   210     }
   198 
   211 
   199     warn "command \"$cmd\" not supported\n";
   212     warn "command \"$cmd\" not supported\n";
   200     return $ERROR{command};
   213     return $ERROR{command};
   201 }
   214 }
   251 =item B<S> and B<C>
   264 =item B<S> and B<C>
   252 
   265 
   253 Bit-Set/Clear operations (works only on address 0x100 and 0x104) since
   266 Bit-Set/Clear operations (works only on address 0x100 and 0x104) since
   254 it always expects 32 bit!
   267 it always expects 32 bit!
   255 
   268 
       
   269 =item B<R>
       
   270 
       
   271 Reading the outputs 0x100 .. 0x107.
       
   272 
   256 =back
   273 =back