1#! /usr/bin/perl
2#
3#
4# $Id: Match.pm 75 2009-08-12 22:08:28Z lem $
5
6package Net::Radius::Server::Match;
7
8use 5.008;
9use strict;
10use warnings;
11use Carp qw/croak/;
12
13use Net::Radius::Server::Base ':match';
14use base 'Net::Radius::Server::Base';
15our $VERSION = do { sprintf "%0.3f", 1+(q$Revision: 75 $ =~ /\d+/g)[0]/1000 };
16
17sub mk
18{
19    my $self = shift;
20    croak "->mk() cannot have arguments when in object-method mode\n"
21	if ref($self) and $self->isa('UNIVERSAL') and @_;
22
23    my $n = $self;
24
25    if (@_)
26    {
27	$n = $self->new(@_);
28	die "Failed to create new object\n" unless $n;
29    }
30
31    return sub { $n->_match(@_) };
32}
33
34sub _match
35{
36    my $self	= shift;
37    my $r_args	= shift;
38
39    for my $arg (sort keys %$self)
40    {
41	my $n = NRS_MATCH_OK;
42	next if $arg =~ /^_/;
43	if ($self->can('match_' . $arg))
44	{
45	    no strict 'refs';
46	    my $m = 'match_' . $arg;
47	    $self->log(4, "Invoking match method $m");
48	    $n = $self->$m($r_args, @_);
49	}
50	unless ($n == NRS_MATCH_OK)
51	{
52	    if ($r_args->{dict})
53	    {
54		$self->log(2, "Fail request from " .
55			   ($r_args->{request}->attr
56			    ($r_args->{dict}->attr_name(4))
57			    || '(no NAS-IP-Address)')
58			   . " [" . ($r_args->{peer_addr} || '(no peer)')
59			   . "] for user "
60			   . ($r_args->{request}->attr
61			      ($r_args->{dict}->attr_name(1))
62			      || '(no user)'));
63	    }
64	    else
65	    {
66		$self->log(2, "Fail request from ["
67			   . ($r_args->{peer_addr} || '(no peer)')
68			   . "] and no dictionary");
69	    }
70	    $self->log(4, "Return $n from match method");
71	    return $n;
72	}
73    }
74
75    if ($r_args->{dict})
76    {
77	$self->log(2, "Match request from " .
78		   ($r_args->{request}->attr
79		    ($r_args->{dict}->attr_name(4))
80		    || '(no NAS-IP-Address)')
81		   . " [" . ($r_args->{peer_addr} || '(no peer)')
82		   . "] for user "
83		   . ($r_args->{request}->attr
84		      ($r_args->{dict}->attr_name(1))
85		      || '(no user)'));
86    }
87    else
88    {
89	$self->log(2, "Match request from ["
90		   . ($r_args->{peer_addr} || '(no peer)')
91		   . "] and no dictionary");
92    }
93    return NRS_MATCH_OK;	# Fail by default
94}
95
9642;
97
98__END__
99
100=head1 NAME
101
102Net::Radius::Server::Match - Base class for match methods
103
104=head1 SYNOPSIS
105
106  package My::Radius::Match;
107  use base 'Net::Radius::Server::Match';
108
109  __PACKAGE__->mk_accessors(qw/foo bar baz/);
110
111  sub match_foo { ... }
112  sub match_bar { ... }
113  sub match_baz { ... }
114
115  # Meanwhile, in a configuration file nearby...
116  my $match = My::Radius::Match->new({ foo => 'x', bar => 'y' });
117  my $match_sub = $match->mk;
118  ...
119
120  # Alternatively, in a more compact notation...
121  my $match_sub = My::Radius::Match->mk({ foo => 'x', bar => 'y' });
122
123=head1 DESCRIPTION
124
125C<Net::Radius::Server::Match> is a base class for developing "match"
126methods to be used in C<Net::Radius::Server> rules.
127
128=over
129
130=item C<-E<gt>new($hashref)>
131
132Creates a new C<Net::Radius::Server::Match> object. C<$hashref>
133referenes a hash with the attributes that will apply to this object,
134so that multiple match methods (that will share the same underlying
135object) can be created and given to different rules.
136
137=item C<$self-E<gt>mk()> or C<__PACKAGE__-E<gt>mk($hashref)>
138
139This method returns a sub suitable for calling as a match method for a
140C<Net::Radius::Server> rule. The resulting sub will return either
141C<NRS_MATCH_OK> or C<NRS_MATCH_FAIL> depending on its result.
142
143The sub contains a closure where the object attributes -- Actually,
144the object itself -- are kept.
145
146When invoked as an object method (ie, C<$self-E<gt>mk()>), no
147arguments can be given. The object is preserved as is within the
148closure.
149
150When invoked as a class method (ie, C<__PACKAGE__-E<gt>mk($hashref)>),
151a new object is created with the given arguments and then, this object
152is preserved within the closure. This form is useful for compact
153filter definitions that require little or no surrounding code or
154holding variables.
155
156=item C<-E<gt>_match()>
157
158This method is internally called by the sub returned by the call to
159C<-E<gt>mk()> and should not be called explicitly. This method
160iterates through the existing elements in the object -- It is assumed
161that it is a blessed hash ref, as left by C<Class::Accessor>.
162
163This method tries to invoke C<$self->match_$element(@_)>, passing the
164same arguments it receives - Note that normally, those are the same
165that were passed to the sub returned by the factory.
166
167See the source of C<Net::Radius::Server::Match::Simple>. This is much
168simpler than it sounds. Really.
169
170The calls are done in "short circuit". This means that the first
171method returning C<NRS_MATCH_FAIL> will cause this result to be
172returned.
173
174Arguments with no corresponding C<match_*> method are
175ignored. Arguments whose name start with "_" are also ignored.
176
177By default, this method will return C<NRS_MATCH_OK>.
178
179=back
180
181=head2 Methods to Provide in Derived Classes
182
183As shown in the example in the SYNOPSIS, your derived class must
184provide a C<match_*> method for each attribute you define.
185
186The method must return any of the C<NRS_MATCH_*> constants to indicate
187its result.
188
189=head2 EXPORT
190
191None by default.
192
193
194=head1 HISTORY
195
196  $Log$
197  Revision 1.6  2006/12/14 16:33:17  lem
198  Rules and methods will only report failures in log level 3 and
199  above. Level 4 report success and failure, for deeper debugging
200
201  Revision 1.5  2006/12/14 15:52:25  lem
202  Fix CVS tags
203
204
205=head1 SEE ALSO
206
207Perl(1), Class::Accessor(3), Net::Radius::Server(3).
208
209=head1 AUTHOR
210
211Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt>
212
213=head1 COPYRIGHT AND LICENSE
214
215Copyright (C) 2006 by Luis E. Muñoz
216
217This library is free software; you can redistribute it and/or modify
218it under the same terms as Perl 5.8.6 itself.
219
220=cut
221
222
223