File Coverage

blib/lib/Net/TacacsPlus/Packet/AccountRequestBody.pm
Criterion Covered Total %
statement 51 54 94.4
branch 10 18 55.5
condition n/a
subroutine 9 9 100.0
pod 3 3 100.0
total 73 84 86.9


line stmt bran cond sub pod time code
1             package Net::TacacsPlus::Packet::AccountRequestBody;
2              
3             =head1 NAME
4              
5             Net::TacacsPlus::Packet::AccountRequestBody - Tacacs+ accounting request body
6              
7             =head1 DESCRIPTION
8              
9             The account REQUEST packet body
10              
11              
12             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
13              
14             +----------------+----------------+----------------+----------------+
15             | flags | authen_method | priv_lvl | authen_type |
16             +----------------+----------------+----------------+----------------+
17             | authen_service | user len | port len | rem_addr len |
18             +----------------+----------------+----------------+----------------+
19             | arg_cnt | arg 1 len | arg 2 len | ... |
20             +----------------+----------------+----------------+----------------+
21             | arg N len | user ...
22             +----------------+----------------+----------------+----------------+
23             | port ...
24             +----------------+----------------+----------------+----------------+
25             | rem_addr ...
26             +----------------+----------------+----------------+----------------+
27             | arg 1 ...
28             +----------------+----------------+----------------+----------------+
29             | arg 2 ...
30             +----------------+----------------+----------------+----------------+
31             | ...
32             +----------------+----------------+----------------+----------------+
33             | arg N ...
34             +----------------+----------------+----------------+----------------+
35              
36             =cut
37              
38              
39             our $VERSION = '1.10_01';
40              
41 10     10   45 use strict;
  10         14  
  10         482  
42 10     10   46 use warnings;
  10         13  
  10         295  
43              
44 10     10   149 use 5.006;
  10         23  
  10         542  
45 10     10   78 use Net::TacacsPlus::Constants 1.03;
  10         321  
  10         55  
46 10     10   55 use Carp::Clan;
  10         15  
  10         93  
47              
48 10     10   1909 use base qw{ Class::Accessor::Fast };
  10         17  
  10         5505  
49              
50             __PACKAGE__->mk_accessors(qw{
51             acct_flags
52             authen_method
53             priv_lvl
54             authen_type
55             service
56             user
57             port
58             rem_addr
59             args
60             });
61              
62             =head1 METHODS
63              
64             =over 4
65              
66             =item new( somekey => somevalue)
67              
68             Construct tacacs+ accounting REQUEST packet body object
69              
70             Parameters:
71              
72             acct_flags : TAC_PLUS_ACCT_FLAG_* - default TAC_PLUS_ACCT_FLAG_STOP
73             authen_method : TAC_PLUS_AUTHEN_METH_* - default TAC_PLUS_AUTHEN_METH_TACACSPLUS
74             priv_lvl : TAC_PLUS_PRIV_LVL_* - default TAC_PLUS_PRIV_LVL_MIN
75             authen_type : TAC_PLUS_AUTHEN_TYPE_* - default TAC_PLUS_AUTHEN_TYPE_ASCII
76             service : TAC_PLUS_AUTHEN_SVC_* - default TAC_PLUS_AUTHEN_SVC_LOGIN
77             user : username
78             port : port - default 'Virtual00'
79             rem_addr : our ip address - default '127.0.0.1'
80             args : args arrayref
81              
82             =cut
83              
84             sub new()
85             {
86 2     2 1 387 my $class = shift;
87 2         8 my %params = @_;
88              
89             #let the class accessor contruct the object
90 2         14 my $self = $class->SUPER::new(\%params);
91              
92 2 100       26 if ($params{'raw_body'}) {
93 1         4 $self->decode($params{'raw_body'});
94 1         7 delete $self->{'raw_body'};
95 1         4 return $self;
96             }
97              
98 1 50       5 $self->acct_flags(TAC_PLUS_ACCT_FLAG_STOP) if not defined $self->acct_flags;
99 1 50       13 $self->authen_method(TAC_PLUS_AUTHEN_METH_TACACSPLUS) if not defined $self->authen_method;
100 1 50       8 $self->priv_lvl(TAC_PLUS_PRIV_LVL_MIN) if not defined $self->priv_lvl;
101 1 50       16 $self->authen_type(TAC_PLUS_AUTHEN_TYPE_ASCII) if not defined $self->authen_type;
102 1 50       7 $self->service(TAC_PLUS_AUTHEN_SVC_LOGIN) if not defined $self->service;
103 1 50       5 $self->port('Virtual00') if not defined $self->port;
104 1 50       6 $self->rem_addr('127.0.0.1') if not defined $self->rem_addr;
105              
106 1 50       7 croak 'pass array reference as args' if not ref $self->args eq 'ARRAY';
107              
108 1         12 return $self;
109             }
110              
111             =item decode($raw_body)
112              
113             Construct body object from raw data.
114              
115             =cut
116              
117             sub decode {
118 1     1 1 2 my ($self, $raw_body) = @_;
119            
120 1         2 my $user_length;
121             my $port_length;
122 0         0 my $rem_addr_length;
123 0         0 my $args_count;
124 0         0 my $payload;
125            
126             (
127 1         9 $self->{'acct_flags'},
128             $self->{'authen_method'},
129             $self->{'priv_lvl'},
130             $self->{'authen_type'},
131             $self->{'service'},
132             $user_length,
133             $port_length,
134             $rem_addr_length,
135             $args_count,
136             $payload,
137             ) = unpack("C9a*", $raw_body);
138              
139             #build array of unpack strings per argument - ('a10', 'a12', ...)
140 4         7 my @args_unpack_strings =
141 1         4 map { 'a'.$_ }
142             unpack('C'.$args_count , $payload)
143             ;
144              
145             #remove counts from raw body
146 1         3 $payload = substr($payload, $args_count);
147              
148             (
149 1         8 $self->{'user'},
150             $self->{'port'},
151             $self->{'rem_addr'},
152             $payload,
153             ) = unpack('a'.$user_length.'a'.$port_length.'a'.$rem_addr_length.'a*', $payload);
154              
155             #fill args property
156 1         8 $self->args([
157             unpack(
158             join('', @args_unpack_strings),
159             $payload
160             )
161             ]);
162              
163             }
164              
165              
166             =item raw()
167              
168             Return binary data of packet body.
169              
170             =cut
171              
172             sub raw {
173 1     1 1 982 my $self = shift;
174              
175 1         5 my $body = pack("C9",
176             $self->{'acct_flags'},
177             $self->{'authen_method'},
178             $self->{'priv_lvl'},
179             $self->{'authen_type'},
180             $self->{'service'},
181             length($self->{'user'}),
182             length($self->{'port'}),
183             length($self->{'rem_addr'}),
184 1         4 scalar(@{$self->{'args'}}),
185             );
186              
187             #add args lengths
188 1         3 $body .= pack('C*', map { length($_) } @{$self->{'args'}});
  4         6  
  1         2  
189            
190 1         2 $body .= $self->{'user'}
191             .$self->{'port'}
192             .$self->{'rem_addr'}
193 1         3 .join('', @{$self->{'args'}});
194              
195 1         3 return $body;
196             }
197              
198             1;
199              
200             =back
201              
202             =cut