raddb/mods-config/perl/example.pl

   1
   2 #
   3 #  This program is free software; you can redistribute it and/or modify
   4 #  it under the terms of the GNU General Public License as published by
   5 #  the Free Software Foundation; either version 2 of the License, or
   6 #  (at your option) any later version.
   7 #
   8 #  This program is distributed in the hope that it will be useful,
   9 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #  GNU General Public License for more details.
  12 #
  13 #  You should have received a copy of the GNU General Public License
  14 #  along with this program; if not, write to the Free Software
  15 #  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  16 #
  17 #  Copyright 2002  The FreeRADIUS server project
  18 #  Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
  19 #
  20
  21 #
  22 # Example code for use with rlm_perl
  23 #
  24 # You can use every module that comes with your perl distribution!
  25 #
  26 # If you are using DBI and do some queries to DB, please be sure to
  27 # use the CLONE function to initialize the DBI connection to DB.
  28 #
  29
  30 use strict;
  31 use warnings;
  32
  33 # use ...
  34 use Data::Dumper;
  35
  36 # Bring the global hashes into the package scope
  37 our (%RAD_REQUEST, %RAD_REPLY, %RAD_CHECK);
  38
  39 # This is hash wich hold original request from radius
  40 #my %RAD_REQUEST;
  41 # In this hash you add values that will be returned to NAS.
  42 #my %RAD_REPLY;
  43 #This is for check items
  44 #my %RAD_CHECK;
  45 # This is configuration items from "config" perl module configuration section
  46 #my %RAD_PERLCONF;
  47
  48 # Multi-value attributes are mapped to perl arrayrefs.
  49 #
  50 #  update request {
  51 #    Filter-Id := 'foo'
  52 #    Filter-Id += 'bar'
  53 #  }
  54 #
  55 # This results to the following entry in %RAD_REQUEST:
  56 #
  57 #  $RAD_REQUEST{'Filter-Id'} = [ 'foo', 'bar' ];
  58 #
  59 # Likewise, you can assign an arrayref to return multi-value attributes
  60
  61 #
  62 # This the remapping of return values
  63 #
  64 use constant {
  65         RLM_MODULE_REJECT   => 0, # immediately reject the request
  66         RLM_MODULE_OK       => 2, # the module is OK, continue
  67         RLM_MODULE_HANDLED  => 3, # the module handled the request, so stop
  68         RLM_MODULE_INVALID  => 4, # the module considers the request invalid
  69         RLM_MODULE_USERLOCK => 5, # reject the request (user is locked out)
  70         RLM_MODULE_NOTFOUND => 6, # user not found
  71         RLM_MODULE_NOOP     => 7, # module succeeded without doing anything
  72         RLM_MODULE_UPDATED  => 8, # OK (pairs modified)
  73         RLM_MODULE_NUMCODES => 9  # How many return codes there are
  74 };
  75
  76 # Same as src/include/radiusd.h
  77 use constant    L_DBG=>   1;
  78 use constant    L_AUTH=>  2;
  79 use constant    L_INFO=>  3;
  80 use constant    L_ERR=>   4;
  81 use constant    L_PROXY=> 5;
  82 use constant    L_ACCT=>  6;
  83
  84 #  Global variables can persist across different calls to the module.
  85 #
  86 #
  87 #       {
  88 #        my %static_global_hash = ();
  89 #
  90 #               sub post_auth {
  91 #               ...
  92 #               }
  93 #               ...
  94 #       }
  95
  96
  97 # Function to handle authorize
  98 sub authorize {
  99         # For debugging purposes only
 100 #       &log_request_attributes;
 101
 102         # Here's where your authorization code comes
 103         # You can call another function from here:
 104         &test_call;
 105
 106         return RLM_MODULE_OK;
 107 }
 108
 109 # Function to handle authenticate
 110 sub authenticate {
 111         # For debugging purposes only
 112 #       &log_request_attributes;
 113
 114         if ($RAD_REQUEST{'User-Name'} =~ /^baduser/i) {
 115                 # Reject user and tell him why
 116                 $RAD_REPLY{'Reply-Message'} = "Denied access by rlm_perl function";
 117                 return RLM_MODULE_REJECT;
 118         } else {
 119                 # Accept user and set some attribute
 120                 $RAD_REPLY{'h323-credit-amount'} = "100";
 121                 return RLM_MODULE_OK;
 122         }
 123 }
 124
 125 # Function to handle preacct
 126 sub preacct {
 127         # For debugging purposes only
 128 #       &log_request_attributes;
 129
 130         return RLM_MODULE_OK;
 131 }
 132
 133 # Function to handle accounting
 134 sub accounting {
 135         # For debugging purposes only
 136 #       &log_request_attributes;
 137
 138         # You can call another subroutine from here
 139         &test_call;
 140
 141         return RLM_MODULE_OK;
 142 }
 143
 144 # Function to handle checksimul
 145 sub checksimul {
 146         # For debugging purposes only
 147 #       &log_request_attributes;
 148
 149         return RLM_MODULE_OK;
 150 }
 151
 152 # Function to handle pre_proxy
 153 sub pre_proxy {
 154         # For debugging purposes only
 155 #       &log_request_attributes;
 156
 157         return RLM_MODULE_OK;
 158 }
 159
 160 # Function to handle post_proxy
 161 sub post_proxy {
 162         # For debugging purposes only
 163 #       &log_request_attributes;
 164
 165         return RLM_MODULE_OK;
 166 }
 167
 168 # Function to handle post_auth
 169 sub post_auth {
 170         # For debugging purposes only
 171 #       &log_request_attributes;
 172
 173         return RLM_MODULE_OK;
 174 }
 175
 176 # Function to handle xlat
 177 sub xlat {
 178         # For debugging purposes only
 179 #       &log_request_attributes;
 180
 181         # Loads some external perl and evaluate it
 182         my ($filename,$a,$b,$c,$d) = @_;
 183         &radiusd::radlog(L_DBG, "From xlat $filename ");
 184         &radiusd::radlog(L_DBG,"From xlat $a $b $c $d ");
 185         local *FH;
 186         open FH, $filename or die "open '$filename' $!";
 187         local($/) = undef;
 188         my $sub = <FH>;
 189         close FH;
 190         my $eval = qq{ sub handler{ $sub;} };
 191         eval $eval;
 192         eval {main->handler;};
 193 }
 194
 195 # Function to handle detach
 196 sub detach {
 197         # For debugging purposes only
 198 #       &log_request_attributes;
 199 }
 200
 201 #
 202 # Some functions that can be called from other functions
 203 #
 204
 205 sub test_call {
 206         # Some code goes here
 207 }
 208
 209 sub log_request_attributes {
 210         # This shouldn't be done in production environments!
 211         # This is only meant for debugging!
 212         for (keys %RAD_REQUEST) {
 213                 &radiusd::radlog(L_DBG, "RAD_REQUEST: $_ = $RAD_REQUEST{$_}");
 214         }
 215 }
 216