File Coverage

blib/lib/Device/Velleman/PPS10.pm
Criterion Covered Total %
statement 28 193 14.5
branch 3 92 3.2
condition 0 39 0.0
subroutine 9 18 50.0
pod 5 7 71.4
total 45 349 12.8


line stmt bran cond sub pod time code
1             package Device::Velleman::PPS10;
2              
3             ################################################################################
4             # Class for reading data from Velleman pps10 scope over serial line.
5             # Currently the module is geared towards processing only BA packets.
6             #
7             # Note: This may work for the HPS40 model, but is untested.
8             # Tested only on a Linux system.
9              
10 1     1   21287 use 5.008000;
  1         4  
  1         31  
11 1     1   5 use strict;
  1         2  
  1         28  
12 1     1   4 use warnings;
  1         5  
  1         36  
13              
14 1     1   4 use base qw(Exporter);
  1         2  
  1         140  
15             BEGIN {
16 1     1   16 our $VERSION = 0.03;
17             }
18              
19 1     1   1296 use Device::SerialPort;
  1         38259  
  1         73  
20 1     1   951 use Hash::Util qw(lock_hash lock_keys);
  1         2259  
  1         7  
21              
22              
23             ################################################################################
24             # Scope Characteristics
25              
26             use constant {
27             # The ascii string of the delimiters defining the start of a data packet.
28             # The binary values in the buffer will be matched in string context.
29 1         2182 BA_DELIM => 'BA' . chr(10) . chr(1),
30             BR_DELIM => 'BR',
31             BS_DELIM => 'BS' . chr(11) . chr(0),
32              
33             # There are 8 full divisions for volts on the scope LCD display spanning the 0-255 8-bit range output.
34             POINTS_PER_VOLT_DIV => 32, # number of points per division out of the full 8-bit 0-255 point range.
35             POINTS_PER_TIME_DIV => 10, # number of samples per division out of the full 256 samples per frame.
36              
37             # The voltage sample value defined to be the 0V baseline.
38             BASELINE_POINT => 127,
39              
40             DEFAULT_SERIAL_PORT => '/dev/ttyS0',
41             DEFAULT_SERIAL_READ => 255,
42 1     1   116 };
  1         1  
43              
44             # Volts per divisions mappings for packet header values.
45             my @volts = ('0.005', '0.01', '0.02', '0.05', '0.1', '0.2', '0.4', '1', '2', '4', '8', '20');
46             my @volts_10x = map { $_ * 10 } @volts; # 10x
47             my %volt_divs;
48              
49             # AC
50             @volt_divs{ 0 .. 11} = @volts; # 1x
51             @volt_divs{16 .. 27} = @volts_10x; # 10x
52              
53             # DC
54             @volt_divs{32 .. 43} = @volts; # 1x
55             @volt_divs{48 .. 59} = @volts_10x; # 10x
56              
57             # Times in seconds.
58             # Note: there are higher time/div resolutions than 1 second.
59             # It appears that the scope returns BR packets (and even BS packets) for times 0.5s/div and longer.
60             my @times = (
61             '0.0000002',
62             '0.0000005',
63             '0.000001',
64             '0.000002',
65             '0.000005', # 5 us
66             '0.00001',
67             '0.00002',
68             '0.00005',
69             '0.0001',
70             '0.0002',
71             '0.0005',
72             '0.001',
73             '0.002',
74             '0.005', # 5 ms
75             '0.01',
76             '0.02',
77             '0.05',
78             '0.1',
79             '0.2',
80             '0.5',
81             '1' # 1 s
82             );
83              
84             # Times per division mapping to header values.
85             my %time_divs;
86             @time_divs{ 0 .. 20} = @times;
87             @time_divs{64 .. 84} = @times;
88              
89              
90             ################################################################################
91             # Local Functions
92              
93             # Identify the packet type from the raw packet data.
94             # Simply check to see if the given strings begins with one of the delimiters.
95             sub _identify_packet_type {
96 0     0   0 my $packet_bin = shift;
97              
98 0 0       0 if (index($packet_bin, BA_DELIM) == 0) {
    0          
    0          
99 0         0 return 'BA';
100             } elsif (index($packet_bin, BR_DELIM) == 0) {
101 0         0 return 'BR';
102             } elsif (index($packet_bin, BS_DELIM) == 0) {
103 0         0 return 'BS';
104             }
105             }
106              
107             # Convert the trace data points from 0:255 to voltage according to v/div.
108             # Convert the time data points from 0:255 to time where the first sample is 0 seconds.
109             # The shift_only does not scale the values, but centers the voltage sample values on 127,
110             # the 0V baseline.
111             sub _format_trace {
112 0     0   0 my ($p_info, $shift_only) = @_;
113              
114             # x_max: The width of the x-axis.
115             # y_max: The height of the y-axis above and below the 0V baseline.
116              
117 0         0 my (@new_trace, @new_time);
118 0 0       0 if ($shift_only) {
119             # Simply shift the trace half-way down, where 127 is the 0V baseline.
120 0         0 @new_trace = map { $_ - BASELINE_POINT } @{$p_info->{trace}};
  0         0  
  0         0  
121 0         0 @new_time = @{$p_info->{time}};
  0         0  
122              
123 0         0 $p_info->{x_max} = 256;
124 0         0 $p_info->{y_max} = BASELINE_POINT;
125             } else {
126             # Scale the time points to seconds.
127 0 0       0 if (my $time_per_point = $p_info->{time_per_point}) {
128 0         0 $p_info->{x_max} = 256 * $time_per_point;
129 0         0 @new_time = map { $_ * $time_per_point } @{$p_info->{time}};
  0         0  
  0         0  
130             } else {
131 0         0 @new_time = @{$p_info->{time}};
  0         0  
132             }
133              
134             # Scale the trace data volts/div.
135 0 0       0 if (my $volts_per_point = $p_info->{volts_per_point}) {
136 0         0 $p_info->{y_max} = BASELINE_POINT * $volts_per_point;
137 0         0 @new_trace = map { ($_ - BASELINE_POINT) * $volts_per_point } @{$p_info->{trace}};
  0         0  
  0         0  
138             } else {
139 0         0 @new_trace = @{$p_info->{trace}};
  0         0  
140             }
141             }
142              
143 0         0 $p_info->{trace_scaled} = \@new_trace;
144 0         0 $p_info->{time_scaled} = \@new_time;
145              
146 0         0 return;
147             }
148              
149              
150             ################################################################################
151             # Class Methods
152              
153             # Return all the packet header code to /div translation hashes.
154             sub get_division_maps {
155 0     0 0 0 my $class = shift;
156              
157 0         0 return { time_divs => { %time_divs },
158             volt_divs => { %volt_divs } };
159             }
160              
161             # Make pps10 scope object.
162             sub new {
163 1     1 1 15 my $class = shift;
164              
165             # Define defaults and allow them to be overridden.
166 1         3 my %args = @_;
167 1         3 my ($port, $read_bytes, $verbose, $debug) = @args{qw(port read_bytes verbose debug)};
168              
169 1 50       5 $port = defined $port ? $port : DEFAULT_SERIAL_PORT;
170 1 50       4 $read_bytes = defined $read_bytes ? $read_bytes : DEFAULT_SERIAL_READ;
171              
172             # Create a Serial port object, or fail here.
173 1 50       11 my $sp = Device::SerialPort->new($port) or
174             die "Could not open $port: $!\n";
175              
176             # Serial port settings specific to the Velleman PPS10.
177 0           $sp->handshake('none');
178 0           $sp->baudrate(57600);
179 0           $sp->parity('none');
180 0           $sp->databits(8);
181 0           $sp->stopbits(1);
182              
183 0           $sp->read_char_time(0); # don't wait for each character
184 0           $sp->read_const_time(1000); # 1 second per unfulfilled "read" call
185              
186 0 0         print STDERR "Reading in chunks of $read_bytes bytes\n"
187             if $verbose;
188              
189             # Cause fatal error if accessing and undefined header value
190 0 0         if ($debug) {
191 0           lock_hash(%time_divs);
192 0           lock_hash(%volt_divs);
193             }
194              
195 0 0         my %self = (serial_port => $sp,
    0          
196             port => $port,
197             read_bytes => $read_bytes,
198             verbose => defined $verbose ? $verbose : 0,
199             debug => defined $debug ? $debug : 0,
200              
201             # Data read from serial port
202             read_data => undef, # last data read from serial port.
203             read_total_bytes => undef, # length of requested serial port data.
204             read_count => 0, # count of serial port readings.
205             read_buffer => undef, # buffer of serial port data, holding candidate packets.
206              
207             # Packet info.
208             packet_count => 0,
209             current_packet => undef,
210             first_ba_seen => 0,
211              
212             # Opened file handle of the file to dump raw serial port reads.
213             # A defined value indicates that a dump should happen.
214             raw_out_fh => undef);
215              
216 0           bless \%self, $class;
217              
218             # Catch any invalid hash key usage.
219 0           lock_keys(%self);
220              
221 0           return \%self;
222             }
223              
224              
225             ################################################################################
226             # Object Methods
227              
228             # Read n number of of bytes from the serial port using Device::SerialPort->read into the buffer.
229             sub read {
230 0     0 1   my $self = shift;
231              
232 0           my $verbose = $self->{verbose};
233 0           my $read_bytes = $self->{read_bytes};
234              
235 0           my ($read_length, $read_data) = ($self->{serial_port}->read($read_bytes));
236              
237             # Total read count and bytes.
238 0           $self->{read_count}++;
239 0           $self->{read_total_bytes}+= length($read_data);
240              
241 0 0         if ($verbose) {
242 0           print STDERR "Serial port reading $self->{read_count} ... ";
243 0           print STDERR "reported length: $read_length, string length: " . length($read_data) . "\n";
244              
245 0 0         if ($read_length == 0) {
    0          
246 0           print STDERR "Serial port read: no data.\n";
247             } elsif ($read_length < $read_bytes) {
248 0           print STDERR "Serial port read: under read $read_length/$read_bytes.\n";
249             }
250             }
251              
252 0 0         if (my $raw_fh = $self->{raw_out_fh}) {
253 0           print $raw_fh $read_data;
254             }
255              
256             # Append to read buffer. This buffer will be truncated from the
257             # start by get_next_packet() as it extracts any packets it finds.
258 0           $self->{read_data} = $read_data; # Last read serial data.
259 0           $self->{read_buffer}.= $read_data;
260              
261 0 0         return ($read_length, $read_data)
262             if defined wantarray;
263              
264 0           return;
265             }
266              
267             # To be called after a read() from the serial port.
268             # Get the next BA packet that's available based on the read serial port data.
269             # The caller should call get_next_packet() in a loop until all packets
270             # have been processed and fetch more data using read() in the outer loop.
271             # Returns undef if there was not enough data to process.
272             # TODO: Use of $read_buffer may be unnecessary and could be an opportunity to introduce bugs.
273             sub get_next_packet {
274 0     0 1   my $self = shift;
275              
276 0           my $verbose = $self->{verbose};
277 0           my $debug = $self->{debug};
278              
279 0           my $read_buffer = $self->{read_buffer};
280              
281             # Get the index of the first BA delimiter.
282 0           my $ba_index_0 = index($read_buffer, BA_DELIM);
283 0           my $ba_index_1;
284              
285             # Get indexes of other delimiters.
286 0           my $br_index = index($read_buffer, BR_DELIM);
287 0           my $bs_index = index($read_buffer, BS_DELIM);
288              
289             # Make this verbose?
290 0 0 0       if ($verbose and $ba_index_0 == -1) {
291 0           print "No BA delim found in buffer of size: " . length($read_buffer) . ".\n";
292             }
293              
294             return
295 0 0         if $ba_index_0 == -1;
296              
297 0 0         if ($ba_index_0 >= 0) {
    0          
    0          
298 0 0         print STDERR "Found start of BA packet in buffer.\n"
299             if $debug;
300              
301             # If no BA has been seen before this instance of get_next_packet() call, then strip off bytes
302             # leading up to the first BA delim.
303             # It's not clear if the leading data is a complete BA packet or not.
304             # It needs to be stripped off, leaving the buffer to start with the BA delim.
305 0 0         if (not $self->{first_ba_seen}) {
306 0           substr($self->{read_buffer}, 0, $ba_index_0, '');
307 0           $self->{first_ba_seen} = 1;
308              
309 0 0         if ($verbose) {
310 0           print STDERR "Truncating leading data before first BA delimiter.\n";
311 0           print STDERR "Read buffer was: $read_buffer\n";
312 0           print STDERR "Now : $self->{read_buffer}\n";
313             }
314              
315             # Reset buffer var and first index.
316 0           $read_buffer = $self->{read_buffer};
317 0           $ba_index_0 = index($read_buffer, BA_DELIM);
318             }
319              
320             # Find second BA delim, if it exists.
321             # This would indicate that a complete BA packet exists in the buffer.
322 0           $ba_index_1 = index($read_buffer, BA_DELIM, ($ba_index_0 + 1));
323              
324 0 0         if (not $ba_index_1 > 0) {
325 0           return;
326             }
327             } elsif ($br_index >= 0) {
328 0 0         if ($debug) {
329 0           print "Found BR packet: $read_buffer\n";
330 0           print "-> " . sprintf("%vd", $read_buffer) . "\n";
331             }
332             } elsif ($bs_index >= 0) {
333             # Have not seen a BS packet so far during development.
334 0 0         if ($debug) {
335 0           print "Found BS packet: $read_buffer\n";
336             }
337             }
338              
339             # Fetch the packet string and truncate at the same time.
340 0 0         print STDERR "BA found packet in buffer at byte positions $ba_index_0 and $ba_index_1\n"
341             if $verbose;
342              
343 0           my $length = $ba_index_1 - $ba_index_0;
344 0           my $p_data = substr($self->{read_buffer}, $ba_index_0, $length, '');
345              
346             # Truncate any leading unused data to avoid bloat of the buffer.
347 0           substr($self->{read_buffer}, 0, $ba_index_0, '');
348              
349 0           my $packet = $self->parse_packet($p_data);
350              
351 0           $self->{packet_count}++;
352              
353             # Return on the first packet from the parts.
354 0           return $packet;
355             }
356              
357             # Parse and process a packet string.
358             # Must be a complete paket with header bytes but the delimiter may be optional.
359             sub parse_packet {
360 0     0 0   my $self = shift;
361              
362 0           my $packet = shift;
363              
364 0           my $verbose = $self->{verbose};
365 0           my $debug = $self->{debug};
366              
367 0           my $raw_packet = $packet;
368              
369             # Strip and fetch any packet type delimiters.
370 0           my $ba_str = BA_DELIM;
371 0           my $br_str = BR_DELIM;
372 0           my $bs_str = BS_DELIM;
373              
374             # Strip the packet delimiters.
375 0           $packet =~ s/^($ba_str|$br_str|$bs_str)(.*)/$2/;
376 0           my $packet_type = _identify_packet_type($1);
377              
378 0 0         print "Parsed Packet Type: $packet_type\n"
379             if $verbose;
380              
381             # For now, strip off any non-BA packets that may have snuck in.
382 0           my @non_ba_str = $packet =~ s/($br_str|$bs_str).*$//;
383              
384             # Split into individual bytes.
385             # Note: Would it be faster to sprintf() first and then split?
386 0           my @bytes = split('', $packet);
387              
388             # Fetch the data section, leaving the headers in @bytes.
389 0           my @trace = map { sprintf("%vd", $_) } splice(@bytes, 6);
  0            
390              
391             # Time.
392             # Fix x-axis to 256 samples per screen, as described in the serial port protocol.
393             # This will keep the trace display consistent and not vary based on length of @trace.
394 0           my @time = (0 .. 255);
395              
396             # Convert the header bytes into decimals.
397 0           my @header = map { sprintf("%vd", $_) } @bytes;
  0            
398              
399 0           my $volts_key = $header[1];
400              
401 0           my $volts_acdc;
402 0 0 0       if ($volts_key >= 0 and $volts_key <= 11 or $volts_key >= 16 and $volts_key <= 27 ) {
    0 0        
      0        
      0        
      0        
      0        
403 0           $volts_acdc = 'ac';
404             } elsif ($volts_key >= 32 and $volts_key <= 43 or $volts_key >= 48 and $volts_key <= 59 ) {
405 0           $volts_acdc = 'dc';
406             }
407              
408 0           my $volts_10x;
409 0 0 0       if ($volts_key >= 16 and $volts_key <= 27 or $volts_key >= 48 and $volts_key <= 59) {
    0 0        
      0        
      0        
      0        
      0        
410 0           $volts_10x = 1;
411             } elsif ($volts_key >= 32 and $volts_key <= 43 or $volts_key >= 0 and $volts_key <= 11 ) {
412 0           $volts_10x = 0;
413             }
414              
415             # Expect the possibility of an unknown header value for divisions.
416 0           my $time_per_div = $time_divs{$header[0]};
417 0 0         my $time_per_point = $time_per_div ? ($time_per_div / POINTS_PER_TIME_DIV) : 0;
418              
419 0           my $volts_per_div = $volt_divs{$volts_key};
420 0 0         my $volts_per_point = $volts_per_div ? ($volts_per_div / POINTS_PER_VOLT_DIV) : 0;
421              
422 0 0         if ($debug) {
423 0 0         print STDERR "Found unknown time/div value: " . $header[0] . "\n"
424             if not $time_per_div;
425              
426 0 0         print STDERR "Found unknown volt/div value: " . $volts_key . "\n"
427             if not $volts_per_div;
428             }
429              
430             # Complete packet data structure.
431 0           my %packet = ( packet_type => $packet_type,
432             raw_packet => $raw_packet,
433             processed_packet => $packet,
434             header => \@header,
435             time_per_div => $time_per_div,
436             time_per_point => $time_per_point,
437             volts_per_div => $volts_per_div,
438             volts_per_point => $volts_per_point,
439             volts_acdc => $volts_acdc,
440             volts_10x => $volts_10x,
441             trace => \@trace,
442             time => \@time,
443             x_max => undef, # The width of the x-axis.
444             y_max => undef, # The height of the y-axis above and below the 0V baseline.
445             trace_scaled => undef,
446             time_scaled => undef,);
447              
448             # Scale the trace data.
449 0           _format_trace(\%packet, 0);
450              
451             # Note: Should the last processed packet persist when there should not be any current packet?
452 0           $self->{current_packet} = \%packet;
453              
454 0           return \%packet;
455             }
456              
457             # Start saving the raw data read from the serial port to specified file.
458             # Data will start being saved in the next call to read().
459             sub save_raw_data_to_file {
460 0     0 1   my $self = shift;
461              
462 0           my $filename = shift;
463 0           my $unbuffer = shift;
464              
465             # Don't clobber an existing file handle.
466 0 0         if (defined $self->{raw_out_fh}) {
467 0 0         print STDERR "Open file handle exists for writing raw data. Skipping.\n"
468             if $self->{verbose};
469              
470 0           return 0;
471             }
472              
473             # Open or die.
474 0 0         open(my $out_fh, '>', $filename) or
475             die "Could not write to '$filename': $!\n";
476              
477             # Unbuffer this file handle if explicitly requested.
478             # Unbuffering the handle results in disk activity for each read from serial port.
479 0 0         if ($unbuffer) {
480 0           my $old_fh = select($out_fh); $| = 1; select($old_fh);
  0            
  0            
481             }
482              
483 0           $self->{raw_out_fh} = $out_fh;
484              
485 0           return 1;
486             }
487              
488             # Close the raw dump file handle.
489             sub close_raw_data_file {
490 0     0 1   my $self = shift;
491              
492 0 0         if (defined $self->{raw_out_fh}) {
493 0           print "closing\n";
494 0           close($self->{raw_out_fh});
495 0           $self->{raw_out_fh} = undef;
496             }
497              
498 0           return;
499             }
500              
501             sub DESTROY {
502 0     0     my $self = shift;
503              
504 0 0         print STDERR "DESTROY() called\n"
505             if $self->{debug};
506              
507             # Close any dump files that may be open.
508 0           $self->close_raw_data_file;
509              
510 0           return;
511             }
512             1;
513              
514             __END__