package Quancom::Test::Server;

# This package is for internal use only - for testing the
# Quancom.pm module and should work like the real USB-OPTO device of
# Quancom.

#    Quancom test/simulator server
#    Copyright (C) 2008  Heiko Schlittermann
#
#    This program is free software: you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation, either version 3 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
#    Heiko Schlittermann <hs@schlittermann.de>

use strict;
use warnings;
use Carp;
use IO::Socket;
use IO::Select;

my $STX   = "\x02";
my %ERROR = (
    checksum  => "E0",
    character => "E1",
    command   => "E2",
    width     => "E3",
    internal  => "E4",    # non offical
);

sub new {
    my $class = ref $_ ? ref shift : shift;

    my $self = bless {} => $class;
    my $addr = shift or croak "need socket address";

    $self->{debug} = 0;

    # if there's a parameter passed we understand it as
    # a socket address for communication
    if ($addr eq "-") {
        warn "listening on: stdio\n";
    }
    else {
        if ($addr =~ /\//) {
            $self->{file}   = $addr;
            $self->{socket} = new IO::Socket::UNIX(
                Listen => 1,
                Local  => $self->{file}
            ) or croak "Can't create IO::Socket::UNIX: $!\n";
        }
        else {
            $addr = "127.0.0.1:$1" if $addr =~ /^:?(\d+)/;

            $self->{socket} = new IO::Socket::INET(
                Listen    => 1,
                ReuseAddr => 1,
                LocalAddr => $addr
            ) or croak "Can't create IO::Socket::INET: $!\n";
        }

        warn "listening on: $addr\n";
    }

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

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

    return $self;
}

sub show {
    my $self = shift;
    printf STDERR "%0v8b\n", join "", reverse @{ $self->{outputs} };
}

sub DESTROY {
    my $self = shift;
    unlink $self->{file} if $self->{file};
}

sub run {
    my $self = shift;

    if ($self->{socket}) {

        # It's a quick and dirty runner!
        # This runner lives with the assumption, that the client always
        # sends a line terminated by "\r" in one chunk. No other processing
        # takes place between the first character and the final "\r",
        # especially no accepting of new connections or reading of other
        # connection data or sending data!
        # BUT: This socket based server can talk to more than one
        # client.

        my $s = new IO::Select $self->{socket};
        while (my @ready = $s->can_read) {
            foreach my $c (@ready) {

                # create a new connection or process incoming
                # data

                if ($c == $self->{socket}) {
                    my $n = $self->{socket}->accept;
                    $n->autoflush(1);
                    $s->add($n);
                    next;
                }

                local $/ = "\r";    # quancom sends CR as line terminator
                my $l = <$c>;
                $s->remove($c), next if not defined $l;
                chomp $l;
                $l = $self->_process($l);
                $c->print($l . "\r");
                $self->show;
            }
        }
        return;
    }

    # STDIO communication
    while (<>) {
        chomp;
        print $self->_process($_), "\n";
        $self->show;
    }
}

sub _process {
    my $self = shift;
    my $line = shift;
    my $retval;

    # some fixups
    $line =~ s/^$STX//;    # cut STX, if any
    $line =~ s/(..)$//;    # cut checksum

    warn "got: <STX>$line($1)\n" if $self->{debug};

    return $ERROR{checksum}
      if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line");

    my ($jid, $cmd, $width, $addr, $data) = (
        $line =~ /
	([\da-f]{2})	# jid
	((?-i)[RWSC])	# cmd
	((?-i)[BWLX])	# width
	([\da-f]{4})	# addr
	(.*?)		# data
	$/xi
    );

    # some transformations for more easy use
    $addr = hex($addr);
    $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 ($addr < 0x100) {
        carp "writing to registers <= 0x100 not supported\n";
        return $ERROR{internal};
    }

    if ($cmd eq "W") {
        return $ERROR{width} if @data != $width;

        @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] =
          map { pack "C", hex($_) } @data;
        return _with_checksum("O$jid");
    }

    if ($cmd =~ /^[SC]$/) {

        # 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));
            }
        }
        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};
}

sub _with_checksum {
    $_[0] . sprintf("%02x", unpack("%8C*", $_[0]));
}

1;

__END__

=head1 NAME

Quancom::Test::Server

=head1 SYNOPSIS

    use Quancom::Test::Server;

    my $server = new Quancom::Test::Server "/tmp/socket";
    $server->run();

=head1 METHODS

=over

=item constructor B<new>( I<$address> )

This creates a new server on the I<$address>. The I<$address> may be one
of the following:

    "-"		    server communications on STDIN/STDOUT
    [address:]port  server binds to port I<port> on address I<address>
		    or 0.0.0.0
    filename	    server creates and binds to the named socket
		    file (the file gets created by the server and
		    will be removed afterwards)

=back

=head1 BUGS

Not all commands/registers are implemented. Currently the following
operations are supported:

=over

=item B<W>

Setting of outputs 0x100 .. 0x107

=item B<S> and B<C>

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
