1#! /usr/bin/perl 2# 3# 4# $Id: Replace.pm 75 2009-08-12 22:08:28Z lem $ 5 6package Net::Radius::Server::Set::Replace; 7 8use 5.008; 9use strict; 10use warnings; 11 12our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 }; 13 14use Net::Radius::Server::Base qw/:set/; 15use base qw/Net::Radius::Server::Set/; 16__PACKAGE__->mk_accessors(qw/attr vsattr result/); 17 18sub set_attr 19{ 20 my $self = shift; 21 my $r_data = shift; 22 23 my $rep = $r_data->{response}; 24 my $spec = $self->attr || []; 25 26 my $i = 0; 27 while ($i < @$spec) 28 { 29 my $attr = $spec->[$i]; 30 my $cond = $spec->[$i + 1]; 31 my $newv = $spec->[$i + 2]; 32 33 if (not grep { $_ eq $attr } $rep->attributes) 34 { 35 $self->log(4, "Skip $attr replacement"); 36 $i += 3; 37 next; 38 } 39 40 my $curv = $rep->attr($attr); 41 42 if (not ref($cond)) 43 { 44 if ($curv eq $cond) 45 { 46 $self->log(4, "Replace $attr $curv with $newv (eq $cond)"); 47 $rep->set_attr($attr, $newv); 48 } 49 else 50 { 51 $self->log(4, 52 "Don't replace $attr $curv with $newv (!= $cond)"); 53 } 54 } 55 elsif (ref($cond) eq 'Regexp') 56 { 57 if ($curv =~ m/$cond/) 58 { 59 $self->log(4, "Replace $attr $curv with $newv (=~ $cond)"); 60 $rep->set_attr($attr, $newv); 61 } 62 else 63 { 64 $self->log(4, 65 "Don't replace $attr $curv with $newv (!~ $cond)"); 66 } 67 } 68 elsif (ref($cond) eq 'NetAddr::IP') 69 { 70 my $ip = new NetAddr::IP $curv; 71 if ($ip and $cond->contains($ip)) 72 { 73 $self->log(4, "Replace $attr $curv with $newv ($ip)"); 74 $rep->set_attr($attr, $newv); 75 } 76 else 77 { 78 $self->log(4, 79 "Don't replace $attr $curv with $newv " 80 . "(!contains $cond)"); 81 82 } 83 } 84 else 85 { 86 die $self->description . ": Don't know how to work with $cond\n"; 87 } 88 89 $i += 3; 90 } 91} 92 93sub set_vsattr 94{ 95 my $self = shift; 96 my $r_data = shift; 97 98 my $rep = $r_data->{response}; 99 my $spec = $self->vsattr || []; 100 101 my $i = 0; 102 while ($i < @$spec) 103 { 104 my $vend = $spec->[$i]; 105 my $attr = $spec->[$i + 1]; 106 my $cond = $spec->[$i + 2]; 107 my $newv = $spec->[$i + 3]; 108 109 if (not grep { $_ eq $attr } $rep->vsattributes($vend)) 110 { 111 $self->log(4, "Skip $vend" . ".$attr replacement"); 112 $i += 4; 113 next; 114 } 115 116 for my $curv (@{$rep->vsattr($vend, $attr) || []}) 117 { 118 if (not ref($cond)) 119 { 120 if ($curv eq $cond) 121 { 122 $self->log(4, "Replace $vend" . ".$attr $curv with $newv" 123 . " (eq $cond)"); 124 $curv = $newv; 125 } 126 else 127 { 128 $self->log(4, "Don't replace $vend" 129 . ".$attr $curv with $newv (ne $cond)"); 130 } 131 } 132 elsif (ref($cond) eq 'Regexp') 133 { 134 if ($curv =~ m/$cond/) 135 { 136 $self->log(4, "Replace $vend" . ".$attr $curv with $newv" 137 . " (=~ $cond)"); 138 $curv = $newv; 139 } 140 else 141 { 142 $self->log(4, "Don't replace $vend" 143 . ".$attr $curv with $newv (=~ $cond)"); 144 } 145 } 146 elsif (ref($cond) eq 'NetAddr::IP') 147 { 148 my $ip = new NetAddr::IP $curv; 149 if ($ip and $cond->contains($ip)) 150 { 151 $self->log(4, "Replace $vend" . ".$attr $curv with $newv" 152 . " ($cond)"); 153 $curv = $newv; 154 } 155 else 156 { 157 $self->log(4, "Don't replace $vend" 158 . ".$attr $curv with $newv ($cond)"); 159 } 160 161 } 162 else 163 { 164 die $self->description . 165 ": Don't know how to work with $cond\n"; 166 } 167 } 168 $i += 4; 169 } 170} 171 17242; 173 174__END__ 175 176=head1 NAME 177 178Net::Radius::Server::Set::Replace - Perform replacements on the RADIUS response 179 180=head1 SYNOPSIS 181 182 use Net::Radius::Server::Base qw/:set/; 183 use Net::Radius::Server::Set::Replace; 184 185 my $replace = Net::Radius::Server::Set::Replace->new 186 ({ 187 result => NRS_SET_RESPOND, 188 vsattr => [ 189 [ 'Cisco', 'cisco-avpair' => qr/datum=foo/ => 'bad=baz' ], 190 ], 191 attr => [ 192 [ 'Reply-Message', qr/Login Succesful/ => "Welcome home!!!\r\n\r\n", 193 'Reply-Message', qr/Invalid/ => "Go away stranger\r\n\r\n", 194 ], 195 ]}); 196 my $replace_sub = $set->mk; 197 198=head1 DESCRIPTION 199 200C<Net::Radius::Server::Set::Replace> provides a simple mechanism 201allowing changes to be made to RADIUS packets. 202 203See C<Net::Radius::Server::Set> for general usage guidelines. The 204relevant attributes that control the matching of RADIUS requests are: 205 206=over 207 208=item C<attr> 209 210Takes a listref containing groups of three elements: The first is the 211name of the attribute to replace. The second, is the replacement 212condition. It must be true in order for the replacement to be 213completed. The third element is the value to be stored in the named 214attribute. 215 216The replacement condition can be of any of the following types: 217 218=over 219 220=item B<scalar> 221 222An exact match will be attempted. 223 224=item B<regexp> 225 226The value of the attribute must match the given regexp. 227 228=item B<NetAddr::IP> 229 230The value of the attribute must be convertible into a NetAddr::IP(3) 231subnet. In this case, the comparison matches if the given 232NetAddr::IP(3) range contains the current attribute. 233 234The comparison does not match if the attribute value cannot be 235converted into a NetAddr::IP(3) object. 236 237=back 238 239=item C<result> 240 241The result of the invocation of this set method. See 242C<Net::Radius::Server::Set> for more information. The example shown in 243the synopsis would cause an inmediate return of the packet. Other set 244methods after the current one won't be called at all. 245 246=item C<vsattr> 247 248Just as C<attr>, but dealing with 249C<Net::Radius::Packet-E<gt>set_vsattr()> instead. 250 251=back 252 253=head2 EXPORT 254 255None by default. 256 257 258=head1 HISTORY 259 260 $Log$ 261 Revision 1.4 2006/12/14 16:33:17 lem 262 Rules and methods will only report failures in log level 3 and 263 above. Level 4 report success and failure, for deeper debugging 264 265 Revision 1.3 2006/12/14 15:52:25 lem 266 Fix CVS tags 267 268 269=head1 SEE ALSO 270 271Perl(1), NetAddr::IP(3), Net::Radius::Server(3), 272Net::Radius::Server::Set(3), Net::Radius::Packet(3). 273 274=head1 AUTHOR 275 276Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt> 277 278=head1 COPYRIGHT AND LICENSE 279 280Copyright (C) 2006 by Luis E. Muñoz 281 282This library is free software; you can redistribute it and/or modify 283it under the same terms as Perl 5.8.6 itself. 284 285=cut 286 287 288