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