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