lib/Quancom/Test/Server.pm
changeset 15 2d41fac09084
parent 14 7ccc679ac5db
child 17 ecc10b50b7a6
equal deleted inserted replaced
14:7ccc679ac5db 15:2d41fac09084
    26 use warnings;
    26 use warnings;
    27 use Carp;
    27 use Carp;
    28 use IO::Socket;
    28 use IO::Socket;
    29 use IO::Select;
    29 use IO::Select;
    30 
    30 
    31 my $STX = "\x02";
    31 my $STX   = "\x02";
       
    32 my %ERROR = (
       
    33     checksum  => pack("ac", "E", 0),
       
    34     character => pack("ac", "E", 1),
       
    35     command   => pack("ac", "E", 2),
       
    36     width     => pack("ac", "E", 3),
       
    37 );
    32 
    38 
    33 sub new {
    39 sub new {
    34     my $class = ref $_ ? ref shift : shift;
    40     my $class = ref $_ ? ref shift : shift;
    35 
    41 
    36     my $self = bless {} => $class;
    42     my $self = bless {} => $class;
    73     return $self;
    79     return $self;
    74 }
    80 }
    75 
    81 
    76 sub show {
    82 sub show {
    77     my $self = shift;
    83     my $self = shift;
    78     printf STDERR "%0v8b\n", join "", @{ $self->{outputs} };
    84     printf STDERR "%0v8b\n", join "", reverse @{ $self->{outputs} };
    79 }
    85 }
    80 
    86 
    81 sub DESTROY {
    87 sub DESTROY {
    82     my $self = shift;
    88     my $self = shift;
    83     unlink $self->{file} if $self->{file};
    89     unlink $self->{file} if $self->{file};
   115                 my $l = <$c>;
   121                 my $l = <$c>;
   116                 $s->remove($c), next if not defined $l;
   122                 $s->remove($c), next if not defined $l;
   117                 chomp $l;
   123                 chomp $l;
   118                 $l = $self->_process($l);
   124                 $l = $self->_process($l);
   119                 $c->print($l . "\r");
   125                 $c->print($l . "\r");
       
   126 		$self->show;
   120             }
   127             }
   121         }
   128         }
   122         return;
   129         return;
   123     }
   130     }
   124 
   131 
   125     # STDIO communication
   132     # STDIO communication
   126     while (<>) {
   133     while (<>) {
   127         chomp;
   134         chomp;
   128         print $self->_process($_), "\n";
   135         print $self->_process($_), "\n";
       
   136 	$self->show;
   129     }
   137     }
   130 }
   138 }
   131 
   139 
   132 sub _process {
   140 sub _process {
   133     my $self = shift;
   141     my $self = shift;
   138     $line =~ s/^$STX//;    # cut STX, if any
   146     $line =~ s/^$STX//;    # cut STX, if any
   139     $line =~ s/(..)$//;    # cut checksum
   147     $line =~ s/(..)$//;    # cut checksum
   140 
   148 
   141     warn "got: <STX>$line($1)\n" if $self->{debug};
   149     warn "got: <STX>$line($1)\n" if $self->{debug};
   142 
   150 
   143     return pack("ac", "E", 1)    # checksum error
   151     return $ERROR{checksum}
   144       if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line");
   152       if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line");
   145 
   153 
   146     my ($jid, $cmd, $width, $addr, $data) = (
   154     my ($jid, $cmd, $width, $addr, $data) = (
   147         $line =~ /
   155         $line =~ /
   148 	([\da-f]{2})	# jid
   156 	([\da-f]{2})	# jid
   153 	$/xi
   161 	$/xi
   154     );
   162     );
   155 
   163 
   156     # some transformations for more easy use
   164     # some transformations for more easy use
   157     $addr = hex($addr);
   165     $addr = hex($addr);
   158     $width =
   166     $width = $width eq "B"
   159         $width eq "B" ? 1
   167       ? 1    #  8 bit
   160       : $width eq "W" ? 2
   168       : $width eq "W" ? 2    # 16 bit
   161       : $width eq "L" ? 3
   169       : $width eq "L" ? 4    # 32 bit
   162       : $width eq "X" ? 4
   170       : $width eq "X" ? 8    # 64 bit
   163       :                 0;
   171       :                 0;
   164 
   172 
       
   173     my @data = reverse ($data =~ /(..)/g); # msb
       
   174     my $offset = $addr - 0x100;
       
   175 
   165     if ($cmd eq "W") {
   176     if ($cmd eq "W") {
   166         my @data = $data =~ /(..)/g;
   177         return $ERROR{width} if @data != $width;
   167         return pack("ac", "E", 3)    # width error
       
   168           if @data != $width;
       
   169 
       
   170         my $offset = $addr - 0x100;
       
   171 
   178 
   172         @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =
   179         @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =
   173           map { pack "C", hex($_) } @data;
   180           map { pack "C", hex($_) } @data;
   174         $self->show;
   181         return _with_checksum("O$jid");
   175 
   182     }
   176         $retval = "O$jid";
   183 
   177     }
   184     if ($cmd =~ /^[SC]$/) {
   178     else {
   185         # currently restricted to 4 byte (32bit)
   179         warn "command \"$cmd\" not supported\n";
   186         return $ERROR{command} if $width != 4;
   180         $retval = pack("ac", "E", 2);
   187         return $ERROR{width}   if @data != 4;
   181     }
   188         foreach (@{ $self->{outputs} }[ $offset .. $offset + $width - 1 ]) {
   182 
   189             if ($cmd eq "S") {
   183     return $retval . sprintf("%02x", unpack("%8C*", $retval));
   190                 $_ |= pack("C", hex(shift @data));
       
   191             }
       
   192 	    else {
       
   193 		$_ &= ~pack("C", hex(shift @data));
       
   194 	    }
       
   195         }
       
   196         return _with_checksum("O$jid");
       
   197     }
       
   198 
       
   199     warn "command \"$cmd\" not supported\n";
       
   200     return $ERROR{command};
       
   201 }
       
   202 
       
   203 sub _with_checksum {
       
   204     $_[0] . sprintf("%02x", unpack("%8C*", $_[0]));
   184 }
   205 }
   185 
   206 
   186 1;
   207 1;
   187 
   208 
   188 __END__
   209 __END__
   213     filename	    server creates and binds to the named socket
   234     filename	    server creates and binds to the named socket
   214 		    file (the file gets created by the server and
   235 		    file (the file gets created by the server and
   215 		    will be removed afterwards)
   236 		    will be removed afterwards)
   216 
   237 
   217 =back
   238 =back
       
   239 
       
   240 =head1 BUGS
       
   241 
       
   242 Not all commands/registers are implemented. Currently the following
       
   243 operations are supported:
       
   244 
       
   245 =over
       
   246 
       
   247 =item B<W>
       
   248 
       
   249 Setting of outputs 0x100 .. 0x107
       
   250 
       
   251 =item B<S> and B<C>
       
   252 
       
   253 Bit-Set/Clear operations (works only on address 0x100 and 0x104) since
       
   254 it always expects 32 bit!
       
   255 
       
   256 =back