package Quancom;

#    Quancom - a perl library module to talk to USBOPTO-XX
#    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::INET;    # FIXME: shold be loaded conditionally
use IO::Socket::UNIX;    # FIXME: shold be loaded conditionally

use Quancom::Result;

our $VERSION = 0.1;

my $DEFAULT_PORT = 1001;
my $STX          = "\x02";

sub new {
    my $class = ref $_[0] ? ref shift : shift;
    my $self = bless {} => $class;

    $self->{peer} = shift or croak "need a peer address!";

    if ($self->{peer} !~ /\//) {
        $self->{peer} .= ":$DEFAULT_PORT"
          unless $self->{peer} =~ /:\d+$/;

        $self->{socket} = new IO::Socket::INET(
            Proto    => "tcp",
            PeerAddr => $self->{peer}
        );
    }
    else {
        $self->{socket} = new IO::Socket::UNIX(Peer => $self->{peer});
    }

    $self->{socket} or croak "Can't create socket to $self->{peer}: $!\n";

    $self->{job} = 0;
    $self->{ok}  = undef;

    return $self;
}

sub last_result { $_[0]->{last_result} }

sub cmd {
    my $self = shift;
    my $cmd  = shift;

    $self->_tx($cmd);
    $self->_rx;

    return $self->{last_result};
}

sub reset {
    my $self = shift;
    $self->cmd("SL 0007 00.00.00.01");
}

sub full_reset {
    my $self = shift;
    $self->reset->ok or return $self->{last_result};
    $self->cmd("WB 0007 00");
}

sub set {
    my $self = shift;
    croak "bad usage" if @_ < 2;

    my $value = pop @_ ? 1 : 0;
    my @bits   = map { $_ - 1 } @_;
    my @groups = map { 0 } 0 .. 7;

    # input is a list of bits to set and the value (0/1)
    # we'll map it to SX 0100 xx.xx.xx.xx xx.xx.xx.xx
    foreach (@bits) {
        my $group = int($_ / 8);
        my $bit   = $_ % 8;
        $groups[$group] |= (1 << $bit);
    }

    my $cmd = $value ? "S" : "C";

    # could be optimized to only include the bytes we're interested
    # in
    $cmd .= "X 0100";
    $cmd .= join "", map { sprintf "%02x ", $_ } reverse @groups;
    $self->cmd($cmd);
}

sub on { push @_, 1; goto \&set }

sub off { push @_, 0; goto \&set }

sub get {
    my $self = shift;
    my @bits = map { $_ - 1 } @_;

    # could be optimized to only include the bytes we're interested
    # in
    $self->cmd("RX 0100")->ok
      or return undef;
    my @groups = reverse map { hex } ($self->last_result->data =~ /../g);

    my @r;

    foreach (@bits) {
        my $group = int($_ / 8);
        my $bit   = $_ % 8;
        push @r, $groups[$group] & (1 << $bit) ? 1 : 0;
    }

    return @bits == 1 ? $r[0] : @r;
}

sub set_timeout {
    my $self = shift;
    my $to   = shift;

    carp "setting timeouts does not work!";

    # timeout 3 (2.8s)
    # [__--.-___]
    #     1 1	    0x18
    #   1           0x58
    $to = sprintf "%02x", ($to << 3 | 0x42);
    $self->cmd("SL 0007 00.00.00.$to");
}

sub clear_timeout {
}

sub _tx {
    my $self = shift;
    my $cmd  = shift;

    $cmd =~ s/[^A-Z\d]//ig;

    $self->{job} = ++$self->{job} % 255;    # cap the job id on 255;
    $cmd = $STX . sprintf("%02x", $self->{job}) . $cmd;    # add STX and job id
    $cmd .= sprintf("%02x", unpack("%8C*", $cmd));         # add checksum

    $cmd =~ /^.(..)(......)(.*)(..)/;
    warn "sending $1 $2 $3 ($4)\n";
    $self->{socket}->print($cmd . "\r");
}

sub _rx {
    my $self = shift;

    local $/ = "\r";                                       # CR is the delimiter

    local $_ = $self->{socket}->getline;

    # chomp; warn "<<$_>>\n";
    return $self->{last_result} = new Quancom::Result($_);
}

sub TIEARRAY {
    my $class = shift;
    my $self = new Quancom @_;
    return $self;
}

sub STORE {
    my $self = shift;
    warn "@_\n";
    my ($bit, $value) = @_;
    $self->set($bit + 1, $value)->ok and return $value;
    croak "can't set bit $bit to $value";
}

sub FETCH {
    my $self = shift;
    warn "@_\n";
    my $bit = $_[0];
    my $value;
    defined($value = $self->get($bit + 1))
	and return $value;

    croak "can't get bit $bit\n";
}

sub PUSH {
    my $self = shift;
    warn "@_\n";
    my @a;
    @a[0..62] = $self->get(2..64);
    $a[63] = $_[0];
    $self->set(@a);
    return $self->FETCHSIZE;
}

sub FETCHSIZE {
    my $self = shift;
    return 64;
}

1;

__END__

=head1 NAME

Quancom - perl module to access the usb opto quancom device

=head1 SYNOPSIS

    use Quancom;

    my $quancom = new Quancom "172.16.0.22";
    my $result  = $q->cmd("xxxxxx");
    if ($result->error) { die $result->error_message } 
    else { print $result->data }

    $q->set(1 .. 64 => 1);  # switch on all the lights


=head1 METHODS

=over

=item constructor B<new>( I<ip or socket name> )

This method returns a new Quancom object if the connection was
successfully established. For testing you may use "0.0.0.0" as address,
this disables the socket communication and just simulates the Quancom
module.

=item B<set>( $bit, ... => $value )

This sets one or more bits the specified values (true, false).

=item B<get>( $bit, ... )

Return the values of the specified bits. If you provide a list of bits,
you'll get a list of values, if you provide just a single bit, you'll
get a single scalar only. On error it returns B<undef>. So for a single
scalar you've to check carefully if you got 0 or undef.

=item B<on>( $bit, ... )

=item B<off>( $bit, ... )

Both are just shortcuts for L<set>().

=item B<cmd>( I<string> )

Send a Quancom string to the device. The string here should be
B<without> the leading STX and Jobid as well without the trailing CR.
It returns a L<Quancom::Result> object.

The only tested I<string> is currently "WB0101FF", which should set
all bits on the first relais. Some other (untested) string for setting
just the lowest bit on the first relais should be "WB010001".

B<Note:> This function is provided for functionality not covered by the
above L<set()> function. Whenever possible, you should avoid using this
L<cmd()>, since it binds you tightly to the specific hardware.

=item B<reset>( )

This resets the device by setting the reset control flag.
B<Note:> It doesn't reset timeouts etc. To reset these, use
L<full_reset()>.

=item B<full_reset>( )

This clears the outputs AND resets timeouts by writing zero 
to all control bits.

=item B<last_result>( )

This returns an object containing the last result.
See L<Quancom::Result> for more information.

=back

=head1 EXAMPLES

    use Quancom;
    my $quancom = new Quancom("172.20.20.1");

    my $result;
    
    $result = $quancom->set(1, 7 => 1);
    die $quancom->error_message if $quancom->error;

    $result = $quancom->set(23 => 0);
    die $quancom->error_message if not $quancom->ok;

    $quancom->set(12 => 1);
    $result = $quancom->last_result;
    die $quancom->error_message if not $quancom->ok;

    $quancom->set(1..63 => 1)->ok 
	or die $quancom->last_result->error_message;

    $quancom->on(33);
    $quancom->off(33);

    @a = $quancom->get(1..64) or 
	die $quancom->last_result->error_message;
    ($a23, $a34) = $quancom->get(23, 34);

    defined($a = $quancom->get(12))
	or die $quancom->last_result->error_message;

=head1 SEE ALSO

L<Quancom::Result>

=head1 AUTHOR

    Maik Schueller <maik.schueller@o3si.de>
    Heiko Schlittermann <hs@schlittermann.de>

=head1 THANKS

Thanks to Mr. van den Berg from Quancom for his support.

=cut
