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