xref: /netbsd-src/external/bsd/openldap/dist/servers/slapd/back-perl/config.c (revision 549b59ed3ccf0d36d3097190a0db27b770f3a839)
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
perl_back_db_config(BackendDB * be,const char * fname,int lineno,int argc,char ** argv)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
perl_cf(ConfigArgs * c)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
perl_back_init_cf(BackendInfo * bi)253 perl_back_init_cf( BackendInfo *bi )
254 {
255 	bi->bi_cf_ocs = perlocs;
256 
257 	return config_register_schema( perlcfg, perlocs );
258 }
259