File Coverage

blib/lib/Net/TacacsPlus/Packet/AuthorResponseBody.pm
Criterion Covered Total %
statement 46 46 100.0
branch 2 2 100.0
condition n/a
subroutine 9 9 100.0
pod 3 3 100.0
total 60 60 100.0


line stmt bran cond sub pod time code
1             package Net::TacacsPlus::Packet::AuthorResponseBody;
2              
3             =head1 NAME
4              
5             Net::TacacsPlus::Packet::AuthorResponseBody - Tacacs+ authorization response body
6              
7             =head1 DESCRIPTION
8              
9             The authorization RESPONSE packet body
10              
11              
12              
13             1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8
14              
15             +----------------+----------------+----------------+----------------+
16             | status | arg_cnt | server_msg len |
17             +----------------+----------------+----------------+----------------+
18             + data len | arg 1 len | arg 2 len |
19             +----------------+----------------+----------------+----------------+
20             | ... | arg N len | server_msg ...
21             +----------------+----------------+----------------+----------------+
22             | data ...
23             +----------------+----------------+----------------+----------------+
24             | arg 1 ...
25             +----------------+----------------+----------------+----------------+
26             | arg 2 ...
27             +----------------+----------------+----------------+----------------+
28             | ...
29             +----------------+----------------+----------------+----------------+
30             | arg N ...
31             +----------------+----------------+----------------+----------------+
32              
33             =cut
34              
35              
36             our $VERSION = '1.10';
37              
38 10     10   59 use strict;
  10         22  
  10         368  
39 10     10   55 use warnings;
  10         22  
  10         4391  
40              
41 10     10   1047 use 5.006;
  10         39  
  10         485  
42 10     10   73 use Net::TacacsPlus::Constants 1.03;
  10         227  
  10         72  
43 10     10   80 use Carp::Clan;
  10         24  
  10         240  
44              
45 10     10   2408 use base qw{ Class::Accessor::Fast };
  10         27  
  10         7333  
46              
47             __PACKAGE__->mk_accessors(qw{
48             status
49             server_msg
50             data
51             args
52             });
53              
54             =head1 METHODS
55              
56             =over 4
57              
58             =item new( somekey => somevalue)
59              
60             Construct tacacs+ authorization response body object
61              
62             Parameters:
63              
64             'raw_body': raw body
65              
66             =cut
67              
68             sub new() {
69 2     2 1 595 my $class = shift;
70 2         12 my %params = @_;
71              
72             #let the class accessor contruct the object
73 2         22 my $self = $class->SUPER::new(\%params);
74              
75 2 100       140 if ($params{'raw_body'}) {
76 1         6 $self->decode($params{'raw_body'});
77 1         3 delete $self->{'raw_body'};
78 1         4 return $self;
79             }
80              
81 1         6 return $self;
82             }
83              
84             =item decode($raw_data)
85              
86             Extract status, server_msg, data and arguments from raw packet.
87              
88             =cut
89              
90             sub decode {
91 1     1 1 3 my ($self, $raw_data) = @_;
92            
93 1         1 my ($server_msg_len,$arg_cnt,@arg_lengths,$data_len,$offset,@args);
94            
95             (
96 1         8 $self->{'status'},
97             $arg_cnt,
98             $server_msg_len,
99             $data_len,
100             ) = unpack("CCnn", $raw_data);
101 1         2 $offset = 6;
102            
103 1         7 @arg_lengths = unpack("x$offset" . ("C" x $arg_cnt), $raw_data);
104 1         2 $offset += $arg_cnt;
105              
106 1         9 ($self->{'server_msg'}, $self->{'data'}) =
107             unpack("x$offset"."a".$server_msg_len."a".$data_len, $raw_data);
108 1         2 $offset += $server_msg_len + $data_len;
109              
110 1         4 foreach my $arglen (@arg_lengths)
111             {
112 3         10 push(@args, unpack("x$offset"."a$arglen", $raw_data));
113 3         6 $offset += $arglen;
114             }
115            
116 1         5 $self->{'args'} = \@args;
117             }
118              
119              
120             =item raw()
121              
122             Return binary data of packet body.
123              
124             =cut
125              
126             sub raw {
127 1     1 1 2476 my $self = shift;
128              
129 1         8 my $args_count = scalar(@{$self->{'args'}});
  1         10  
130 3         8 my $body = pack('CCnnC'.$args_count.'a*a*a*',
131             $self->{'status'},
132             $args_count,
133             length($self->{'server_msg'}),
134             length($self->{'data'}),
135 1         3 (map { length($_) } @{$self->{'args'}}),
  1         11  
136             $self->{'server_msg'},
137             $self->{'data'},
138 1         6 join('', @{$self->{'args'}}),
139             );
140              
141 1         4 return $body;
142             }
143              
144             =back
145              
146             =cut
147              
148             1;