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