File Coverage

lib/Net/EGTS/Packet/Response.pm
Criterion Covered Total %
statement 33 33 100.0
branch n/a
condition n/a
subroutine 11 11 100.0
pod n/a
total 44 44 100.0


line stmt bran cond sub pod time code
1 3     3   53772 use utf8;
  3         13  
  3         15  
2              
3             package Net::EGTS::Packet::Response;
4 3     3   452 use namespace::autoclean;
  3         13310  
  3         15  
5 3     3   470 use Mouse;
  3         20737  
  3         14  
6             extends qw(Net::EGTS::Packet);
7              
8 3     3   1064 use Carp;
  3         5  
  3         167  
9 3     3   440 use List::MoreUtils qw(natatime);
  3         9641  
  3         23  
10              
11 3     3   2022 use Net::EGTS::Types;
  3         90  
  3         81  
12 3     3   315 use Net::EGTS::Codes;
  3         67  
  3         693  
13 3     3   345 use Net::EGTS::Util qw(usize);
  3         4  
  3         264  
14              
15             # Response Packet ID
16             has RPID => is => 'rw', isa => 'USHORT';
17             # Processing Result
18             has PR => is => 'rw', isa => 'BYTE';
19             # Service Data Record
20             has SDR => is => 'rw', isa => 'Maybe[BINARY]';
21              
22             after 'decode' => sub {
23             my ($self) = @_;
24 3     3   16 use bytes;
  3         4  
  3         12  
25              
26             die 'Packet not EGTS_PT_RESPONSE type'
27             unless $self->PT == EGTS_PT_RESPONSE;
28              
29             return unless defined $self->SFRD;
30             return unless length $self->SFRD;
31              
32             my $bin = $self->SFRD;
33             $self->RPID( $self->nip(\$bin => 'S') );
34             $self->PR( $self->nip(\$bin => 'C') );
35             $self->SDR( $self->nip(\$bin => 'a*' => length($bin)) );
36             };
37              
38             before 'encode' => sub {
39             my ($self) = @_;
40 3     3   384 use bytes;
  3         3  
  3         10  
41              
42             die 'Packet not EGTS_PT_RESPONSE type'
43             unless $self->PT == EGTS_PT_RESPONSE;
44              
45             my $bin = pack 'S C' => $self->RPID, $self->PR;
46             $bin .= pack 'a*' => $self->SDR if defined $self->SDR;
47              
48             $self->SFRD( $bin );
49             };
50              
51             around BUILDARGS => sub {
52             my $orig = shift;
53             my $class = shift;
54             return $class->$orig( @_, PT => EGTS_PT_RESPONSE );
55             };
56              
57             augment as_debug => sub {
58             my ($self) = @_;
59 3     3   437 use bytes;
  3         5  
  3         8  
60              
61             my @bytes = ((unpack('B*', $self->SFRD)) =~ m{.{8}}g);
62              
63             my @str;
64             push @str => sprintf('RPID: %s %s', splice @bytes, 0 => usize('S'));
65             push @str => sprintf('PR: %s', splice @bytes, 0 => usize('C'));
66              
67             my $it = natatime 4, @bytes;
68             my @chunks;
69             while (my @vals = $it->()) {
70             push @chunks, join(' ', @vals);
71             }
72             push @str => sprintf('SDR: %s', join("\n ", @chunks));
73              
74             return @str;
75             };
76              
77             __PACKAGE__->meta->make_immutable();