File Coverage

lib/Net/EGTS/Record.pm
Criterion Covered Total %
statement 107 118 90.6
branch 21 36 58.3
condition 6 15 40.0
subroutine 20 21 95.2
pod 5 7 71.4
total 159 197 80.7


line stmt bran cond sub pod time code
1 9     9   60762 use utf8;
  9         21  
  9         40  
2              
3             package Net::EGTS::Record;
4 9     9   639 use namespace::autoclean;
  9         14237  
  9         34  
5 9     9   738 use Mouse;
  9         21790  
  9         39  
6              
7 9     9   2731 use Carp;
  9         11  
  9         469  
8 9     9   480 use List::MoreUtils qw(natatime);
  9         10173  
  9         53  
9              
10 9     9   4914 use Net::EGTS::Util qw(str2time time2new new2time usize dumper_bitstring);
  9         12  
  9         427  
11 9     9   304 use Net::EGTS::Types;
  9         94  
  9         659  
12              
13             require Net::EGTS::SubRecord;
14              
15             our $RN = 0;
16              
17             =head1 NAME
18              
19             Net::EGTS::Record - Record
20              
21             =cut
22              
23             # Record Length
24             has RL =>
25             is => 'rw',
26             isa => 'USHORT',
27             lazy => 1,
28             builder => sub {
29             my ($self) = @_;
30 9     9   41 use bytes;
  9         13  
  9         40  
31             return length($self->RD);
32             },
33             ;
34              
35             # Record Number
36             has RN =>
37             is => 'rw',
38             isa => 'USHORT',
39             lazy => 1,
40             builder => sub {
41             my $rn = $RN;
42             $RN = 0 unless ++$RN >= 0 && $RN <= 65535;
43             return $rn;
44             }
45             ;
46              
47              
48             # Flags:
49             # Source Service On Device
50             has SSOD => is => 'rw', isa => 'BIT1', default => 0x0;
51             # Recipient Service On Device
52             has RSOD => is => 'rw', isa => 'BIT1', default => 0x0;
53             # Group
54             has GRP => is => 'rw', isa => 'BIT1', default => 0x0;
55             # Record Processing Priority
56             has RPP => is => 'rw', isa => 'BIT2', default => 0x00;
57             # Time Field Exists
58             has TMFE =>
59             is => 'rw',
60             isa => 'BIT1',
61             lazy => 1,
62             builder => sub{ defined $_[0]->TM ? 0x1 : 0x0 },
63             ;
64             # Event ID Field Exists
65             has EVFE =>
66             is => 'rw',
67             isa => 'BIT1',
68             lazy => 1,
69             builder => sub{ defined $_[0]->EVID ? 0x1 : 0x0 },
70             ;
71             # Object ID Field Exists
72             has OBFE =>
73             is => 'rw',
74             isa => 'BIT1',
75             lazy => 1,
76             builder => sub{ defined $_[0]->OID ? 0x1 : 0x0 },
77             ;
78              
79             # Optional:
80             # Object Identifier
81             has OID => is => 'rw', isa => 'Maybe[UINT]';
82             # Event Identifier
83             has EVID => is => 'rw', isa => 'Maybe[UINT]';
84             # Time
85             has TM => is => 'rw', isa => 'Maybe[UINT]';
86              
87             # Source Service Type
88             has SST => is => 'rw', isa => 'BYTE';
89             # Recipient Service Type
90             has RST => is => 'rw', isa => 'BYTE';
91             # Record Data
92             has RD =>
93             is => 'rw',
94             isa => 'BINARY',
95             trigger => sub {
96             my ($self, $value, $old) = @_;
97             die 'Record Data too short' if length($value) < 3;
98             die 'Record Data too long' if length($value) > 65498;
99             }
100             ;
101              
102             # Record binary
103             has bin => is => 'rw', isa => 'Str', default => '';
104              
105             # Array of decoded subrecords
106             has subrecords =>
107             is => 'rw',
108             isa => 'ArrayRef[Net::EGTS::SubRecord]',
109             lazy => 1,
110             builder => sub {
111             my ($self) = @_;
112             return [] unless defined $self->RD;
113             return [] unless length $self->RD;
114             return Net::EGTS::SubRecord->decode_all( $self->RD );
115             },
116             ;
117              
118             around BUILDARGS => sub {
119             my $orig = shift;
120             my $class = shift;
121              
122             # simple scalar decoding support
123             my $bin = @_ % 2 ? shift : undef;
124             my %opts = @_;
125              
126             # simple time support
127             if( defined( my $time = delete $opts{time} ) ) {
128             $opts{TM} = time2new str2time $time;
129             $opts{TMFE} = 1 if $opts{TM};
130             }
131              
132             return $class->$orig( bin => $bin, %opts ) if $bin;
133             return $class->$orig( %opts );
134             };
135             sub BUILD {
136 11     11 1 17 my $self = shift;
137 11         12 my $args = shift;
138 11 100       69 $self->decode( \$self->bin ) if length $self->bin;
139             }
140              
141             # Get chunk from binary and store it
142             sub take {
143 43     43 0 70 my ($self, $bin, $mask, $length) = @_;
144 9     9   4853 use bytes;
  9         13  
  9         37  
145              
146 43   66     90 $length //= usize($mask);
147 43 50       61 confess "Can`t get chunk of length $length" if $length > length $$bin;
148              
149 43         61 my $chunk = substr $$bin, 0 => $length, '';
150 43         104 $self->bin( $self->bin . $chunk );
151              
152 43         169 return unpack $mask => $chunk;
153             }
154              
155             # Helper to get portion of data
156             sub nip {
157 0     0 0 0 my ($self, $bin, $mask, $length) = @_;
158 9     9   996 use bytes;
  9         27  
  9         26  
159              
160 0   0     0 $length //= usize($mask);
161 0 0       0 confess "Can`t get chunk of length $length" if $length > length $$bin;
162              
163 0         0 my $chunk = substr $$bin, 0 => $length, '';
164 0         0 return unpack $mask => $chunk;
165             }
166              
167             =head2 encode
168              
169             Build record as binary
170              
171             =cut
172              
173             sub encode {
174 3     3 1 664 my ($self) = @_;
175 9     9   852 use bytes;
  9         50  
  9         31  
176              
177 3 50       9 croak 'Source Service Type required' unless defined $self->SST;
178 3 50       8 croak 'Recipient Service Type required' unless defined $self->RST;
179 3 50       14 croak 'Record Data required' unless defined $self->RD;
180 3 50 33     14 croak 'Wrong Record Length' unless $self->RL >= 3 &&
181             $self->RL <= 65498;
182 3         4 my $mask = 'S S B8';
183              
184             # Optional fields
185 3         3 my @optional;
186 3 50 33     7 if( $self->OBFE || $self->GRP ) {
187 0         0 $mask = join ' ', $mask, 'L';
188 0         0 push @optional, $self->OID;
189             }
190 3 50       9 if( $self->EVFE ) {
191 0         0 $mask = join ' ', $mask, 'L';
192 0         0 push @optional, $self->EVID;
193             }
194 3 50       7 if( $self->TMFE ) {
195 0         0 $mask = join ' ', $mask, 'L';
196 0         0 push @optional, $self->TM;
197             }
198              
199 3         6 $mask = join ' ', $mask, 'C C a*';
200              
201 3         22 my $bin = pack $mask =>
202             $self->RL, $self->RN,
203             sprintf(
204             '%b%b%b%02b%b%b%b',
205             $self->SSOD, $self->RSOD, $self->GRP, $self->RPP, $self->TMFE,
206             $self->EVFE, $self->OBFE,
207             ),
208             @optional,
209             $self->SST, $self->RST, $self->RD
210             ;
211              
212 3         9 $self->bin( $bin );
213 3         8 return $bin;
214             }
215              
216             =head2 decode \$bin
217              
218             Decode binary I<$bin> into record object.
219             The binary stream will be truncated!
220              
221             =cut
222              
223             sub decode {
224 7     7 1 14 my ($self, $bin) = @_;
225 9     9   2297 use bytes;
  9         16  
  9         24  
226              
227 7         20 $self->RL( $self->take($bin => 'S') );
228 7         35 $self->RN( $self->take($bin => 'S') );
229              
230 7         19 my $flags = $self->take($bin => 'C');
231 7         25 $self->SSOD( ($flags & 0b10000000) >> 7 );
232 7         15 $self->RSOD( ($flags & 0b01000000) >> 6 );
233 7         16 $self->GRP( ($flags & 0b00100000) >> 5 );
234 7         19 $self->RPP( ($flags & 0b00011000) >> 3 );
235 7         28 $self->TMFE( ($flags & 0b00000100) >> 2 );
236 7         38 $self->EVFE( ($flags & 0b00000010) >> 1 );
237 7         20 $self->OBFE( ($flags & 0b00000001) );
238              
239 7 100 66     924 $self->OID( $self->take($bin => 'L') ) if $self->OBFE || $self->GRP;
240 7 50       15 $self->EVID( $self->take($bin => 'L') ) if $self->EVFE;
241 7 50       23 $self->TM( $self->take($bin => 'L') ) if $self->TMFE;
242              
243 7         15 $self->SST( $self->take($bin => 'C') );
244 7         13 $self->RST( $self->take($bin => 'C') );
245              
246 7         21 $self->RD( $self->take($bin => 'a*' => $self->RL) );
247              
248 7         20 return $self;
249             }
250              
251             =head2 decode_all \$bin
252              
253             Parse all records from packet Service Frame Data
254              
255             =cut
256              
257             sub decode_all {
258 4     4 1 18 my ($class, $bin) = @_;
259 9     9   1646 use bytes;
  9         66  
  9         31  
260              
261 4         7 my @result;
262 4         14 while( my $length = length $bin ) {
263 5         34 my $self = Net::EGTS::Record->new->decode( \$bin );
264 5 50       23 die 'Something wrong in records decode' unless $self;
265              
266 5         18 push @result, $self;
267             }
268              
269 4 100       48 return wantarray ? @result : \@result;
270             }
271              
272             =head2 as_debug
273              
274             Return human readable string
275              
276             =cut
277              
278             sub as_debug {
279 6     6 1 902 my ($self) = @_;
280 9     9   989 use bytes;
  9         13  
  9         22  
281              
282 6         78 my @bytes = ((unpack('B*', $self->bin)) =~ m{.{8}}g);
283              
284 6         8 my @str;
285 6         19 push @str => sprintf('RL: %s %s', splice @bytes, 0 => usize('S'));
286 6         19 push @str => sprintf('RN: %s %s', splice @bytes, 0 => usize('S'));
287 6         17 push @str => sprintf('FLAGS: %s', splice @bytes, 0 => usize('C'));
288              
289 6 100       23 push @str => sprintf('OID: %s %s %s %s', splice @bytes, 0 => usize('L'))
290             if defined $self->OID;
291 6 50       21 push @str => sprintf('EVID: %s %s %s %s', splice @bytes, 0 => usize('L'))
292             if defined $self->EVID;
293 6 50       19 push @str => sprintf('TM: %s %s %s %s', splice @bytes, 0 => usize('L'))
294             if defined $self->TM;
295              
296 6         13 push @str => sprintf('SST: %s', splice @bytes, 0 => usize('C'));
297 6         25 push @str => sprintf('RST: %s', splice @bytes, 0 => usize('C'));
298              
299 6         37 my $it = natatime 4, @bytes;
300 6         7 my @chunks;
301 6         28 while (my @vals = $it->()) {
302 13         42 push @chunks, join(' ', @vals);
303             }
304 6         20 push @str => sprintf('RD: %s', join("\n ", @chunks));
305              
306 6         49 return join "\n", @str;
307             }
308              
309             __PACKAGE__->meta->make_immutable();