1 package Quancom;

     2 

     3 use strict;

     4 use warnings;

     5 use IO::Socket::INET;

     6 use Quancom::Result;

     7 

     8 my $DEFAULT_PORT = 1001;

     9 

    10 sub new {

    11     my $class = ref $_[0] ? ref shift : shift;

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

    13 

    14     $self->{peer} = shift;

    15     $self->{peer} .= ":$DEFAULT_PORT"

    16       unless $self->{peer} =~ /:\d+$/;

    17 

    18     $self->{socket} = new IO::Socket::INET(

    19         Proto    => "tcp",

    20         PeerAddr => $self->{peer}

    21     );

    22 

    23     $self->{job} = 0;

    24     $self->{ok} = undef;

    25 

    26     return $self;

    27 }

    28 

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

    30 

    31 sub cmd {

    32     my $self = shift;

    33     my $cmd  = shift;

    34 

    35     $self->_tx($cmd);

    36     $self->_rx($cmd);

    37 

    38     return $self->{last_result};

    39 }

    40 

    41 sub _tx {

    42     my $self = shift;

    43     my $cmd  = shift;

    44 

    45     $self->{job} = ++$self->{job} % 255;    # cap the job id on 255;

    46     $cmd = "\x02" . sprintf("%02x", $self->{job}) . $cmd;   # add STX and job id

    47     $cmd .= sprintf("%02x", unpack("%8C*", $cmd));          # add checksum

    48 

    49     warn "sending $cmd | " . unpack("H*", $cmd) . "\n";

    50     $self->{socket}->print($cmd . "\r");

    51 }

    52 

    53 sub _rx {

    54     my $self = shift;

    55 

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

    57     my $r = $self->{socket}->getline;    # now it's a line

    58     chomp($r);                           # we do not need the delimiter

    59 

    60     $self->{last_result} = new Quancom::Result;

    61 

    62     # decode the status

    63     if (($self->{last_result}{error_code}) = $r =~ /^E(.)/) {

    64         $self->{last_result}{ok} = 0;

    65     }

    66     elsif (my ($jobid, $data, $csum) = $r =~ /^[DO](..)(.*)(..)$/) {

    67         $self->{last_result}{ok} = 1;

    68 	$self->{last_result}{result} = defined $data ? $data : "";

    69     }

    70     else {

    71         die "unknown response $r";

    72     }

    73 

    74     return $r;

    75 }

    76 

    77 

    78 1;

    79 

    80 __END__

    81 

    82 =head1 NAME

    83 

    84 Quancom - perl module to access the usb opto quancom device

    85 

    86 =head1 SYNOPSIS

    87 

    88     use Quancom;

    89 

    90     my $q = new Quancom 172.16.0.22;

    91     my $r = $q->cmd("xxxxxx") 

    92 	or die $r->error_message;

    93 

    94 =head1 METHODS

    95 

    96 =over

    97 

    98 =item constructor B<new>( I<ip> )

    99 

   100 This method returns a new Quancom object if the connection was

   101 successfully established.

   102 

   103 =item B<send>( I<string> )

   104 

   105 Send a Quancom string to the device. The string here should be

   106 B<without> the leading STX and Jobid as well without the trailing CR.

   107 

   108 It returns TRUE on success, FALSE otherwise.

   109 

   110 =item B<last_result>( )

   111 

   112 This returns an object containing the last result.

   113 

   114 =back

   115 

   116 =head1 AUTHOR

   117 

   118     Maik Schueller

   119     Heiko Schlittermann

   120 

   121 =cut