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