# HG changeset patch # User Heiko Schlittermann # Date 1228835063 -3600 # Node ID 6f1e9c4bee3ceda2c83bf29db37708ea1707faa7 # Parent 200d69222aed608c521cedcb331ca545898f4d87 - now with MakeMaker diff -r 200d69222aed -r 6f1e9c4bee3c .perltidyrc --- a/.perltidyrc Tue Dec 09 15:58:11 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ ---paren-tightness=2 diff -r 200d69222aed -r 6f1e9c4bee3c Makefile.PL --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile.PL Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,6 @@ +use ExtUtils::MakeMaker; + +WriteMakefile ( + NAME => "Quancom", + VERSION_FROM => "lib/Quancom.pm", +) diff -r 200d69222aed -r 6f1e9c4bee3c Quancom.pm --- a/Quancom.pm Tue Dec 09 15:58:11 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -package Quancom; - -use strict; -use warnings; -use IO::Socket::INET; -use Quancom::Result; - -my $DEFAULT_PORT = 1001; - -sub new { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless {} => $class; - - $self->{peer} = shift; - $self->{peer} .= ":$DEFAULT_PORT" - unless $self->{peer} =~ /:\d+$/; - - $self->{socket} = new IO::Socket::INET( - Proto => "tcp", - PeerAddr => $self->{peer} - ); - - $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($cmd); - - return $self->{last_result}; -} - -sub _tx { - my $self = shift; - my $cmd = shift; - - $self->{job} = ++$self->{job} % 255; # cap the job id on 255; - $cmd = "\x02" . sprintf("%02x", $self->{job}) . $cmd; # add STX and job id - $cmd .= sprintf("%02x", unpack("%8C*", $cmd)); # add checksum - - warn "sending $cmd | " . unpack("H*", $cmd) . "\n"; - $self->{socket}->print($cmd . "\r"); -} - -sub _rx { - my $self = shift; - - local $/ = "\r"; # CR is the delimiter - my $r = $self->{socket}->getline; # now it's a line - chomp($r); # we do not need the delimiter - - $self->{last_result} = new Quancom::Result; - - # decode the status - if (($self->{last_result}{error_code}) = $r =~ /^E(.)/) { - $self->{last_result}{ok} = 0; - } - elsif (my ($jobid, $data, $csum) = $r =~ /^[DO](..)(.*)(..)$/) { - $self->{last_result}{ok} = 1; - $self->{last_result}{result} = defined $data ? $data : ""; - } - else { - die "unknown response $r"; - } - - return $r; -} - - -1; - -__END__ - -=head1 NAME - -Quancom - perl module to access the usb opto quancom device - -=head1 SYNOPSIS - - use Quancom; - - my $q = new Quancom 172.16.0.22; - my $r = $q->cmd("xxxxxx") - or die $r->error_message; - -=head1 METHODS - -=over - -=item constructor B( I ) - -This method returns a new Quancom object if the connection was -successfully established. - -=item B( I ) - -Send a Quancom string to the device. The string here should be -B the leading STX and Jobid as well without the trailing CR. - -It returns TRUE on success, FALSE otherwise. - -=item B( ) - -This returns an object containing the last result. - -=back - -=head1 AUTHOR - - Maik Schueller - Heiko Schlittermann - -=cut diff -r 200d69222aed -r 6f1e9c4bee3c Quancom/.perltidyrc --- a/Quancom/.perltidyrc Tue Dec 09 15:58:11 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -../.perltidyrc \ No newline at end of file diff -r 200d69222aed -r 6f1e9c4bee3c Quancom/Result.pm --- a/Quancom/Result.pm Tue Dec 09 15:58:11 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,82 +0,0 @@ -package Quancom::Result; - -use strict; -use warnings; - -sub new { - my $class = ref $_[0] ? ref shift : shift; - return bless {} => $class; -} - -sub ok { - my $self = shift; - return $self->{ok}; -} - -sub result { - my $self = shift; - return undef if not $self->{ok}; - return $self->{result}; -} - -sub error { - my $self = shift; - return undef if $self->{ok}; - return $self->{error_code}; -} - -sub error_message { - my $self = shift; - - return undef if !@_ and $self->{ok}; - - return ("checksum error", "character error", "invalid command", - "invalid width")[ @_ ? $_[0] : $self->{error_code} ]; -} - -1; - -__END__ - -=head1 NAME - -Quancom::Result - perl module to access the usb opto quancom device result - -=head1 SYNOPSIS - - use Quancom; - - my $q = new Quancom 172.16.0.22; - my $r = $q->cmd("xxxxxx") - or die $r->error_message; - -=head1 METHODS - -=over - -=item B ( ) - -Use this method to query the last operations status. - -=item B ( ) - -Returns the last result. This is valid only if the last status is ok, -otherwise you'll get "undef". - -=item B ( [I] ) - -Returns a message describing the last error. Of if you pass an error -code it will the return the associated message. - -=item B ( ) - -Returns the last error code (numerical). - -=back - -=head1 AUTHOR - - Maik Schueller - Heiko Schlittermann - -=cut diff -r 200d69222aed -r 6f1e9c4bee3c example --- a/example Tue Dec 09 15:58:11 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,19 +0,0 @@ -#! /usr/bin/perl - -use strict; -use warnings; -use Quancom; -use Data::Dumper; - - -MAIN: { - my $q = new Quancom $ARGV[0]; - - my $r; - $r = $q->cmd("WB0101FF"); - print $r->error_message, "\n" if $r->error; - - print $r->ok; - print $q->last_result->ok; -} - diff -r 200d69222aed -r 6f1e9c4bee3c examples/example --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/example Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,19 @@ +#! /usr/bin/perl + +use strict; +use warnings; +use Quancom; +use Data::Dumper; + + +MAIN: { + my $q = new Quancom $ARGV[0]; + + my $r; + $r = $q->cmd("WB0101FF"); + print $r->error_message, "\n" if $r->error; + + print $r->ok; + print $q->last_result->ok; +} + diff -r 200d69222aed -r 6f1e9c4bee3c lib/.perltidyrc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/.perltidyrc Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,1 @@ +--paren-tightness=2 diff -r 200d69222aed -r 6f1e9c4bee3c lib/Quancom.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Quancom.pm Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,124 @@ +package Quancom; + +use strict; +use warnings; +use IO::Socket::INET; +use Quancom::Result; +use Carp; + +our $VERSION = 0.1; + +my $DEFAULT_PORT = 1001; + +sub new { + my $class = ref $_[0] ? ref shift : shift; + my $self = bless {} => $class; + + $self->{peer} = shift or croak "need a peer address!"; + $self->{peer} .= ":$DEFAULT_PORT" + unless $self->{peer} =~ /:\d+$/; + + $self->{socket} = new IO::Socket::INET( + Proto => "tcp", + PeerAddr => $self->{peer} + ); + + $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($cmd); + + return $self->{last_result}; +} + +sub _tx { + my $self = shift; + my $cmd = shift; + + $self->{job} = ++$self->{job} % 255; # cap the job id on 255; + $cmd = "\x02" . sprintf("%02x", $self->{job}) . $cmd; # add STX and job id + $cmd .= sprintf("%02x", unpack("%8C*", $cmd)); # add checksum + + warn "sending $cmd | " . unpack("H*", $cmd) . "\n"; + $self->{socket}->print($cmd . "\r"); +} + +sub _rx { + my $self = shift; + + local $/ = "\r"; # CR is the delimiter + my $r = $self->{socket}->getline; # now it's a line + chomp($r); # we do not need the delimiter + + $self->{last_result} = new Quancom::Result; + + # decode the status + if (($self->{last_result}{error_code}) = $r =~ /^E(.)/) { + $self->{last_result}{ok} = 0; + } + elsif (my ($jobid, $data, $csum) = $r =~ /^[DO](..)(.*)(..)$/) { + $self->{last_result}{ok} = 1; + $self->{last_result}{result} = defined $data ? $data : ""; + } + else { + die "unknown response $r"; + } + + return $r; +} + + +1; + +__END__ + +=head1 NAME + +Quancom - perl module to access the usb opto quancom device + +=head1 SYNOPSIS + + use Quancom; + + my $q = new Quancom 172.16.0.22; + my $r = $q->cmd("xxxxxx") + or die $r->error_message; + +=head1 METHODS + +=over + +=item constructor B( I ) + +This method returns a new Quancom object if the connection was +successfully established. + +=item B( I ) + +Send a Quancom string to the device. The string here should be +B the leading STX and Jobid as well without the trailing CR. + +It returns TRUE on success, FALSE otherwise. + +=item B( ) + +This returns an object containing the last result. + +=back + +=head1 AUTHOR + + Maik Schueller + Heiko Schlittermann + +=cut diff -r 200d69222aed -r 6f1e9c4bee3c lib/Quancom/.perltidyrc --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Quancom/.perltidyrc Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,1 @@ +../.perltidyrc \ No newline at end of file diff -r 200d69222aed -r 6f1e9c4bee3c lib/Quancom/Result.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Quancom/Result.pm Tue Dec 09 16:04:23 2008 +0100 @@ -0,0 +1,82 @@ +package Quancom::Result; + +use strict; +use warnings; + +sub new { + my $class = ref $_[0] ? ref shift : shift; + return bless {} => $class; +} + +sub ok { + my $self = shift; + return $self->{ok}; +} + +sub result { + my $self = shift; + return undef if not $self->{ok}; + return $self->{result}; +} + +sub error { + my $self = shift; + return undef if $self->{ok}; + return $self->{error_code}; +} + +sub error_message { + my $self = shift; + + return undef if !@_ and $self->{ok}; + + return ("checksum error", "character error", "invalid command", + "invalid width")[ @_ ? $_[0] : $self->{error_code} ]; +} + +1; + +__END__ + +=head1 NAME + +Quancom::Result - perl module to access the usb opto quancom device result + +=head1 SYNOPSIS + + use Quancom; + + my $q = new Quancom 172.16.0.22; + my $r = $q->cmd("xxxxxx") + or die $r->error_message; + +=head1 METHODS + +=over + +=item B ( ) + +Use this method to query the last operations status. + +=item B ( ) + +Returns the last result. This is valid only if the last status is ok, +otherwise you'll get "undef". + +=item B ( [I] ) + +Returns a message describing the last error. Of if you pass an error +code it will the return the associated message. + +=item B ( ) + +Returns the last error code (numerical). + +=back + +=head1 AUTHOR + + Maik Schueller + Heiko Schlittermann + +=cut