1 package Quancom;

     2 

     3 use strict;

     4 use warnings;

     5 use IO::Socket::INET;

     6 use Quancom::Result;

     7 use Carp;

     8 

     9 our $VERSION = 0.1;

    10 

    11 my $DEFAULT_PORT = 1001;

    12 

    13 sub new {

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

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

    16 

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

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

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

    20 

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

    22         Proto    => "tcp",

    23         PeerAddr => $self->{peer}

    24     );

    25 

    26     $self->{job} = 0;

    27     $self->{ok} = undef;

    28 

    29     return $self;

    30 }

    31 

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

    33 

    34 sub cmd {

    35     my $self = shift;

    36     my $cmd  = shift;

    37 

    38     $self->_tx($cmd);

    39     $self->_rx($cmd);

    40 

    41     return $self->{last_result};

    42 }

    43 

    44 sub _tx {

    45     my $self = shift;

    46     my $cmd  = shift;

    47 

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

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

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

    51 

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

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

    54 }

    55 

    56 sub _rx {

    57     my $self = shift;

    58 

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

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

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

    62 

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

    64 

    65     # decode the status

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

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

    68     }

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

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

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

    72     }

    73     else {

    74         die "unknown response $r";

    75     }

    76 

    77     return $r;

    78 }

    79 

    80 

    81 1;

    82 

    83 __END__

    84 

    85 =head1 NAME

    86 

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

    88 

    89 =head1 SYNOPSIS

    90 

    91     use Quancom;

    92 

    93     my $q = new Quancom 172.16.0.22;

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

    95 	or die $r->error_message;

    96 

    97 =head1 METHODS

    98 

    99 =over

   100 

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

   102 

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

   104 successfully established.

   105 

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

   107 

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

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

   110 

   111 It returns TRUE on success, FALSE otherwise.

   112 

   113 =item B<last_result>( )

   114 

   115 This returns an object containing the last result.

   116 

   117 =back

   118 

   119 =head1 AUTHOR

   120 

   121     Maik Schueller

   122     Heiko Schlittermann

   123 

   124 =cut