1 /* $OpenLDAP$ */
2 /* This work is part of OpenLDAP Software <http://www.openldap.org/>.
3  *
4  * Copyright 1999-2021 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 "../slap-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 			"EQUALITY booleanMatch "
47 			"SYNTAX OMsBoolean SINGLE-VALUE )", NULL, NULL },
48 	{ "perlModuleConfig", "args", 2, 0, 0,
49 		ARG_MAGIC|PERL_CONFIG, perl_cf,
50 		"( OLcfgDbAt:11.4 NAME 'olcPerlModuleConfig' "
51 			"DESC 'Perl module config directives' "
52 			"EQUALITY caseExactMatch "
53 			"SYNTAX OMsDirectoryString )", NULL, NULL },
54 	{ NULL }
55 };
56 
57 static ConfigOCs perlocs[] = {
58 	{ "( OLcfgDbOc:11.1 "
59 		"NAME 'olcDbPerlConfig' "
60 		"DESC 'Perl DB configuration' "
61 		"SUP olcDatabaseConfig "
62 		"MUST ( olcPerlModulePath $ olcPerlModule ) "
63 		"MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
64 			Cft_Database, perlcfg, NULL, NULL },
65 	{ NULL }
66 };
67 
68 static ConfigOCs ovperlocs[] = {
69 	{ "( OLcfgDbOc:11.2 "
70 		"NAME 'olcovPerlConfig' "
71 		"DESC 'Perl overlay configuration' "
72 		"SUP olcOverlayConfig "
73 		"MUST ( olcPerlModulePath $ olcPerlModule ) "
74 		"MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
75 			Cft_Overlay, perlcfg, NULL, NULL },
76 	{ NULL }
77 };
78 
79 /**********************************************************
80  *
81  * Config
82  *
83  **********************************************************/
84 int
perl_back_db_config(BackendDB * be,const char * fname,int lineno,int argc,char ** argv)85 perl_back_db_config(
86 	BackendDB *be,
87 	const char *fname,
88 	int lineno,
89 	int argc,
90 	char **argv
91 )
92 {
93 	int rc = config_generic_wrapper( be, fname, lineno, argc, argv );
94 	/* backward compatibility: map unknown directives to perlModuleConfig */
95 	if ( rc == SLAP_CONF_UNKNOWN ) {
96 		char **av = ch_malloc( (argc+2) * sizeof(char *));
97 		int i;
98 		av[0] = "perlModuleConfig";
99 		av++;
100 		for ( i=0; i<argc; i++ )
101 			av[i] = argv[i];
102 		av[i] = NULL;
103 		av--;
104 		rc = config_generic_wrapper( be, fname, lineno, argc+1, av );
105 		ch_free( av );
106 	}
107 	return rc;
108 }
109 
110 static int
perl_cf(ConfigArgs * c)111 perl_cf(
112 	ConfigArgs *c
113 )
114 {
115 	PerlBackend *pb = (PerlBackend *) c->be->be_private;
116 	SV* loc_sv;
117 	int count ;
118 	int args;
119 	int rc = 0;
120 	char eval_str[EVAL_BUF_SIZE];
121 	struct berval bv;
122 
123 	if ( c->op == SLAP_CONFIG_EMIT ) {
124 		switch( c-> type ) {
125 		case PERL_MODULE:
126 			if ( !pb->pb_module_name )
127 				return 1;
128 			c->value_string = ch_strdup( pb->pb_module_name );
129 			break;
130 		case PERL_PATH:
131 			if ( !pb->pb_module_path )
132 				return 1;
133 			ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
134 			break;
135 		case PERL_CONFIG:
136 			if ( !pb->pb_module_config )
137 				return 1;
138 			ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
139 			break;
140 		}
141 	} else if ( c->op == LDAP_MOD_DELETE ) {
142 		/* FIXME: none of this affects the state of the perl
143 		 * interpreter at all. We should probably destroy it
144 		 * and recreate it...
145 		 */
146 		switch( c-> type ) {
147 		case PERL_MODULE:
148 			ch_free( pb->pb_module_name );
149 			pb->pb_module_name = NULL;
150 			break;
151 		case PERL_PATH:
152 			if ( c->valx < 0 ) {
153 				ber_bvarray_free( pb->pb_module_path );
154 				pb->pb_module_path = NULL;
155 			} else {
156 				int i = c->valx;
157 				ch_free( pb->pb_module_path[i].bv_val );
158 				for (; pb->pb_module_path[i].bv_val; i++ )
159 					pb->pb_module_path[i] = pb->pb_module_path[i+1];
160 			}
161 			break;
162 		case PERL_CONFIG:
163 			if ( c->valx < 0 ) {
164 				ber_bvarray_free( pb->pb_module_config );
165 				pb->pb_module_config = NULL;
166 			} else {
167 				int i = c->valx;
168 				ch_free( pb->pb_module_config[i].bv_val );
169 				for (; pb->pb_module_config[i].bv_val; i++ )
170 					pb->pb_module_config[i] = pb->pb_module_config[i+1];
171 			}
172 			break;
173 		}
174 	} else {
175 		PERL_SET_CONTEXT( PERL_INTERPRETER );
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 );
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
perl_back_init_cf(BackendInfo * bi)251 perl_back_init_cf( BackendInfo *bi )
252 {
253 	bi->bi_cf_ocs = perlocs;
254 
255 	return config_register_schema( perlcfg, perlocs );
256 }
257