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-2016 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_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_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 'olcDbPerlConfig' "
  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 static ConfigOCs ovperlocs[] = {
  68         { "( OLcfgDbOc:11.2 "
  69                 "NAME 'olcovPerlConfig' "
  70                 "DESC 'Perl overlay configuration' "
  71                 "SUP olcOverlayConfig "
  72                 "MUST ( olcPerlModulePath $ olcPerlModule ) "
  73                 "MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
  74                         Cft_Overlay, perlcfg, NULL, NULL },
  75         { NULL }
  76 };
  77
  78 /**********************************************************
  79  *
  80  * Config
  81  *
  82  **********************************************************/
  83 int
  84 perl_back_db_config(
  85         BackendDB *be,
  86         const char *fname,
  87         int lineno,
  88         int argc,
  89         char **argv
  90 )
  91 {
  92         int rc = config_generic_wrapper( be, fname, lineno, argc, argv );
  93         /* backward compatibility: map unknown directives to perlModuleConfig */
  94         if ( rc == SLAP_CONF_UNKNOWN ) {
  95                 char **av = ch_malloc( (argc+2) * sizeof(char *));
  96                 int i;
  97                 av[0] = "perlModuleConfig";
  98                 av++;
  99                 for ( i=0; i<argc; i++ )
 100                         av[i] = argv[i];
 101                 av[i] = NULL;
 102                 av--;
 103                 rc = config_generic_wrapper( be, fname, lineno, argc+1, av );
 104                 ch_free( av );
 105         }
 106         return rc;
 107 }
 108
 109 static int
 110 perl_cf(
 111         ConfigArgs *c
 112 )
 113 {
 114         PerlBackend *pb = (PerlBackend *) c->be->be_private;
 115         SV* loc_sv;
 116         int count ;
 117         int args;
 118         int rc = 0;
 119         char eval_str[EVAL_BUF_SIZE];
 120         struct berval bv;
 121
 122         if ( c->op == SLAP_CONFIG_EMIT ) {
 123                 switch( c-> type ) {
 124                 case PERL_MODULE:
 125                         if ( !pb->pb_module_name )
 126                                 return 1;
 127                         c->value_string = ch_strdup( pb->pb_module_name );
 128                         break;
 129                 case PERL_PATH:
 130                         if ( !pb->pb_module_path )
 131                                 return 1;
 132                         ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
 133                         break;
 134                 case PERL_CONFIG:
 135                         if ( !pb->pb_module_config )
 136                                 return 1;
 137                         ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
 138                         break;
 139                 }
 140         } else if ( c->op == LDAP_MOD_DELETE ) {
 141                 /* FIXME: none of this affects the state of the perl
 142                  * interpreter at all. We should probably destroy it
 143                  * and recreate it...
 144                  */
 145                 switch( c-> type ) {
 146                 case PERL_MODULE:
 147                         ch_free( pb->pb_module_name );
 148                         pb->pb_module_name = NULL;
 149                         break;
 150                 case PERL_PATH:
 151                         if ( c->valx < 0 ) {
 152                                 ber_bvarray_free( pb->pb_module_path );
 153                                 pb->pb_module_path = NULL;
 154                         } else {
 155                                 int i = c->valx;
 156                                 ch_free( pb->pb_module_path[i].bv_val );
 157                                 for (; pb->pb_module_path[i].bv_val; i++ )
 158                                         pb->pb_module_path[i] = pb->pb_module_path[i+1];
 159                         }
 160                         break;
 161                 case PERL_CONFIG:
 162                         if ( c->valx < 0 ) {
 163                                 ber_bvarray_free( pb->pb_module_config );
 164                                 pb->pb_module_config = NULL;
 165                         } else {
 166                                 int i = c->valx;
 167                                 ch_free( pb->pb_module_config[i].bv_val );
 168                                 for (; pb->pb_module_config[i].bv_val; i++ )
 169                                         pb->pb_module_config[i] = pb->pb_module_config[i+1];
 170                         }
 171                         break;
 172                 }
 173         } else {
 174                 switch( c->type ) {
 175                 case PERL_MODULE:
 176                         snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
 177                         eval_pv( eval_str, 0 );
 178
 179                         if (SvTRUE(ERRSV)) {
 180                                 STRLEN len;
 181
 182                                 snprintf( c->cr_msg, sizeof( c->cr_msg ), "%s: error %s",
 183                                         c->log, SvPV(ERRSV, len ));
 184                                 Debug( LDAP_DEBUG_ANY, "%s\n", c->cr_msg, 0, 0 );
 185                                 rc = 1;
 186                         } else {
 187                                 dSP; ENTER; SAVETMPS;
 188                                 PUSHMARK(sp);
 189                                 XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0)));
 190                                 PUTBACK;
 191
 192                                 count = call_method("new", G_SCALAR);
 193
 194                                 SPAGAIN;
 195
 196                                 if (count != 1) {
 197                                         croak("Big trouble in config\n") ;
 198                                 }
 199
 200                                 pb->pb_obj_ref = newSVsv(POPs);
 201
 202                                 PUTBACK; FREETMPS; LEAVE ;
 203                                 pb->pb_module_name = ch_strdup( c->argv[1] );
 204                         }
 205                         break;
 206
 207                 case PERL_PATH:
 208                         snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", c->argv[1] );
 209                         loc_sv = eval_pv( eval_str, 0 );
 210                         /* XXX loc_sv return value is ignored. */
 211                         ber_str2bv( c->argv[1], 0, 0, &bv );
 212                         value_add_one( &pb->pb_module_path, &bv );
 213                         break;
 214
 215                 case PERL_CONFIG: {
 216                         dSP ;  ENTER ; SAVETMPS;
 217
 218                         PUSHMARK(sp) ;
 219                         XPUSHs( pb->pb_obj_ref );
 220
 221                         /* Put all arguments on the perl stack */
 222                         for( args = 1; args < c->argc; args++ )
 223                                 XPUSHs(sv_2mortal(newSVpv(c->argv[args], 0)));
 224
 225                         ber_str2bv( c->line + STRLENOF("perlModuleConfig "), 0, 0, &bv );
 226                         value_add_one( &pb->pb_module_config, &bv );
 227
 228                         PUTBACK ;
 229
 230                         count = call_method("config", G_SCALAR);
 231
 232                         SPAGAIN ;
 233
 234                         if (count != 1) {
 235                                 croak("Big trouble in config\n") ;
 236                         }
 237
 238                         rc = POPi;
 239
 240                         PUTBACK ; FREETMPS ;  LEAVE ;
 241                         }
 242                         break;
 243                 }
 244         }
 245         return rc;
 246 }
 247
 248 int
 249 perl_back_init_cf( BackendInfo *bi )
 250 {
 251         bi->bi_cf_ocs = perlocs;
 252
 253         return config_register_schema( perlcfg, perlocs );
 254 }