1 package Quancom::Test::Server;

     2 

     3 # This package is for internal use only - for testing the

     4 # Quancom.pm module and should work like the real USB-OPTO device of

     5 # Quancom.

     6 

     7 use strict;

     8 use warnings;

     9 use Carp;

    10 use IO::Socket::UNIX;

    11 use IO::Select;

    12 

    13 my $STX = "\x02";

    14 

    15 sub new {

    16     my $class = ref $_ ? ref shift : shift;

    17 

    18     my $self = bless {} => $class;

    19 

    20     # if there's a filename passed, then we assume it as

    21     # the UNIX socket for communication, otherwise we communicate

    22     # via STDIN/STDOUT

    23     if (@_) {

    24         $self->{fifo}   = shift;

    25         $self->{socket} = new IO::Socket::UNIX(

    26             Listen => 1,

    27             Local  => $self->{fifo}

    28         ) or croak "Can't create IO::Socket::UNIX: $!\n";

    29         warn "listening on: $self->{fifo}\n";

    30     }

    31     else {

    32         warn "listening on: stdio\n";

    33     }

    34 

    35     # we can't use 64bit as Vector (vec()), since not all platforms support it

    36     @{ $self->{outputs} } = map { pack "c", $_ } (0, 0, 0, 0, 0, 0, 0, 0);

    37     $self->show;

    38 

    39     return $self;

    40 }

    41 

    42 sub show {

    43     my $self = shift;

    44     printf STDERR "%0v8b\n", join "", @{ $self->{outputs} };

    45 }

    46 

    47 sub DESTROY {

    48     my $self = shift;

    49     unlink $self->{fifo} if $self->{fifo};

    50 }

    51 

    52 sub run {

    53     my $self = shift;

    54 

    55     if ($self->{socket}) {

    56 

    57         # It's a quick and dirty runner!

    58         # This runner lives with the assumption, that the client always

    59         # sends a line terminated by "\r" in one chunk. No other processing

    60         # takes place between the first character and the final "\r",

    61         # especially no accepting of new connections or reading of other

    62         # connection data or sending data!

    63         # BUT: This socket based server can talk to more than one

    64         # client.

    65 

    66         my $s = new IO::Select $self->{socket};

    67         while (my @ready = $s->can_read) {

    68             foreach my $c (@ready) {

    69 

    70                 # create a new connection or process incoming

    71                 # data

    72 

    73                 if ($c == $self->{socket}) {

    74 		    my $n = $self->{socket}->accept;

    75 		    $n->autoflush(1);

    76                     $s->add($n);

    77                     next;

    78                 }

    79 

    80                 local $/ = "\r";    # quancom sends CR as line terminator

    81                 my $l = <$c>;

    82                 $s->remove($c), next if not defined $l;

    83                 chomp $l;

    84 		$l = $self->_process($l);

    85 		warn "sending $l\n";

    86                 $self->{socket}->print($l . "\r");

    87 		warn "done\n";

    88             }

    89         }

    90         return;

    91     }

    92 

    93     # STDIO communication

    94     while (<>) {

    95         chomp;

    96         print $self->_process($_), "\n";

    97     }

    98 }

    99 

   100 sub _process {

   101     my $self = shift;

   102     my $line = shift;

   103     my $retval;

   104 

   105     # some fixups

   106     $line =~ s/^$STX//;    # cut STX, if any

   107     $line =~ s/(..)$//;    # cut checksum

   108 

   109     warn "got: <STX>$line($1)\n";

   110 

   111     return pack("ac", "E", 1)    # checksum error

   112       if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line");

   113 

   114     my ($jid, $cmd, $width, $addr, $data) = (

   115         $line =~ /

   116 	([\da-f]{2})	# jid

   117 	((?-i)[RWSC])	# cmd

   118 	((?-i)[BWLX])	# width

   119 	([\da-f]{4})	# addr

   120 	(.*?)		# data

   121 	$/xi

   122     );

   123 

   124     # some transformations for more easy use

   125     $addr = hex($addr);

   126     $width =

   127         $width eq "B" ? 1

   128       : $width eq "W" ? 2

   129       : $width eq "L" ? 3

   130       : $width eq "X" ? 4

   131       :                 0;

   132 

   133     if ($cmd eq "W") {

   134         my @data = $data =~ /(..)/g;

   135         return pack("ac", "E", 3)    # width error

   136           if @data != $width;

   137 

   138         my $offset = $addr - 0x100;

   139 

   140 	warn "@data\n";

   141 

   142         $self->show;

   143         @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =

   144           map { pack "C", hex($_) } @data;

   145         $self->show;

   146 

   147 	$retval = "O$jid";

   148     }

   149     else {

   150 	warn "command \"$cmd\" not supported\n";

   151 	$retval = pack("ac", "E", 2);

   152     }

   153 

   154     return $retval . sprintf("%02x", unpack("%8C*", $retval));

   155 }

   156 

   157 1;