Back to index

openldap  2.4.31
config.c
Go to the documentation of this file.
00001 /* $OpenLDAP$ */
00002 /* This work is part of OpenLDAP Software <http://www.openldap.org/>.
00003  *
00004  * Copyright 1999-2012 The OpenLDAP Foundation.
00005  * Portions Copyright 1999 John C. Quillan.
00006  * Portions Copyright 2002 myinternet Limited.
00007  * All rights reserved.
00008  *
00009  * Redistribution and use in source and binary forms, with or without
00010  * modification, are permitted only as authorized by the OpenLDAP
00011  * Public License.
00012  *
00013  * A copy of this license is available in file LICENSE in the
00014  * top-level directory of the distribution or, alternatively, at
00015  * <http://www.OpenLDAP.org/license.html>.
00016  */
00017 
00018 #include "perl_back.h"
00019 #include "../config.h"
00020 
00021 static ConfigDriver perl_cf;
00022 
00023 enum {
00024        PERL_MODULE = 1,
00025        PERL_PATH,
00026        PERL_CONFIG
00027 };
00028 
00029 static ConfigTable perlcfg[] = {
00030        { "perlModule", "module", 2, 2, 0,
00031               ARG_STRING|ARG_MAGIC|PERL_MODULE, perl_cf, 
00032               "( OLcfgDbAt:11.1 NAME 'olcPerlModule' "
00033                      "DESC 'Perl module name' "
00034                      "EQUALITY caseExactMatch "
00035                      "SYNTAX OMsDirectoryString SINGLE-VALUE )", NULL, NULL },
00036        { "perlModulePath", "path", 2, 2, 0,
00037               ARG_MAGIC|PERL_PATH, perl_cf, 
00038               "( OLcfgDbAt:11.2 NAME 'olcPerlModulePath' "
00039                      "DESC 'Perl module path' "
00040                      "EQUALITY caseExactMatch "
00041                      "SYNTAX OMsDirectoryString )", NULL, NULL },
00042        { "filterSearchResults", "on|off", 2, 2, 0, ARG_ON_OFF|ARG_OFFSET,
00043               (void *)offsetof(PerlBackend, pb_filter_search_results),
00044               "( OLcfgDbAt:11.3 NAME 'olcPerlFilterSearchResults' "
00045                      "DESC 'Filter search results before returning to client' "
00046                      "SYNTAX OMsBoolean SINGLE-VALUE )", NULL, NULL },
00047        { "perlModuleConfig", "args", 2, 0, 0,
00048               ARG_MAGIC|PERL_CONFIG, perl_cf, 
00049               "( OLcfgDbAt:11.4 NAME 'olcPerlModuleConfig' "
00050                      "DESC 'Perl module config directives' "
00051                      "EQUALITY caseExactMatch "
00052                      "SYNTAX OMsDirectoryString )", NULL, NULL },
00053        { NULL }
00054 };
00055 
00056 static ConfigOCs perlocs[] = {
00057        { "( OLcfgDbOc:11.1 "
00058               "NAME 'olcDbPerlConfig' "
00059               "DESC 'Perl DB configuration' "
00060               "SUP olcDatabaseConfig "
00061               "MUST ( olcPerlModulePath $ olcPerlModule ) "
00062               "MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
00063                      Cft_Database, perlcfg, NULL, NULL },
00064        { NULL }
00065 };
00066 
00067 static ConfigOCs ovperlocs[] = {
00068        { "( OLcfgDbOc:11.2 "
00069               "NAME 'olcovPerlConfig' "
00070               "DESC 'Perl overlay configuration' "
00071               "SUP olcOverlayConfig "
00072               "MUST ( olcPerlModulePath $ olcPerlModule ) "
00073               "MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
00074                      Cft_Overlay, perlcfg, NULL, NULL },
00075        { NULL }
00076 };
00077 
00078 /**********************************************************
00079  *
00080  * Config
00081  *
00082  **********************************************************/
00083 int
00084 perl_back_db_config(
00085        BackendDB *be,
00086        const char *fname,
00087        int lineno,
00088        int argc,
00089        char **argv
00090 )
00091 {
00092        int rc = config_generic_wrapper( be, fname, lineno, argc, argv );
00093        /* backward compatibility: map unknown directives to perlModuleConfig */
00094        if ( rc == SLAP_CONF_UNKNOWN ) {
00095               char **av = ch_malloc( (argc+2) * sizeof(char *));
00096               int i;
00097               av[0] = "perlModuleConfig";
00098               av++;
00099               for ( i=0; i<argc; i++ )
00100                      av[i] = argv[i];
00101               av[i] = NULL;
00102               av--;
00103               rc = config_generic_wrapper( be, fname, lineno, argc+1, av );
00104               ch_free( av );
00105        }
00106        return rc;
00107 }
00108 
00109 static int
00110 perl_cf(
00111        ConfigArgs *c
00112 )
00113 {
00114        PerlBackend *pb = (PerlBackend *) c->be->be_private;
00115        SV* loc_sv;
00116        int count ;
00117        int args;
00118        int rc = 0;
00119        char eval_str[EVAL_BUF_SIZE];
00120        struct berval bv;
00121 
00122        if ( c->op == SLAP_CONFIG_EMIT ) {
00123               switch( c-> type ) {
00124               case PERL_MODULE:
00125                      if ( !pb->pb_module_name )
00126                             return 1;
00127                      c->value_string = ch_strdup( pb->pb_module_name );
00128                      break;
00129               case PERL_PATH:
00130                      if ( !pb->pb_module_path )
00131                             return 1;
00132                      ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
00133                      break;
00134               case PERL_CONFIG:
00135                      if ( !pb->pb_module_config )
00136                             return 1;
00137                      ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
00138                      break;
00139               }
00140        } else if ( c->op == LDAP_MOD_DELETE ) {
00141               /* FIXME: none of this affects the state of the perl
00142                * interpreter at all. We should probably destroy it
00143                * and recreate it...
00144                */
00145               switch( c-> type ) {
00146               case PERL_MODULE:
00147                      ch_free( pb->pb_module_name );
00148                      pb->pb_module_name = NULL;
00149                      break;
00150               case PERL_PATH:
00151                      if ( c->valx < 0 ) {
00152                             ber_bvarray_free( pb->pb_module_path );
00153                             pb->pb_module_path = NULL;
00154                      } else {
00155                             int i = c->valx;
00156                             ch_free( pb->pb_module_path[i].bv_val );
00157                             for (; pb->pb_module_path[i].bv_val; i++ )
00158                                    pb->pb_module_path[i] = pb->pb_module_path[i+1];
00159                      }
00160                      break;
00161               case PERL_CONFIG:
00162                      if ( c->valx < 0 ) {
00163                             ber_bvarray_free( pb->pb_module_config );
00164                             pb->pb_module_config = NULL;
00165                      } else {
00166                             int i = c->valx;
00167                             ch_free( pb->pb_module_config[i].bv_val );
00168                             for (; pb->pb_module_config[i].bv_val; i++ )
00169                                    pb->pb_module_config[i] = pb->pb_module_config[i+1];
00170                      }
00171                      break;
00172               }
00173        } else {
00174               switch( c->type ) {
00175               case PERL_MODULE:
00176                      snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
00177                      eval_pv( eval_str, 0 );
00178 
00179                      if (SvTRUE(ERRSV)) {
00180                             STRLEN len;
00181 
00182                             snprintf( c->cr_msg, sizeof( c->cr_msg ), "%s: error %s",
00183                                    c->log, SvPV(ERRSV, len ));
00184                             Debug( LDAP_DEBUG_ANY, "%s\n", c->cr_msg, 0, 0 );
00185                             rc = 1;
00186                      } else {
00187                             dSP; ENTER; SAVETMPS;
00188                             PUSHMARK(sp);
00189                             XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0)));
00190                             PUTBACK;
00191 
00192                             count = call_method("new", G_SCALAR);
00193 
00194                             SPAGAIN;
00195 
00196                             if (count != 1) {
00197                                    croak("Big trouble in config\n") ;
00198                             }
00199 
00200                             pb->pb_obj_ref = newSVsv(POPs);
00201 
00202                             PUTBACK; FREETMPS; LEAVE ;
00203                             pb->pb_module_name = ch_strdup( c->argv[1] );
00204                      }
00205                      break;
00206 
00207               case PERL_PATH:
00208                      snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", c->argv[1] );
00209                      loc_sv = eval_pv( eval_str, 0 );
00210                      /* XXX loc_sv return value is ignored. */
00211                      ber_str2bv( c->argv[1], 0, 0, &bv );
00212                      value_add_one( &pb->pb_module_path, &bv );
00213                      break;
00214 
00215               case PERL_CONFIG: {
00216                      dSP ;  ENTER ; SAVETMPS;
00217 
00218                      PUSHMARK(sp) ;
00219                      XPUSHs( pb->pb_obj_ref );
00220 
00221                      /* Put all arguments on the perl stack */
00222                      for( args = 1; args < c->argc; args++ ) {
00223                             XPUSHs(sv_2mortal(newSVpv(c->argv[args], 0)));
00224                      }
00225 
00226                      PUTBACK ;
00227 
00228                      count = call_method("config", G_SCALAR);
00229 
00230                      SPAGAIN ;
00231 
00232                      if (count != 1) {
00233                             croak("Big trouble in config\n") ;
00234                      }
00235 
00236                      rc = POPi;
00237 
00238                      PUTBACK ; FREETMPS ;  LEAVE ;
00239                      }
00240                      break;
00241               }
00242        }
00243        return rc;
00244 }
00245 
00246 int
00247 perl_back_init_cf( BackendInfo *bi )
00248 {
00249        bi->bi_cf_ocs = perlocs;
00250 
00251        return config_register_schema( perlcfg, perlocs );
00252 }