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