1#! /usr/bin/perl 2# 3# 4# $Id: Set.pm 75 2009-08-12 22:08:28Z lem $ 5 6package Net::Radius::Server::Set; 7 8use 5.008; 9use strict; 10use warnings; 11use Carp qw/croak/; 12 13use Net::Radius::Server::Base ':set'; 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->_set(@_) }; 32} 33 34sub _set 35{ 36 my $self = shift; 37 my $r_args = shift; 38 39 for my $arg (sort keys %$self) 40 { 41 next if $arg =~ /^_/; 42 if ($self->can('set_' . $arg)) 43 { 44 no strict 'refs'; 45 my $m = 'set_' . $arg; 46 $self->log(4, "Invoking set method $m"); 47 $self->$m($r_args, @_); 48 } 49 } 50 51 if ($self->can('result') and exists $self->{result}) 52 { 53 my $r = $self->result; 54 $self->log(4, "Set returning $r"); 55 return $r; 56 } 57 58 $self->log(4, "Set returning CONTINUE by default"); 59 return NRS_SET_CONTINUE; 60} 61 6242; 63 64__END__ 65 66=head1 NAME 67 68Net::Radius::Server::Set - Base class for set methods 69 70=head1 SYNOPSIS 71 72 package My::Radius::Set; 73 use base 'Net::Radius::Server::Set'; 74 75 __PACKAGE__->mk_accessors(qw/foo bar baz/); 76 77 sub set_foo { ... } 78 sub set_bar { ... } 79 sub set_baz { ... } 80 81 # Meanwhile, in a configuration file nearby... 82 my $set = My::Radius::Set->new({ foo => 'x', bar => 'y' }); 83 my $set_sub = $set->mk; 84 ... 85 86 # Alternatively, in a more compact notation... 87 my $set_sub = My::Radius::Set->mk({ foo => 'x', bar => 'y' }); 88 89=head1 DESCRIPTION 90 91C<Net::Radius::Server::Set> is a base class for developing "set" 92methods to be used in C<Net::Radius::Server> rules. 93 94C<Net::Radius::Server::Set>'s C<new()> will honor a property called 95C<result>, that will be used as the return value of the 96method. Otherwise, C<NRS_SET_CONTINUE> will be returned. Note that you 97can define the C<set_result> hook, causing the result of the request 98to be calculated at packet processing time. 99 100=over 101 102=item C<-E<gt>new($hashref)> 103 104Creates a new C<Net::Radius::Server::Set> object. C<$hashref> 105referenes a hash with the attributes that will apply to this object, 106so that multiple set methods (that will share the same underlying 107object) can be created and given to different rules. 108 109=item C<$self-E<gt>mk()> or C<__PACKAGE__-E<gt>mk($hashref)> 110 111This method returns a sub suitable for calling as a set method for a 112C<Net::Radius::Server> rule. The resulting sub will return whatever is 113defined in its C<result> property. 114 115The sub contains a closure where the object attributes -- Actually, 116the object itself -- are kept. 117 118When invoked as an object method (ie, C<$self-E<gt>mk()>), no 119arguments can be given. The object is preserved as is within the 120closure. 121 122When invoked as a class method (ie, C<__PACKAGE__-E<gt>mk($hashref)>), 123a new object is created with the given arguments and then, this object 124is preserved within the closure. This form is useful for compact 125filter definitions that require little or no surrounding code or 126holding variables. 127 128=item C<-E<gt>_set()> 129 130This method is internally called by the sub returned by the call to 131C<-E<gt>mk()> and should not be called explicitly. This method 132iterates through the existing elements in the object -- It is assumed 133that it is a blessed hash ref, as left by C<Class::Accessor>. 134 135This method tries to invoke C<$self->set_$element(@_)>, passing the 136same arguments it receives - Note that normally, those are the same 137that were passed to the sub returned by the factory. 138 139See the source of C<Net::Radius::Server::Set::Simple>. This is much 140simpler than it sounds. Really. 141 142Arguments with no corresponding C<set_*> method are 143ignored. Arguments whose name start with "_" are also ignored. 144 145After invoking all the required C<set_*> methods, whatever is 146specified in the C<result> property or the default value is returned. 147 148=back 149 150=head2 Methods to Provide in Derived Classes 151 152As shown in the example in the SYNOPSIS, your derived class must 153provide a C<match_*> method for each attribute you define. 154 155The method must return any of the C<NRS_MATCH_*> constants to indicate 156its result. 157 158=head2 EXPORT 159 160None by default. 161 162 163=head1 HISTORY 164 165 $Log$ 166 Revision 1.4 2006/12/14 16:33:17 lem 167 Rules and methods will only report failures in log level 3 and 168 above. Level 4 report success and failure, for deeper debugging 169 170 Revision 1.3 2006/12/14 15:52:25 lem 171 Fix CVS tags 172 173 174=head1 SEE ALSO 175 176Perl(1), Class::Accessor(3), Net::Radius::Server(3). 177 178=head1 AUTHOR 179 180Luis E. Muñoz, E<lt>luismunoz@cpan.orgE<gt> 181 182=head1 COPYRIGHT AND LICENSE 183 184Copyright (C) 2006 by Luis E. Muñoz 185 186This library is free software; you can redistribute it and/or modify 187it under the same terms as Perl 5.8.6 itself. 188 189=cut 190 191 192