git.sur5r.net Git - openldap/blob - servers/slapd/back-perl/config.c

   1 /* $OpenLDAP$ */
   2 /* This work is part of OpenLDAP Software <http://www.openldap.org/>.
   3  *
   4  * Copyright 1999-2011 The OpenLDAP Foundation.
   5  * Portions Copyright 1999 John C. Quillan.
   6  * Portions Copyright 2002 myinternet Limited.
   7  * All rights reserved.
   8  *
   9  * Redistribution and use in source and binary forms, with or without
  10  * modification, are permitted only as authorized by the OpenLDAP
  11  * Public License.
  12  *
  13  * A copy of this license is available in file LICENSE in the
  14  * top-level directory of the distribution or, alternatively, at
  15  * <http://www.OpenLDAP.org/license.html>.
  16  */
  17
  18 #include "perl_back.h"
  19 #include "../config.h"
  20
  21 static ConfigDriver perl_cf;
  22
  23 enum {
  24         PERL_MODULE = 1,
  25         PERL_PATH,
  26         PERL_CONFIG
  27 };
  28
  29 static ConfigTable perlcfg[] = {
  30         { "perlModule", "module", 2, 2, 0,
  31                 ARG_STRING|ARG_MAGIC|PERL_MODULE, perl_cf,
  32                 "( OLcfgDbAt:11.1 NAME 'olcPerlModule' "
  33                         "DESC 'Perl module name' "
  34                         "EQUALITY caseExactMatch "
  35                         "SYNTAX OMsDirectoryString SINGLE-VALUE )", NULL, NULL },
  36         { "perlModulePath", "path", 2, 2, 0,
  37                 ARG_STRING|ARG_MAGIC|PERL_PATH, perl_cf,
  38                 "( OLcfgDbAt:11.2 NAME 'olcPerlModulePath' "
  39                         "DESC 'Perl module path' "
  40                         "EQUALITY caseExactMatch "
  41                         "SYNTAX OMsDirectoryString )", NULL, NULL },
  42         { "filterSearchResults", "on|off", 2, 2, 0, ARG_ON_OFF|ARG_OFFSET,
  43                 (void *)offsetof(PerlBackend, pb_filter_search_results),
  44                 "( OLcfgDbAt:11.3 NAME 'olcPerlFilterSearchResults' "
  45                         "DESC 'Filter search results before returning to client' "
  46                         "SYNTAX OMsBoolean SINGLE-VALUE )", NULL, NULL },
  47         { "perlModuleConfig", "args", 2, 0, 0,
  48                 ARG_STRING|ARG_MAGIC|PERL_CONFIG, perl_cf,
  49                 "( OLcfgDbAt:11.4 NAME 'olcPerlModuleConfig' "
  50                         "DESC 'Perl module config directives' "
  51                         "EQUALITY caseExactMatch "
  52                         "SYNTAX OMsDirectoryString )", NULL, NULL },
  53         { NULL }
  54 };
  55
  56 static ConfigOCs perlocs[] = {
  57         { "( OLcfgDbOc:11.1 "
  58                 "NAME 'olcPerlConfig' "
  59                 "DESC 'Perl DB configuration' "
  60                 "SUP olcDatabaseConfig "
  61                 "MUST ( olcPerlModulePath $ olcPerlModule ) "
  62                 "MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
  63                         Cft_Database, perlcfg, NULL, NULL },
  64         { NULL }
  65 };
  66
  67 /**********************************************************
  68  *
  69  * Config
  70  *
  71  **********************************************************/
  72 static int
  73 perl_cf(
  74         ConfigArgs *c
  75 )
  76 {
  77         PerlBackend *pb = (PerlBackend *) c->be->be_private;
  78         SV* loc_sv;
  79         int count ;
  80         int args;
  81         int rc = 0;
  82         char eval_str[EVAL_BUF_SIZE];
  83         struct berval bv;
  84
  85         if ( c->op == SLAP_CONFIG_EMIT ) {
  86                 switch( c-> type ) {
  87                 case PERL_MODULE:
  88                         if ( bv.bv_len < 1 )
  89                                 return 1;
  90                         value_add_one( &c->rvalue_vals, &pb->pb_module_name );
  91                         break;
  92                 case PERL_PATH:
  93                         if ( !pb->pb_module_path )
  94                                 return 1;
  95                         ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
  96                         break;
  97                 case PERL_CONFIG:
  98                         if ( !pb->pb_module_config )
  99                                 return 1;
 100                         ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
 101                         break;
 102                 }
 103         } else if ( c->op == LDAP_MOD_DELETE ) {
 104                 /* FIXME: none of this affects the state of the perl
 105                  * interpreter at all. We should probably destroy it
 106                  * and recreate it...
 107                  */
 108                 switch( c-> type ) {
 109                 case PERL_MODULE:
 110                         ch_free( pb->pb_module_name.bv_val );
 111                         BER_BVZERO( &pb->pb_module_name );
 112                         break;
 113                 case PERL_PATH:
 114                         if ( c->valx < 0 ) {
 115                                 ber_bvarray_free( pb->pb_module_path );
 116                                 pb->pb_module_path = NULL;
 117                         } else {
 118                                 int i = c->valx;
 119                                 ch_free( pb->pb_module_path[i].bv_val );
 120                                 for (; pb->pb_module_path[i].bv_val; i++ )
 121                                         pb->pb_module_path[i] = pb->pb_module_path[i+1];
 122                         }
 123                         break;
 124                 case PERL_CONFIG:
 125                         if ( c->valx < 0 ) {
 126                                 ber_bvarray_free( pb->pb_module_config );
 127                                 pb->pb_module_config = NULL;
 128                         } else {
 129                                 int i = c->valx;
 130                                 ch_free( pb->pb_module_config[i].bv_val );
 131                                 for (; pb->pb_module_config[i].bv_val; i++ )
 132                                         pb->pb_module_config[i] = pb->pb_module_config[i+1];
 133                         }
 134                         break;
 135                 }
 136         } else {
 137                 switch( c->type ) {
 138                 case PERL_MODULE:
 139 #ifdef PERL_IS_5_6
 140                         snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
 141                         eval_pv( eval_str, 0 );
 142 #else
 143                         snprintf( eval_str, EVAL_BUF_SIZE, "%s.pm", c->argv[1] );
 144                         perl_require_pv( eval_str );
 145 #endif /* PERL_IS_5_6 */
 146
 147                         if (SvTRUE(ERRSV)) {
 148                                 STRLEN len;
 149
 150                                 snprintf( c->cr_msg, sizeof( c->cr_msg ), "%s: error %s",
 151                                         c->log, SvPV(ERRSV, len ));
 152                                 Debug( LDAP_DEBUG_ANY, "%s\n", c->cr_msg, 0, 0 );
 153                                 rc = 1;
 154                         } else {
 155                                 dSP; ENTER; SAVETMPS;
 156                                 PUSHMARK(sp);
 157                                 XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0)));
 158                                 PUTBACK;
 159
 160                                 count = call_method("new", G_SCALAR);
 161
 162                                 SPAGAIN;
 163
 164                                 if (count != 1) {
 165                                         croak("Big trouble in config\n") ;
 166                                 }
 167
 168                                 pb->pb_obj_ref = newSVsv(POPs);
 169
 170                                 PUTBACK; FREETMPS; LEAVE ;
 171                                 ber_str2bv( c->argv[1], 0, 1, &pb->pb_module_name );
 172                         }
 173                         break;
 174
 175                 case PERL_PATH:
 176                         snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", c->argv[1] );
 177                         loc_sv = eval_pv( eval_str, 0 );
 178                         /* XXX loc_sv return value is ignored. */
 179                         ber_str2bv( c->argv[1], 0, 0, &bv );
 180                         value_add_one( &pb->pb_module_path, &bv );
 181                         break;
 182
 183                 case PERL_CONFIG: {
 184                         dSP ;  ENTER ; SAVETMPS;
 185
 186                         PUSHMARK(sp) ;
 187                         XPUSHs( pb->pb_obj_ref );
 188
 189                         /* Put all arguments on the perl stack */
 190                         for( args = 1; args < c->argc; args++ ) {
 191                                 XPUSHs(sv_2mortal(newSVpv(c->argv[args], 0)));
 192                         }
 193
 194                         PUTBACK ;
 195
 196                         count = call_method("config", G_SCALAR);
 197
 198                         SPAGAIN ;
 199
 200                         if (count != 1) {
 201                                 croak("Big trouble in config\n") ;
 202                         }
 203
 204                         rc = POPi;
 205
 206                         PUTBACK ; FREETMPS ;  LEAVE ;
 207                         }
 208                         break;
 209                 }
 210         }
 211         return rc;
 212 }
 213
 214 int
 215 perl_back_init_cf( BackendInfo *bi )
 216 {
 217         bi->bi_cf_ocs = perlocs;
 218
 219         return config_register_schema( perlcfg, perlocs );
 220 }