File Coverage

lib/Net/EGTS/Packet.pm
Criterion Covered Total %
statement 144 162 88.8
branch 32 52 61.5
condition 9 18 50.0
subroutine 24 24 100.0
pod 4 6 66.6
total 213 262 81.3


line stmt bran cond sub pod time code
1 8     8   208534 use utf8;
  8         32  
  8         37  
2              
3             package Net::EGTS::Packet;
4 8     8   1616 use namespace::autoclean;
  8         51362  
  8         27  
5 8     8   1705 use Mouse;
  8         83294  
  8         39  
6              
7 8     8   2842 use Carp;
  8         14  
  8         387  
8 8     8   1741 use List::MoreUtils qw(natatime any);
  8         36816  
  8         40  
9 8     8   8308 use Module::Load qw(load);
  8         6762  
  8         36  
10              
11 8     8   1442 use Net::EGTS::Util qw(crc8 crc16 usize dumper_bitstring);
  8         13  
  8         442  
12 8     8   1071 use Net::EGTS::Types;
  8         351  
  8         172  
13 8     8   1138 use Net::EGTS::Codes;
  8         278  
  8         3212  
14              
15             require Net::EGTS::Record;
16              
17             =head1 NAME
18              
19             Net::EGTS::Packet - Packet common part
20              
21             =cut
22              
23             # Global packet identifier
24             our $PID = 0;
25              
26             # Packet types and classes
27             our %TYPES = (
28             EGTS_PT_RESPONSE, 'Net::EGTS::Packet::Response',
29             EGTS_PT_APPDATA, 'Net::EGTS::Packet::Appdata',
30             EGTS_PT_SIGNED_APPDATA, 'Net::EGTS::Packet::SignedAppdata',
31             );
32              
33             # Protocol Version
34             has PRV => is => 'rw', isa => 'BYTE', default => 0x01;
35             # Security Key ID
36             has SKID => is => 'rw', isa => 'BYTE', default => 0;
37              
38             # Flags:
39             # Prefix
40             has PRF => is => 'rw', isa => 'BIT2', default => 0b00;
41             # Route
42             has RTE => is => 'rw', isa => 'BIT1', default => 0b0;
43             # Encryption Algorithm
44             has ENA => is => 'rw', isa => 'BIT2', default => 0b00;
45             # Compressed
46             has CMP => is => 'rw', isa => 'BIT1', default => 0b0;
47             # Priority
48             has PRIORITY => is => 'rw', isa => 'BIT2', default => 0b00;
49              
50             # Header Length
51             has HL =>
52             is => 'rw',
53             isa => 'BYTE',
54             lazy => 1,
55             builder => sub {
56             my ($self) = @_;
57             my $length = 11;
58             $length += 2 if defined $self->PRA;
59             $length += 2 if defined $self->RCA;
60             $length += 1 if defined $self->TTL;
61             return $length;
62             },
63             ;
64             # Header Encoding
65             has HE => is => 'rw', isa => 'BYTE', default => 0x0;
66             # Frame Data Length
67             has FDL =>
68             is => 'rw',
69             isa => 'USHORT',
70             lazy => 1,
71             builder => sub {
72             my ($self) = @_;
73 8     8   59 use bytes;
  8         10  
  8         41  
74             return 0 unless defined $self->SFRD;
75             return 0 unless length $self->SFRD;
76             return length $self->SFRD;
77             },
78             ;
79             # Packet Identifier
80             has PID =>
81             is => 'rw',
82             isa => 'USHORT',
83             lazy => 1,
84             builder => sub {
85             my $pid = $PID;
86             $PID = 0 unless ++$PID >= 0 && $PID <= 65535;
87             return $pid;
88             }
89             ;
90             # Packet Type
91             has PT => is => 'rw', isa => 'BYTE';
92              
93             # Optional (set if RTE enabled):
94             # Peer Address
95             has PRA => is => 'rw', isa => 'Maybe[USHORT]';
96             # Recipient Address
97             has RCA => is => 'rw', isa => 'Maybe[USHORT]';
98             # Time To Live
99             has TTL => is => 'rw', isa => 'Maybe[BYTE]';
100              
101             # Header Check Sum
102             has HCS =>
103             is => 'rw',
104             isa => 'BYTE',
105             lazy => 1,
106             builder => sub {
107             my ($self) = @_;
108 8     8   1357 use bytes;
  8         10  
  8         28  
109             my $length = $self->HL - 1; # HL - HCS
110             die 'Binary too short to get CRC8' if $length > length $self->bin;
111             return crc8( substr( $self->bin, 0 => $length ) );
112             },
113             ;
114              
115             # Service Frame Data
116             has SFRD =>
117             is => 'rw',
118             isa => 'Maybe[BINARY]',
119             default => '',
120             trigger => sub {
121             my ($self, $value, $old) = @_;
122             die 'Service Frame Data too long'
123             if defined($value) && length($value) > 65517;
124             }
125             ;
126             # Service Frame Data Check Sum
127             has SFRCS =>
128             is => 'rw',
129             isa => 'Maybe[USHORT]',
130             lazy => 1,
131             builder => sub {
132             my ($self) = @_;
133 8     8   1048 use bytes;
  8         12  
  8         47  
134             die 'Binary too short to get CRC16' if $self->FDL > length $self->SFRD;
135             return undef unless defined $self->SFRD;
136             return undef unless length $self->SFRD;
137             return crc16( $self->SFRD );
138             }
139             ;
140              
141             # Private:
142             # Packet binary
143             has bin => is => 'rw', isa => 'Str', default => '';
144              
145             # Array of decoded records
146             has records =>
147             is => 'rw',
148             isa => 'ArrayRef[Net::EGTS::Record]',
149             lazy => 1,
150             builder => sub {
151             my ($self) = @_;
152             return [] unless defined $self->SDR;
153             return [] unless length $self->SDR;
154             return Net::EGTS::Record->decode_all( $self->SDR );
155             },
156             ;
157              
158             #around BUILDARGS => sub {
159             # my $orig = shift;
160             # my $class = shift;
161             #
162             # # simple scalar decoding support
163             # my $bin = @_ % 2 ? shift : undef;
164             # my %opts = @_;
165             #
166             # return $class->$orig(
167             # bin => $bin,
168             # %opts
169             # ) if $bin;
170             # return $class->$orig( %opts );
171             #};
172             #sub BUILD {
173             # my $self = shift;
174             # my $args = shift;
175             #
176             # $self->decode( \$self->bin ) if length $self->bin;
177             # use Data::Dumper;
178             # warn Dumper($self);
179             #}
180              
181             # Store binary and count how mutch more bytes need
182             sub take {
183 95     95 0 477 my ($self, $bin, $mask, $length) = @_;
184 8     8   1279 use bytes;
  8         16  
  8         28  
185              
186 95   66     210 $length //= usize($mask);
187 95 50       146 confess "Can`t get chunk of length $length" if $length > length $$bin;
188              
189 95         122 my $chunk = substr $$bin, 0 => $length, '';
190 95         246 $self->bin( $self->bin . $chunk );
191              
192 95         342 return unpack $mask => $chunk;
193             }
194              
195             # Helper to get portion of data
196             sub nip {
197 12     12 0 22 my ($self, $bin, $mask, $length) = @_;
198 8     8   864 use bytes;
  8         10  
  8         38  
199              
200 12   66     33 $length //= usize($mask);
201 12 50       23 confess "Can`t get chunk of length $length" if $length > length $$bin;
202              
203 12         25 my $chunk = substr $$bin, 0 => $length, '';
204 12         66 return unpack $mask => $chunk;
205             }
206              
207             =head2 stream \$bin
208              
209             Parse incoming stream and creates packages from it.
210             If the data is not sufficient to create the package: returns the number
211             of data as many more as required.
212             The buffer is trimmed by the size of the created package.
213              
214             Return:
215              
216             =over
217              
218             =item undef, $need
219              
220             if decode in process and need more data
221              
222             =item object
223              
224             if the packet is fully decoded
225              
226             =item error code
227              
228             if there are any problems
229              
230             =cut
231              
232             sub stream {
233 6     6 1 12206 my ($class, $bin) = @_;
234 8     8   750 use bytes;
  8         13  
  8         23  
235              
236             # Need first 10 bytes
237 6         8 my $need = 10;
238 6 100       17 return (undef, $need) if $need > length $$bin;
239              
240             # Packet size
241 5         17 my $HL = unpack 'C' => substr $$bin, 3, usize('C');
242 5         11 my $FDL = unpack 'S' => substr $$bin, 5, usize('S');
243              
244             # Need full package size
245 5 50       14 $need = $HL + $FDL + ($FDL ? 2 : 0);
246 5 100       12 return (undef, $need) if $need > length $$bin;
247              
248 4         16 my $packet = substr $$bin, 0, $need, '';
249              
250             # Packet type
251 4         9 my $PT = unpack 'C' => substr $packet, 9, usize('C');
252              
253             # Create packet
254 4         10 my $subclass = $TYPES{ $PT };
255 4         16 load $subclass;
256 4         307 return $subclass->new->decode( \$packet );
257             }
258              
259             =head2 decode $bin
260              
261             Decode binary stream I<$bin> into packet object.
262             Return:
263              
264             =over
265              
266             =item undef, $need
267              
268             if decode in process and need more data
269              
270             =item object
271              
272             if the packet is fully decoded
273              
274             =item error code
275              
276             if there are any problems
277              
278             =back
279              
280             =cut
281              
282             sub decode {
283 9     9 1 80 my ($self, $bin) = @_;
284 8     8   1287 use bytes;
  8         11  
  8         25  
285              
286 9         43 $self->PRV( $self->take($bin => 'C') );
287 9         23 $self->SKID($self->take($bin => 'C') );
288              
289 9         21 my $flags = $self->take($bin => 'C');
290 9         48 $self->PRF( ($flags & 0b11000000) >> 6 );
291 9         32 $self->RTE( ($flags & 0b00100000) >> 5 );
292 9         30 $self->ENA( ($flags & 0b00011000) >> 3 );
293 9         35 $self->CMP( ($flags & 0b00000100) >> 2 );
294 9         29 $self->PRIORITY( ($flags & 0b00000011) );
295              
296 9         21 $self->HL( $self->take($bin => 'C') );
297 9         20 $self->HE( $self->take($bin => 'C') );
298 9         19 $self->FDL( $self->take($bin => 'S') );
299 9         22 $self->PID( $self->take($bin => 'S') );
300 9         23 $self->PT( $self->take($bin => 'C') );
301              
302 9 50       51 return EGTS_PC_UNS_PROTOCOL unless $self->PRV == 0x01;
303 9 50 33     61 return EGTS_PC_INC_HEADERFORM unless $self->HL == 11 || $self->HL == 16;
304 9 50       51 return EGTS_PC_UNS_PROTOCOL unless $self->PRF == 0x00;
305              
306 9 50       31 if( $self->RTE ) {
307 0         0 $self->PRA( $self->take($bin => 'S') );
308 0         0 $self->RCA( $self->take($bin => 'S') );
309 0         0 $self->TTL( $self->take($bin => 'C') );
310              
311 0         0 die 'RTE not supported';
312             }
313              
314             # Header CRC8
315 9         26 my $hsc = $self->take($bin => 'C');
316 9 50       55 return EGTS_PC_HEADERCRC_ERROR unless $self->HCS == $hsc;
317              
318             # Complete package. No data.
319 9 100       33 return $self unless $self->FDL;
320              
321 7         26 $self->SFRD( $self->take($bin => 'a*' => $self->FDL) );
322              
323 7         19 my $sfrcs = $self->take($bin => 'S');
324 7 50       27 return EGTS_PC_DATACRC_ERROR unless $self->SFRCS == $sfrcs;
325              
326 7 50       31 unless( $self->ENA == 0x00 ) {
327 0         0 warn 'Encryption not supported yet';
328 0         0 return EGTS_PC_DECRYPT_ERROR;
329             }
330              
331 7 50       23 unless( $self->CMP == 0x00 ) {
332 0         0 warn 'Compression not supported yet';
333 0         0 return EGTS_PC_INC_DATAFORM;
334             }
335              
336 7         17 return $self;
337             }
338              
339             =head2 encode
340              
341             Build packet as binary
342              
343             =cut
344              
345             sub encode {
346 8     8 1 404 my ($self) = @_;
347 8     8   2359 use bytes;
  8         23  
  8         29  
348              
349 8 50       42 croak 'Encryption not supported yet' if $self->ENA;
350 8 50       33 croak 'Compression not supported yet' if $self->CMP;
351 8 50       34 croak 'Packet Type required' unless defined $self->PT;
352              
353 8         13 my $mask = 'C C B8 C C S S C';
354              
355             # Optional fields
356 8         20 my @optional;
357 8 50 33     105 if( $self->PRA || $self->RCA || $self->TTL ) {
      33        
358 0         0 $mask .= ' S S C ';
359 0         0 push @optional, $self->PRA;
360 0         0 push @optional, $self->RCA;
361 0         0 push @optional, $self->TTL;
362              
363 0         0 $self->RTE( 0x1 );
364             }
365              
366             # Header Length
367 8 50       81 $self->HL( 10 + ($self->RTE ? 5 : 0) + 1 );
368              
369             # Build base header
370 8         154 my $bin = pack $mask =>
371             $self->PRV, $self->SKID,
372             sprintf(
373             '%02b%b%02b%b%02b',
374             $self->PRF, $self->RTE, $self->ENA, $self->CMP, $self->PRIORITY,
375             ),
376             $self->HL, $self->HE, $self->FDL, $self->PID, $self->PT,
377             @optional,
378             ;
379              
380             # Header Check Sum
381 8         36 $self->HCS( crc8 $bin );
382 8         34 $bin .= pack 'C' => $self->HCS;
383              
384             # Service Frame Data
385 8 100       35 $bin .= $self->SFRD if defined $self->SFRD;
386              
387             # Service Frame Data Check Sum
388 8 100 66     58 if( $self->SFRD && $self->FDL ) {
389 6         37 $bin .= pack 'S' => $self->SFRCS;
390             }
391              
392 8         34 $self->bin( $bin );
393 8         24 return $bin;
394             }
395              
396             =head2 as_debug
397              
398             Return human readable string
399              
400             =cut
401              
402             sub as_debug {
403 9     9 1 4036 my ($self) = @_;
404 8     8   1960 use bytes;
  8         12  
  8         33  
405              
406 9         140 my @bytes = ((unpack('B*', $self->bin)) =~ m{.{8}}g);
407              
408 9         16 my @str;
409 9         33 push @str => sprintf('PRV: %s', splice @bytes, 0 => usize('C'));
410 9         27 push @str => sprintf('SKID: %s', splice @bytes, 0 => usize('C'));
411 9         22 push @str => sprintf('FLAGS: %s', splice @bytes, 0 => usize('C'));
412 9         22 push @str => sprintf('HL: %s', splice @bytes, 0 => usize('C'));
413 9         23 push @str => sprintf('HE: %s', splice @bytes, 0 => usize('C'));
414 9         41 push @str => sprintf('FDL: %s %s', splice @bytes, 0 => usize('S'));
415 9         56 push @str => sprintf('PID: %s %s', splice @bytes, 0 => usize('S'));
416 9         26 push @str => sprintf('PT: %s', splice @bytes, 0 => usize('C'));
417              
418 9 50       43 push @str => sprintf('PRA: %s %s', splice @bytes, 0 => usize('S'))
419             if defined $self->PRA;
420 9 50       40 push @str => sprintf('RCA: %s %s', splice @bytes, 0 => usize('S'))
421             if defined $self->RCA;
422 9 50       42 push @str => sprintf('TTL: %s', splice @bytes, 0 => usize('C'))
423             if defined $self->TTL;
424              
425 9         28 push @str => sprintf('HCS: %s', splice @bytes, 0 => usize('C'));
426              
427 9 100       24 if( @bytes ) {
428              
429 6 50       22 if( my @qualify = inner() ) {
430 6         17 splice @bytes, 0 => -2;
431 6         13 push @str => sprintf('SFRD =>');
432 6         18 push @str, @qualify;
433 6         39 push @str => sprintf('<======');
434             } else {
435 0         0 my $it = natatime 4, splice @bytes, 0 => -2;
436 0         0 my @chunks;
437 0         0 while (my @vals = $it->()) {
438 0         0 push @chunks, join(' ', @vals);
439             }
440 0         0 push @str => sprintf('SFRD: %s', join("\n ", @chunks));
441             }
442              
443 6         25 push @str => sprintf('SFRCS: %s %s', splice @bytes, 0 => 2);
444             }
445              
446 9         51 push @str, sprintf '(Data %d bytes. Total %d bytes.)',
447             $self->FDL,
448             length $self->bin
449             ;
450              
451 9         75 return join "\n", @str;
452             }
453              
454             __PACKAGE__->meta->make_immutable();