File Coverage

lib/Net/EGTS/SubRecord/Auth/DispatcherIdentity.pm
Criterion Covered Total %
statement 27 27 100.0
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 36 36 100.0


line stmt bran cond sub pod time code
1 4     4   52922 use utf8;
  4         12  
  4         20  
2              
3             package Net::EGTS::SubRecord::Auth::DispatcherIdentity;
4 4     4   466 use Mouse;
  4         20667  
  4         15  
5             extends qw(Net::EGTS::SubRecord);
6              
7 4     4   1211 use Carp;
  4         7  
  4         230  
8 4     4   500 use List::MoreUtils qw(natatime);
  4         9326  
  4         19  
9 4     4   3921 use Encode qw();
  4         28402  
  4         93  
10              
11 4     4   336 use Net::EGTS::Util qw(usize dumper_bitstring);
  4         8  
  4         179  
12 4     4   316 use Net::EGTS::Codes;
  4         83  
  4         998  
13              
14             # Dispatcher Type
15             has DT => is => 'rw', isa => 'BYTE', default => 0;
16             # Dispatcher ID
17             has DID => is => 'rw', isa => 'UINT';
18             # Description
19             has DSCR =>
20             is => 'rw',
21             isa => 'Maybe[STRING]',
22             trigger => sub {
23             my ($self, $value, $old) = @_;
24 4     4   22 use bytes;
  4         6  
  4         18  
25             die 'Description too long' if defined($value) && length($value) > 255;
26             }
27             ;
28              
29             after 'decode' => sub {
30             my ($self) = @_;
31             die 'SubRecord not EGTS_SR_DISPATCHER_IDENTITY type'
32             unless $self->SRT == EGTS_SR_DISPATCHER_IDENTITY;
33              
34             my $bin = $self->SRD;
35             $self->DT( $self->nip(\$bin => 'C') );
36             $self->DID( $self->nip(\$bin => 'L') );
37             $self->DSCR( $self->nip(\$bin => 'a*' => length($bin)) );
38             };
39              
40             before 'encode' => sub {
41             my ($self) = @_;
42             die 'SubRecord not EGTS_SR_DISPATCHER_IDENTITY type'
43             unless $self->SRT == EGTS_SR_DISPATCHER_IDENTITY;
44              
45             my $bin = pack 'C L' => $self->DT, $self->DID;
46             $bin .= pack 'a*' => $self->DSCR if defined $self->DSCR;
47              
48             $self->SRD( $bin );
49             };
50              
51             around BUILDARGS => sub {
52             my $orig = shift;
53             my $class = shift;
54              
55             # simple scalar decoding support
56             my $bin = @_ % 2 ? shift : undef;
57             my %opts = @_;
58              
59             # Description is CP-1251
60             $opts{DSCR} = Encode::encode('CP1251', $opts{DSCR}) if defined $opts{DSCR};
61              
62             return $class->$orig( bin => $bin, %opts, SRT => EGTS_SR_DISPATCHER_IDENTITY)
63             if $bin;
64             return $class->$orig( %opts, SRT => EGTS_SR_DISPATCHER_IDENTITY);
65             };
66              
67             augment as_debug => sub {
68             my ($self) = @_;
69 4     4   1165 use bytes;
  4         8  
  4         10  
70              
71             my @bytes = ((unpack('B*', $self->SRD)) =~ m{.{8}}g);
72              
73             my @str;
74             push @str => sprintf('DT: %s', splice @bytes, 0 => usize('C'));
75             push @str => sprintf('DID: %s %s %s %s', splice @bytes, 0 => usize('L'));
76              
77             my $it = natatime 4, @bytes;
78             my @chunks;
79             while (my @vals = $it->()) {
80             push @chunks, join(' ', @vals);
81             }
82             push @str => sprintf('DSCR: %s', join("\n ", @chunks));
83              
84             return @str;
85             };
86              
87             __PACKAGE__->meta->make_immutable();