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