src/modules/rlm_perl/example.pl

   1 #
   2 #  This program is free software; you can redistribute it and/or modify
   3 #  it under the terms of the GNU General Public License as published by
   4 #  the Free Software Foundation; either version 2 of the License, or
   5 #  (at your option) any later version.
   6 #
   7 #  This program is distributed in the hope that it will be useful,
   8 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
   9 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10 #  GNU General Public License for more details.
  11 #
  12 #  You should have received a copy of the GNU General Public License
  13 #  along with this program; if not, write to the Free Software
  14 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  15 #
  16 #  Copyright 2002  The FreeRADIUS server project
  17 #  Copyright 2002  Boian Jordanov <bjordanov@orbitel.bg>
  18 #
  19
  20 #
  21 # Example code for use with rlm_perl
  22 #
  23 # You can use every module that comes with your perl distribution!
  24 #
  25
  26 use strict;
  27 # use ...
  28 # This is very important ! Without this script will not get the filled hashesh from main.
  29 use vars qw(%RAD_REQUEST %RAD_REPLY %RAD_CHECK);
  30 use Data::Dumper;
  31
  32 # This is hash wich hold original request from radius
  33 #my %RAD_REQUEST;
  34 # In this hash you add values that will be returned to NAS.
  35 #my %RAD_REPLY;
  36 #This is for check items
  37 #my %RAD_CHECK;
  38
  39 #
  40 # This the remapping of return values
  41 #
  42         use constant    RLM_MODULE_REJECT=>    0;#  /* immediately reject the request */
  43         use constant    RLM_MODULE_FAIL=>      1;#  /* module failed, don't reply */
  44         use constant    RLM_MODULE_OK=>        2;#  /* the module is OK, continue */
  45         use constant    RLM_MODULE_HANDLED=>   3;#  /* the module handled the request, so stop. */
  46         use constant    RLM_MODULE_INVALID=>   4;#  /* the module considers the request invalid. */
  47         use constant    RLM_MODULE_USERLOCK=>  5;#  /* reject the request (user is locked out) */
  48         use constant    RLM_MODULE_NOTFOUND=>  6;#  /* user not found */
  49         use constant    RLM_MODULE_NOOP=>      7;#  /* module succeeded without doing anything */
  50         use constant    RLM_MODULE_UPDATED=>   8;#  /* OK (pairs modified) */
  51         use constant    RLM_MODULE_NUMCODES=>  9;#  /* How many return codes there are */
  52
  53 # Function to handle authorize
  54 sub authorize {
  55         # For debugging purposes only
  56 #       &log_request_attributes;
  57
  58         # Here's where your authorization code comes
  59         # You can call another function from here:
  60         &test_call;
  61
  62         return RLM_MODULE_OK;
  63 }
  64
  65 # Function to handle authenticate
  66 sub authenticate {
  67         # For debugging purposes only
  68 #       &log_request_attributes;
  69
  70         if ($RAD_REQUEST{'User-Name'} =~ /^baduser/i) {
  71                 # Reject user and tell him why
  72                 $RAD_REPLY{'Reply-Message'} = "Denied access by rlm_perl function";
  73                 return RLM_MODULE_REJECT;
  74         } else {
  75                 # Accept user and set some attribute
  76                 $RAD_REPLY{'h323-credit-amount'} = "100";
  77                 return RLM_MODULE_OK;
  78         }
  79 }
  80
  81 # Function to handle preacct
  82 sub preacct {
  83         # For debugging purposes only
  84 #       &log_request_attributes;
  85
  86         return RLM_MODULE_OK;
  87 }
  88
  89 # Function to handle accounting
  90 sub accounting {
  91         # For debugging purposes only
  92 #       &log_request_attributes;
  93
  94         # You can call another subroutine from here
  95         &test_call;
  96
  97         return RLM_MODULE_OK;
  98 }
  99
 100 # Function to handle checksimul
 101 sub checksimul {
 102         # For debugging purposes only
 103 #       &log_request_attributes;
 104
 105         return RLM_MODULE_OK;
 106 }
 107
 108 # Function to handle pre_proxy
 109 sub pre_proxy {
 110         # For debugging purposes only
 111 #       &log_request_attributes;
 112
 113         return RLM_MODULE_OK;
 114 }
 115
 116 # Function to handle post_proxy
 117 sub post_proxy {
 118         # For debugging purposes only
 119 #       &log_request_attributes;
 120
 121         return RLM_MODULE_OK;
 122 }
 123
 124 # Function to handle post_auth
 125 sub post_auth {
 126         # For debugging purposes only
 127 #       &log_request_attributes;
 128
 129         return RLM_MODULE_OK;
 130 }
 131
 132 # Function to handle xlat
 133 sub xlat {
 134         # For debugging purposes only
 135 #       &log_request_attributes;
 136
 137         # Loads some external perl and evaluate it
 138         my ($filename,$a,$b,$c,$d) = @_;
 139         &radiusd::radlog(1, "From xlat $filename ");
 140         &radiusd::radlog(1,"From xlat $a $b $c $d ");
 141         local *FH;
 142         open FH, $filename or die "open '$filename' $!";
 143         local($/) = undef;
 144         my $sub = <FH>;
 145         close FH;
 146         my $eval = qq{ sub handler{ $sub;} };
 147         eval $eval;
 148         eval {main->handler;};
 149 }
 150
 151 # Function to handle detach
 152 sub detach {
 153         # For debugging purposes only
 154 #       &log_request_attributes;
 155
 156         # Do some logging.
 157         &radiusd::radlog(0,"rlm_perl::Detaching. Reloading. Done.");
 158 }
 159
 160 #
 161 # Some functions that can be called from other functions
 162 #
 163
 164 sub test_call {
 165         # Some code goes here
 166 }
 167
 168 sub log_request_attributes {
 169         # This shouldn't be done in production environments!
 170         # This is only meant for debugging!
 171         for (keys %RAD_REQUEST) {
 172                 &radiusd::radlog(1, "RAD_REQUEST: $_ = $RAD_REQUEST{$_}");
 173         }
 174 }
 175