--- 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
--- /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",
+)
--- 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<new>( I<ip> )
-
-This method returns a new Quancom object if the connection was
-successfully established.
-
-=item B<send>( 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 TRUE on success, FALSE otherwise.
-
-=item B<last_result>( )
-
-This returns an object containing the last result.
-
-=back
-
-=head1 AUTHOR
-
- Maik Schueller
- Heiko Schlittermann
-
-=cut
--- 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
--- 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<ok> ( )
-
-Use this method to query the last operations status.
-
-=item B<result> ( )
-
-Returns the last result. This is valid only if the last status is ok,
-otherwise you'll get "undef".
-
-=item B<error_message> ( [I<error code>] )
-
-Returns a message describing the last error. Of if you pass an error
-code it will the return the associated message.
-
-=item B<error> ( )
-
-Returns the last error code (numerical).
-
-=back
-
-=head1 AUTHOR
-
- Maik Schueller
- Heiko Schlittermann
-
-=cut
--- 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;
-}
-
--- /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;
+}
+
--- /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
--- /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<new>( I<ip> )
+
+This method returns a new Quancom object if the connection was
+successfully established.
+
+=item B<send>( 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 TRUE on success, FALSE otherwise.
+
+=item B<last_result>( )
+
+This returns an object containing the last result.
+
+=back
+
+=head1 AUTHOR
+
+ Maik Schueller
+ Heiko Schlittermann
+
+=cut
--- /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
--- /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<ok> ( )
+
+Use this method to query the last operations status.
+
+=item B<result> ( )
+
+Returns the last result. This is valid only if the last status is ok,
+otherwise you'll get "undef".
+
+=item B<error_message> ( [I<error code>] )
+
+Returns a message describing the last error. Of if you pass an error
+code it will the return the associated message.
+
+=item B<error> ( )
+
+Returns the last error code (numerical).
+
+=back
+
+=head1 AUTHOR
+
+ Maik Schueller
+ Heiko Schlittermann
+
+=cut