18 Proto => "tcp", |
18 Proto => "tcp", |
19 PeerAddr => $self->{peer} |
19 PeerAddr => $self->{peer} |
20 ); |
20 ); |
21 |
21 |
22 $self->{job} = 0; |
22 $self->{job} = 0; |
|
23 $self->{ok} = undef; |
23 |
24 |
24 return $self; |
25 return $self; |
25 } |
26 } |
26 |
27 |
27 sub cmd { |
28 sub cmd { |
28 my $self = shift; |
29 my $self = shift; |
29 my $cmd = shift; |
30 my $cmd = shift; |
30 |
31 |
31 $self->_tx($cmd); |
32 $self->_tx($cmd); |
32 $self->_rx($cmd); |
33 $self->_rx($cmd); |
|
34 |
|
35 return $self->{ok}; |
|
36 } |
|
37 |
|
38 |
|
39 sub status { |
|
40 my $self = shift; |
|
41 return $self->{ok}; |
|
42 } |
|
43 |
|
44 sub result { |
|
45 my $self = shift; |
|
46 return undef if not $self->{ok}; |
|
47 return $self->{result}; |
|
48 } |
|
49 |
|
50 sub error { |
|
51 my $self = shift; |
|
52 return undef if $self->{ok}; |
|
53 return $self->{error_code}; |
|
54 } |
|
55 |
|
56 sub error_message { |
|
57 my $self = shift; |
|
58 |
|
59 return undef if !@_ and $self->{ok}; |
|
60 |
|
61 return ("checksum error", "character error", "invalid command", |
|
62 "invalid width")[ @_ ? $_[0] : $self->{error_code} ]; |
33 } |
63 } |
34 |
64 |
35 sub _tx { |
65 sub _tx { |
36 my $self = shift; |
66 my $self = shift; |
37 my $cmd = shift; |
67 my $cmd = shift; |
44 $self->{socket}->print($cmd . "\r"); |
74 $self->{socket}->print($cmd . "\r"); |
45 } |
75 } |
46 |
76 |
47 sub _rx { |
77 sub _rx { |
48 my $self = shift; |
78 my $self = shift; |
49 local $/ = "\r"; |
79 |
50 my $r = $self->{socket}->getline; |
80 local $/ = "\r"; # CR is the delimiter |
51 chomp($r); |
81 my $r = $self->{socket}->getline; # now it's a line |
|
82 chomp($r); # we do not need the delimiter |
|
83 |
|
84 # decode the status |
|
85 if (($self->{error_code}) = $r =~ /^E(.)/) { |
|
86 $self->{ok} = 0; |
|
87 } |
|
88 elsif (my ($jobid, $data, $csum) = $r =~ /^[DO](..)(.*)(..)$/) { |
|
89 $self->{ok} = 1; |
|
90 $self->{result} = defined $data ? $data : ""; |
|
91 } |
|
92 else { |
|
93 die "unknown response $r"; |
|
94 } |
|
95 |
52 return $r; |
96 return $r; |
53 } |
97 } |
|
98 |
|
99 1; |
|
100 |
|
101 __END__ |
|
102 |
|
103 =head1 NAME |
|
104 |
|
105 Quancom - perl module to access the usb opto quancom device |
|
106 |
|
107 =head1 SYNOPSIS |
|
108 |
|
109 use Quancom; |
|
110 |
|
111 my $q = new Quancom 172.16.0.22; |
|
112 $q->cmd("xxxxxx") |
|
113 or die $q->error_message; |
|
114 |
|
115 =head1 METHODS |
|
116 |
|
117 =over |
|
118 |
|
119 =item constructor B<new>( I<ip> ) |
|
120 |
|
121 This method returns a new Quancom object if the connection was |
|
122 successfully established. |
|
123 |
|
124 =item B<send>( I<string> ) |
|
125 |
|
126 Send a Quancom string to the device. The string here should be |
|
127 B<without> the leading STX and Jobid as well without the trailing CR. |
|
128 |
|
129 It returns TRUE on success, FALSE otherwise. |
|
130 |
|
131 =item B<status> ( ) |
|
132 |
|
133 Use this method to query the last operations status. |
|
134 |
|
135 =item B<result> ( ) |
|
136 |
|
137 Returns the last result. This is valid only if the last status is ok, |
|
138 otherwise you'll get "undef". |
|
139 |
|
140 =item B<error_message> ( [I<error code>] ) |
|
141 |
|
142 Returns a message describing the last error. Of if you pass an error |
|
143 code it will the return the associated message. |
|
144 |
|
145 =item B<error> ( ) |
|
146 |
|
147 Returns the last error code (numerical). |
|
148 |
|
149 =back |
|
150 |
|
151 =head1 AUTHOR |
|
152 |
|
153 Maik Schueller |
|
154 Heiko Schlittermann |
|
155 |
|
156 =cut |