2 /* This work is part of OpenLDAP Software <http://www.openldap.org/>.
4 * Copyright 1999-2011 The OpenLDAP Foundation.
5 * Portions Copyright 1999 John C. Quillan.
6 * Portions Copyright 2002 myinternet Limited.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted only as authorized by the OpenLDAP
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>.
18 #include "perl_back.h"
19 #include "../config.h"
21 static ConfigDriver perl_cf;
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 "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 },
56 static ConfigOCs perlocs[] = {
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 },
67 static ConfigOCs ovperlocs[] = {
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 },
78 /**********************************************************
82 **********************************************************/
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 *));
97 av[0] = "perlModuleConfig";
99 for ( i=0; i<argc; i++ )
103 rc = config_generic_wrapper( be, fname, lineno, argc+1, av );
114 PerlBackend *pb = (PerlBackend *) c->be->be_private;
119 char eval_str[EVAL_BUF_SIZE];
122 if ( c->op == SLAP_CONFIG_EMIT ) {
125 if ( !pb->pb_module_name )
127 c->value_string = ch_strdup( pb->pb_module_name );
130 if ( !pb->pb_module_path )
132 ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
135 if ( !pb->pb_module_config )
137 ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
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
147 ch_free( pb->pb_module_name );
148 pb->pb_module_name = NULL;
152 ber_bvarray_free( pb->pb_module_path );
153 pb->pb_module_path = NULL;
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];
163 ber_bvarray_free( pb->pb_module_config );
164 pb->pb_module_config = NULL;
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];
176 snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
177 eval_pv( eval_str, 0 );
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 );
187 dSP; ENTER; SAVETMPS;
189 XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0)));
192 count = call_method("new", G_SCALAR);
197 croak("Big trouble in config\n") ;
200 pb->pb_obj_ref = newSVsv(POPs);
202 PUTBACK; FREETMPS; LEAVE ;
203 pb->pb_module_name = ch_strdup( c->argv[1] );
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 );
216 dSP ; ENTER ; SAVETMPS;
219 XPUSHs( pb->pb_obj_ref );
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)));
228 count = call_method("config", G_SCALAR);
233 croak("Big trouble in config\n") ;
238 PUTBACK ; FREETMPS ; LEAVE ;
247 perl_back_init_cf( BackendInfo *bi )
249 bi->bi_cf_ocs = perlocs;
251 return config_register_schema( perlcfg, perlocs );