File Coverage

blib/lib/Lab/Moose/Instrument/SCPIBlock.pm
Criterion Covered Total %
statement 42 44 95.4
branch 7 14 50.0
condition 2 3 66.6
subroutine 9 9 100.0
pod 3 3 100.0
total 63 73 86.3


line stmt bran cond sub pod time code
1             package Lab::Moose::Instrument::SCPIBlock;
2             $Lab::Moose::Instrument::SCPIBlock::VERSION = '3.880';
3             #ABSTRACT: Role for handling SCPI/IEEE 488.2 block data
4              
5 4     4   2553 use v5.20;
  4         16  
6              
7 4     4   25 use Moose::Role;
  4         18  
  4         29  
8 4     4   21938 use MooseX::Params::Validate;
  4         13  
  4         28  
9              
10 4         225 use Lab::Moose::Instrument qw/
11             precision_param
12 4     4   1937 /;
  4         19  
13              
14 4     4   34 use Carp;
  4         9  
  4         252  
15              
16 4     4   44 use namespace::autoclean;
  4         10  
  4         40  
17              
18             with qw/
19             Lab::Moose::Instrument::SCPI::Sense::Sweep
20             Lab::Moose::Instrument::SCPI::Format
21             /;
22              
23              
24             sub block_length {
25 9     9 1 18 my $self = shift;
26 9         58 my ( $num_points, $precision ) = validated_list(
27             \@_,
28             num_points => { isa => 'Int' },
29             precision_param(),
30             );
31              
32 9 0       16689 my $point_length
    50          
33             = $precision eq 'single' ? 4
34             : $precision eq 'double' ? 8
35             : croak("unknown precision $precision");
36              
37 9         28 my $read_length = $num_points * $point_length;
38 9         23 $read_length += length("#d") + length($read_length) + length("\n");
39 9         36 return $read_length;
40             }
41              
42             sub block_to_array {
43 9     9 1 72 my ( $self, %args ) = validated_hash(
44             \@_,
45             binary => { isa => 'Str' },
46             precision_param(),
47             ,
48             );
49              
50 9         16326 my $precision = delete $args{precision};
51 9         24 my $binary = delete $args{binary};
52              
53 9 50       36 if ( substr( $binary, 0, 1 ) ne '#' ) {
54 0         0 croak 'does not look like binary data';
55             }
56              
57 9         39 my %endians = (
58             native => '',
59             big => '>',
60             little => '<'
61             );
62 9         305 my $endianflag = $endians{$self->endian};
63              
64 9         22 my $num_digits = substr( $binary, 1, 1 );
65 9         22 my $num_bytes = substr( $binary, 2, $num_digits );
66 9         29 my $expected_length = $num_bytes + $num_digits + 2;
67              
68             # $binary might have a trailing newline, so do not check for equality.
69 9 50       41 if ( length $binary < $expected_length ) {
70 0         0 croak "incomplete data: expected_length: $expected_length,"
71             . " received length: ", length $binary;
72             }
73              
74 9 50       84 my @floats = unpack(
75             $precision eq 'single' ? "f$endianflag*" : "d$endianflag*",
76             substr( $binary, 2 + $num_digits, $num_bytes )
77             );
78              
79 9         54 return \@floats;
80              
81             }
82              
83              
84             sub set_data_format_precision {
85 9     9 1 60 my ( $self, %args ) = validated_hash(
86             \@_,
87             precision_param(),
88             );
89              
90 9         15021 my $precision = delete $args{precision};
91 9 50       34 my $length = $precision eq 'single' ? 32 : 64;
92 9         41 my $format = $self->cached_format_data();
93              
94 9 100 66     74 if ( $format->[0] ne 'REAL' || $format->[1] != $length ) {
95 3         904 carp "setting data format: REAL, $length";
96 3         37 $self->format_data( format => 'REAL', length => $length );
97             }
98             }
99              
100             1;
101              
102             __END__
103              
104             =pod
105              
106             =encoding UTF-8
107              
108             =head1 NAME
109              
110             Lab::Moose::Instrument::SCPIBlock - Role for handling SCPI/IEEE 488.2 block data
111              
112             =head1 VERSION
113              
114             version 3.880
115              
116             =head1 DESCRIPTION
117              
118             So far, only definite length floating point data of type 'REAL' is
119             supported.
120              
121             See "8.7.9 <DEFINITE LENGTH ARBITRARY BLOCK RESPONSE DATA>" in IEEE 488.2.
122              
123             =head1 METHODS
124              
125             =head2 block_to_array
126              
127             my $array_ref = $self->block_to_array(
128             binary => "#232${bytes}";
129             precision => 'double'
130             );
131              
132             Convert block data to arrayref, where the binary block holds floating point
133             values in native byte-order.
134              
135             =head2 block_length
136              
137             my $read_length = $self->block_length(
138             num_points => $num_points,
139             precision => $precision
140             );
141              
142             Calulate block length for use in C<read_length> parameter.
143              
144             =head2 set_data_format_precision
145              
146             $self->set_data_format_precision( precision => 'double' );
147              
148             Set used floating point type. Has to be 'single' (default) or 'double'.
149              
150             =head1 COPYRIGHT AND LICENSE
151              
152             This software is copyright (c) 2023 by the Lab::Measurement team; in detail:
153              
154             Copyright 2016 Simon Reinhardt
155             2017 Andreas K. Huettel, Simon Reinhardt
156             2020 Andreas K. Huettel, Sam Bingner
157              
158              
159             This is free software; you can redistribute it and/or modify it under
160             the same terms as the Perl 5 programming language system itself.
161              
162             =cut