Re: working rlm_perl example ?

20 Sep 2006

      Michael Gale wrote:
...
Hello,
Does anyone have a working rlm_perl module I can test with ? I have
just started out and at this point can not determine if it is my perl
module that is having a problem or my radius configuration.
An example comes with the freeradius source code in /src/modules/rlm_perl

#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#  Copyright 2002  The FreeRADIUS server project
#  Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
#

#
# Example code for use with rlm_perl
#
# You can use every module that comes with your perl distribution!
#

use strict;
# use ...
# This is very important ! Without this script will not get the filled
hashesh from main.
use vars qw(%RAD_REQUEST %RAD_REPLY %RAD_CHECK);
use Data::Dumper;

# This is hash wich hold original request from radius
#my %RAD_REQUEST;
# In this hash you add values that will be returned to NAS.
#my %RAD_REPLY;
#This is for check items
#my %RAD_CHECK;

#
# This the remapping of return values
#
 use constant    RLM_MODULE_REJECT=>    0;#  /* immediately reject the
request */
 use constant RLM_MODULE_FAIL=>      1;#  /* module failed, don't reply */
 use constant RLM_MODULE_OK=>        2;#  /* the module is OK, continue */
 use constant RLM_MODULE_HANDLED=>   3;#  /* the module handled the request,
so stop. */
 use constant RLM_MODULE_INVALID=>   4;#  /* the module considers the
request invalid. */
 use constant RLM_MODULE_USERLOCK=>  5;#  /* reject the request (user is
locked out) */
 use constant RLM_MODULE_NOTFOUND=>  6;#  /* user not found */
 use constant RLM_MODULE_NOOP=>      7;#  /* module succeeded without doing
anything */
 use constant RLM_MODULE_UPDATED=>   8;#  /* OK (pairs modified) */
 use constant RLM_MODULE_NUMCODES=>  9;#  /* How many return codes there are
*/

# Function to handle authorize
sub authorize {
 # For debugging purposes only
# &log_request_attributes;

 # Here's where your authorization code comes
 # You can call another function from here:
 &test_call;

 return RLM_MODULE_OK;
}

# Function to handle authenticate
sub authenticate {
 # For debugging purposes only
# &log_request_attributes;

 if ($RAD_REQUEST{'User-Name'} =~ /^baduser/i) {
  # Reject user and tell him why
  $RAD_REPLY{'Reply-Message'} = "Denied access by rlm_perl function";
  return RLM_MODULE_REJECT;
 } else {
  # Accept user and set some attribute
  $RAD_REPLY{'h323-credit-amount'} = "100";
  return RLM_MODULE_OK;
 }
}

# Function to handle preacct
sub preacct {
 # For debugging purposes only
# &log_request_attributes;

 return RLM_MODULE_OK;
}

# Function to handle accounting
sub accounting {
 # For debugging purposes only
# &log_request_attributes;

 # You can call another subroutine from here
 &test_call;

 return RLM_MODULE_OK;
}

# Function to handle checksimul
sub checksimul {
 # For debugging purposes only
# &log_request_attributes;

 return RLM_MODULE_OK;
}

# Function to handle pre_proxy
sub pre_proxy {
 # For debugging purposes only
# &log_request_attributes;

 return RLM_MODULE_OK;
}

# Function to handle post_proxy
sub post_proxy {
 # For debugging purposes only
# &log_request_attributes;

 return RLM_MODULE_OK;
}

# Function to handle post_auth
sub post_auth {
 # For debugging purposes only
# &log_request_attributes;

 return RLM_MODULE_OK;
}

# Function to handle xlat
sub xlat {
 # For debugging purposes only
# &log_request_attributes;

 # Loads some external perl and evaluate it
 my ($filename,$a,$b,$c,$d) = @_;
 &radiusd::radlog(1, "From xlat $filename ");
 &radiusd::radlog(1,"From xlat $a $b $c $d ");
 local *FH;
 open FH, $filename or die "open '$filename' $!";
 local($/) = undef;
 my $sub = <FH>;
 close FH;
 my $eval = qq{ sub handler{ $sub;} };
 eval $eval;
 eval {main->handler;};
}

# Function to handle detach
sub detach {
 # For debugging purposes only
# &log_request_attributes;

 # Do some logging.
 &radiusd::radlog(0,"rlm_perl::Detaching. Reloading. Done.");
}

#
# Some functions that can be called from other functions
#

sub test_call {
 # Some code goes here
}

sub log_request_attributes {
 # This shouldn't be done in production environments!
 # This is only meant for debugging!
 for (keys %RAD_REQUEST) {
  &radiusd::radlog(1, "RAD_REQUEST: $_ = $RAD_REQUEST{$_}");
 }
}

--
Groeten, Regards, Salutations,

Thor Spruyt
M: +32 (0)475 67 22 65
E: thor.spruyt@telenet.be
W: www.thor-spruyt.com

www.salesguide.be
www.telenethotspot.be