File Coverage

blib/lib/Device/ProXR.pm
Criterion Covered Total %
statement 17 91 18.6
branch 1 40 2.5
condition 0 11 0.0
subroutine 6 11 54.5
pod 3 3 100.0
total 27 156 17.3


line stmt bran cond sub pod time code
1             package Device::ProXR;
2             ##----------------------------------------------------------------------------
3             ## :mode=perl:indentSize=2:tabSize=2:noTabs=true:
4             ##****************************************************************************
5             ## NOTES:
6             ## * Before comitting this file to the repository, ensure Perl Critic can be
7             ## invoked at the HARSH [3] level with no errors
8             ##****************************************************************************
9            
10             =head1 NAME
11            
12             Device::ProXR - A Moo based object oriented interface for creating
13             controlling devices using the National Control Devices ProXR command set
14            
15             =head1 VERSION
16            
17             Version 0.07
18            
19             =head1 SYNOPSIS
20            
21             ## Device::ProXR is a base class that is typicall extended
22             ## see Device::ProXR::RelayControl
23             use Device::ProXR;
24            
25             my $board = Device::ProXR->new(port => qq{COM1});
26            
27             =head1 SEE ALSO
28            
29             L
30            
31             See the L for the devices with
32             the ProXR series controller.
33            
34            
35             =cut
36            
37             ##****************************************************************************
38             ##****************************************************************************
39 1     1   591 use Moo;
  1         2  
  1         5  
40             ## Moo enables strictures
41             ## no critic (TestingAndDebugging::RequireUseStrict)
42             ## no critic (TestingAndDebugging::RequireUseWarnings)
43 1     1   249 use 5.010;
  1         2  
44 1     1   5 use Readonly;
  1         1  
  1         42  
45 1     1   4 use Time::HiRes qw(usleep);
  1         1  
  1         8  
46 1     1   127 use Carp qw(confess cluck);
  1         1  
  1         193  
47            
48             ## Version string
49             our $VERSION = qq{0.07};
50            
51            
52             ##--------------------------------------------------------
53             ## Time conversion contants
54             ##--------------------------------------------------------
55             ## uSeconds per millisecond
56             Readonly::Scalar my $USECS_PER_MS => 1000;
57             ## milliseconds per second
58             Readonly::Scalar my $MS_PER_SEC => 1000;
59             ## uSeconds per second
60             Readonly::Scalar my $USECS_PER_SEC => $USECS_PER_MS * $MS_PER_SEC;
61            
62             ##--------------------------------------------------------
63             ## Various timeouts
64             ##--------------------------------------------------------
65             Readonly::Scalar my $GET_RESPONSE_DEFAULT_MS_TIMEOUT => 400;
66             ## millisecond timeout when reading from the FPC serial port
67             Readonly::Scalar my $READ_POLL_TIMEOUT_MS => 1000;
68            
69             ##--------------------------------------------------------
70             ## Symbolic constants
71             ##--------------------------------------------------------
72            
73             Readonly::Scalar my $PROXR_API_START => 0xAA;
74             Readonly::Scalar my $PROXR_CMD => 0xFE;
75            
76             ##--------------------------------------------------------
77             ## Conditionally load the needed serial module
78             ##--------------------------------------------------------
79             BEGIN
80             {
81 1 50   1   5 if ($^O eq 'MSWin32')
82             {
83 0         0 require Win32::SerialPort;
84 0         0 Win32::SerialPort->import;
85             }
86             else
87             {
88 1         1117 require Device::SerialPort;
89 1         31530 Device::SerialPort->import;
90             }
91             }
92             ##****************************************************************************
93             ## Object attribute
94             ##****************************************************************************
95            
96             =head1 ATTRIBUTES
97            
98             =cut
99            
100             ##****************************************************************************
101             ##****************************************************************************
102            
103             =over 2
104            
105             =item B
106            
107             Port used to communicate with the device
108            
109             =back
110            
111             =cut
112            
113             ##----------------------------------------------------------------------------
114             has port => (
115             is => qq{rw},
116             default => qq{},
117             );
118            
119             ##****************************************************************************
120             ##****************************************************************************
121            
122             =over 2
123            
124             =item B
125            
126             Baud rate for port used to communicate with the device.
127             NOTE: This only applies to serial port communications
128             DEFAULT: 115200
129            
130             =back
131            
132             =cut
133            
134             ##----------------------------------------------------------------------------
135             has baud => (
136             is => qq{rw},
137             default => qq{115200},
138             );
139            
140             ##****************************************************************************
141             ##****************************************************************************
142            
143             =over 2
144            
145             =item B
146            
147             Enable the API mode of communications. This mode adds byte counts and
148             checksums to all commands and responses.
149             DEFAULT: 1
150            
151             =back
152            
153             =cut
154            
155             ##----------------------------------------------------------------------------
156             has API_mode => (
157             is => qq{rw},
158             default => qq{1},
159             );
160            
161             ##****************************************************************************
162             ##****************************************************************************
163            
164             =over 2
165            
166             =item B
167            
168             Debug level controls amount of debugging information displayed
169             DEFAULT: 0
170            
171             =back
172            
173             =cut
174            
175             ##----------------------------------------------------------------------------
176             has debug_level => (
177             is => qq{rw},
178             default => 0,
179             );
180            
181             ##****************************************************************************
182             ## "Private" atributes
183             ##***************************************************************************
184            
185             ## Holds the port object
186             has _port_obj => (
187             is => qq{rw},
188             predicate => 1,
189            
190             );
191            
192             ## Error message
193             has _error_message => (
194             is => qq{rw},
195             default => qq{},
196             );
197            
198            
199             ##****************************************************************************
200             ## Object Methods
201             ##****************************************************************************
202            
203             =head1 METHODS
204            
205             =cut
206            
207             ##----------------------------------------------------------------------------
208             ## @fn _get_port_object()
209             ## @brief Returns the port object, opening it if needed. Returns UNDEF
210             ## on error and sets last_error
211             ## @param
212             ## @return Port object, or UNDEF on error
213             ## @note
214             ##----------------------------------------------------------------------------
215             sub _get_port_object ## no critic (ProhibitUnusedPrivateSubroutines)
216             {
217 0     0     my $self = shift;
218            
219             ## Returh the object if it already exists
220 0 0         return($self->_port_obj) if ($self->_has_port_obj);
221            
222             ## See if a port was specified
223 0 0         unless ($self->port)
224             {
225 0           $self->_error_message(qq{Missing port attribute!});
226 0           return;
227             }
228            
229             ## Create the object
230 0           my $obj;
231            
232             ## See if we running Windows
233 0 0         if ($^O eq q{MSWin32})
234             {
235             ## Running Windows, use Win32::SerialPort
236 0           $obj = Win32::SerialPort->new($self->port, 1);
237             }
238             else
239             {
240             ## Not running Windows, use Device::SerialPort
241 0           $obj = Device::SerialPort->new($self->port, 1);
242             }
243            
244             ## See if opened the port
245 0 0         unless ($obj)
246             {
247             ## There was an error opening the port
248 0           $self->_error_message(qq{Could not open port "} . $self->port . qq{"});
249 0           return;
250             }
251            
252             ## Configure the port
253 0           $obj->baudrate($self->baud);
254 0           $obj->parity(qq{none});
255 0           $obj->databits(8);
256 0           $obj->stopbits(1);
257 0           $obj->handshake(qq{none});
258 0           $obj->read_const_time($READ_POLL_TIMEOUT_MS);
259 0           $obj->purge_all;
260            
261             ## Write all settings to the serial port
262 0           $obj->write_settings;
263            
264             ## Set the port object
265 0           $self->_port_obj($obj);
266            
267             ## Return the port object
268 0           return($self->_port_obj);
269             }
270            
271            
272            
273             ##****************************************************************************
274             ##****************************************************************************
275            
276             =head2 last_error()
277            
278             =over 2
279            
280             =item B
281            
282             Returns the last error message
283            
284             =item B
285            
286             NONE
287            
288             =item B
289            
290             String containing the last error, or an empty string if no error has been
291             encountered
292            
293             =back
294            
295             =cut
296            
297             ##----------------------------------------------------------------------------
298             sub last_error
299             {
300 0     0 1   my $self = shift;
301            
302 0           return($self->_error_message);
303             }
304            
305             ##****************************************************************************
306             ##****************************************************************************
307            
308             =head2 send_command(cmd, param)
309            
310             =over 2
311            
312             =item B
313            
314             Sends the given command wand optional parameter.
315             NOTE: This method adds the required 0xFE before the command, and
316             encapsulation of the packet in API mode
317            
318             =item B
319            
320             cmd - Command to send
321             param - Optional parameter
322            
323             =item B
324            
325             UNDEF on error (last_error set), or number of bytes sent
326            
327             =back
328            
329             =cut
330            
331             ##----------------------------------------------------------------------------
332             sub send_command
333             {
334 0     0 1   my $self = shift;
335 0           my $cmd = shift;
336 0           my $param = shift;
337            
338             ## See if we received a command
339 0 0         unless (defined($cmd))
340             {
341             ## No command, so set the error message
342 0           $self->_error_message(qq{Missing command parameter!});
343             ## Return UNDEF indicating an error
344 0           return;
345             }
346            
347             ## Assemble the string to send
348 0           my $tx_buff = chr($PROXR_CMD) . chr($cmd);
349             ## Add the parameter if provided
350 0 0         $tx_buff .= chr($param) if (defined($param));
351            
352             ## See if we are in API mode
353 0 0         if ($self->API_mode)
354             {
355             ## API Mode sends (and receives) using the format
356             ## 0xAA COUNT BYTES CHECKSUM
357             ## Where COUNT is the number of BYTES
358             ## CHECKSUM is the 8-bit rolling checksum of the entire buffer
359 0 0         my $count = (defined($param) ? 3 : 2);
360 0           my $chksum = $PROXR_API_START + $count + $PROXR_CMD + $cmd;
361 0 0         $chksum += $param if (defined($param));
362 0           $chksum = $chksum % 256;
363 0           $tx_buff = chr($PROXR_API_START) . chr($count) . $tx_buff . chr($chksum);
364             }
365            
366             ## Print debug output
367 0 0         if ($self->debug_level)
368             {
369 0           print(qq{send_command(): });
370 0           _display_buffer($tx_buff);
371             }
372            
373 0 0         return unless ($self->_get_port_object);
374            
375            
376             ## Send the buffer
377 0           my $tx_len = $self->_port_obj->write($tx_buff);
378            
379             ## Flush all RX and TX buffers
380 0           $self->_port_obj->purge_all;
381            
382             ## Return the number of bytes transmitted
383 0           return $tx_len;
384            
385             }
386            
387             ##****************************************************************************
388             ##****************************************************************************
389            
390             =head2 get_response(count, ms_timeout)
391            
392             =over 2
393            
394             =item B
395            
396             Return a buffer containing the response received from the controller
397             NOTE: In API mode, the checksum is verified and the header byte (0xAA)
398             count and checksum are removed from the buffer
399            
400             =item B
401            
402             count - Number of bytes expected
403             DEFAULT: 1
404             ms_timeout - Optional timeout in milliseconds
405             DEFAULT: 400
406            
407            
408             =item B
409            
410             UNDEF on error (last_error set), or SCALAR containing the data received
411            
412             =back
413            
414             =cut
415            
416             ##----------------------------------------------------------------------------
417             sub get_response
418             {
419 0     0 1   my $self = shift;
420 0   0       my $count = shift // 1;
421 0   0       my $ms_timeout = shift // $GET_RESPONSE_DEFAULT_MS_TIMEOUT;
422            
423             ## Number of bytes expected
424 0           my $expected = $count;
425             ## API mode, responses contain 3 extra bytes
426 0 0         $expected += 3 if ($self->API_mode);
427            
428 0 0         return unless ($self->_has_port_obj);
429            
430 0           my $rx_buff = qq{};
431            
432             ## Set the timeout
433 0           $self->_port_obj->read_const_time($ms_timeout);
434            
435 0           my $timeout = 0;
436 0   0       while ((!$timeout) and ($expected != length($rx_buff)))
437             {
438             ## Read the bytes
439 0           my ($rx_count, $rx_raw) = $self->_port_obj->read(16);
440 0 0         if ($rx_count)
441             {
442 0           $rx_buff .= $rx_raw ;
443             }
444             else
445             {
446 0           $timeout = 1;
447             }
448             }
449            
450             ## Print debug output
451 0 0         if ($self->debug_level)
452             {
453 0           printf(
454             qq{get_response(): Expected %d, received %d\n},
455             $expected,
456             length($rx_buff),
457             );
458 0           _display_buffer($rx_buff);
459             }
460            
461             ## See if we received what we expected
462 0 0         if ($expected == length($rx_buff))
463             {
464 0 0         if ($self->API_mode)
465             {
466             ## Trim off the 0xAA and COUNT from the beginning, and
467             ## checksum from the end
468 0           $rx_buff = substr($rx_buff, 2, -1);
469             }
470             }
471            
472 0           return($rx_buff);
473            
474             }
475            
476             ##----------------------------------------------------------------------------
477             ## @fn _display_buffer($buff)
478             ## @brief Display the given buffer as hexadecimal bytes
479             ## @param $buff - Buffer to be displayed
480             ## @return NONE
481             ## @note
482             ##----------------------------------------------------------------------------
483             sub _display_buffer
484             {
485 0     0     my $buff = shift;
486            
487             ## Iterate through the buffer
488 0           foreach my $idx (0 .. (length($buff) - 1))
489             {
490 0           printf(qq{0x%02X }, ord(substr($buff, $idx, 1)));
491             ## Send newline after 16 bytes
492 0 0 0       print(qq{\n}) if ($idx && (0 == ($idx % 0x10)));
493             }
494            
495             ## Send newline
496 0 0         print(qq{\n}) if (length($buff) % 0x10);
497            
498 0           return;
499             }
500            
501            
502            
503             ##****************************************************************************
504             ## Additional POD documentation
505             ##****************************************************************************
506            
507             =head1 AUTHOR
508            
509             Paul Durden Ealabamapaul AT gmail.comE
510            
511             =head1 COPYRIGHT & LICENSE
512            
513             Copyright (C) 2015 by Paul Durden.
514            
515             This program is free software; you can redistribute it and/or modify it
516             under the same terms as Perl itself.
517            
518             =cut
519            
520             1; ## End of module
521             __END__