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