Dynamic config support - not fully backward compatible

servers/slapd/back-perl/config.c

@@ -16,121 +16,184 @@
  */
 
 #include "perl_back.h"
+#include "../config.h"
 
+static ConfigDriver perl_cf;
+
+enum {
+	PERL_MODULE = 1,
+	PERL_PATH,
+	PERL_CONFIG
+};
+
+static ConfigTable perlcfg[] = {
+	{ "perlModule", "module", 2, 2, 0,
+		ARG_STRING|ARG_MAGIC|PERL_MODULE, perl_cf, 
+		"( OLcfgDbAt:11.1 NAME 'olcPerlModule' "
+			"DESC 'Perl module name' "
+			"EQUALITY caseExactMatch "
+			"SYNTAX OMsDirectoryString SINGLE-VALUE )", NULL, NULL },
+	{ "perlModulePath", "path", 2, 2, 0,
+		ARG_STRING|ARG_MAGIC|PERL_PATH, perl_cf, 
+		"( OLcfgDbAt:11.2 NAME 'olcPerlModulePath' "
+			"DESC 'Perl module path' "
+			"EQUALITY caseExactMatch "
+			"SYNTAX OMsDirectoryString )", NULL, NULL },
+	{ "filterSearchResults", "on|off", 2, 2, 0, ARG_ON_OFF|ARG_OFFSET,
+		(void *)offsetof(PerlBackend, pb_filter_search_results),
+		"( OLcfgDbAt:11.3 NAME 'olcPerlFilterSearchResults' "
+			"DESC 'Filter search results before returning to client' "
+			"SYNTAX OMsBoolean SINGLE-VALUE )", NULL, NULL },
+	{ "perlModuleConfig", "args", 2, 0, 0,
+		ARG_STRING|ARG_MAGIC|PERL_CONFIG, perl_cf, 
+		"( OLcfgDbAt:11.4 NAME 'olcPerlModuleConfig' "
+			"DESC 'Perl module config directives' "
+			"EQUALITY caseExactMatch "
+			"SYNTAX OMsDirectoryString )", NULL, NULL },
+	{ NULL }
+};
+
+static ConfigOCs perlocs[] = {
+	{ "( OLcfgDbOc:11.1 "
+		"NAME 'olcPerlConfig' "
+		"DESC 'Perl DB configuration' "
+		"SUP olcDatabaseConfig "
+		"MUST ( olcPerlModulePath $ olcPerlModule ) "
+		"MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
+			Cft_Database, perlcfg, NULL, NULL },
+	{ NULL }
+};
 
 /**********************************************************
  *
  * Config
  *
  **********************************************************/
-int
+static int
-perl_back_db_config(
+perl_cf(
-	 BackendDB *be,
+	ConfigArgs *c
-	 const char *fname,
-	 int lineno,
-	 int argc,
-	 char **argv
 )
 {
+	PerlBackend *pb = (PerlBackend *) c->be->be_private;
 	SV* loc_sv;
-	PerlBackend *perl_back = (PerlBackend *) be->be_private;
-	char eval_str[EVAL_BUF_SIZE];
 	int count ;
 	int args;
-	int return_code;
+	int rc = 0;
-	
+	char eval_str[EVAL_BUF_SIZE];
+	struct berval bv;
 
-	if ( strcasecmp( argv[0], "perlModule" ) == 0 ) {
+	if ( c->op == SLAP_CONFIG_EMIT ) {
-		if ( argc < 2 ) {
+		switch( c-> type ) {
-			Debug( LDAP_DEBUG_ANY,
+		case PERL_MODULE:
-				 "%s.pm: line %d: missing module in \"perlModule <module>\" line\n",
+			if ( bv.bv_len < 1 )
-				fname, lineno, 0 );
+				return 1;
-			return( 1 );
+			value_add_one( &c->rvalue_vals, &pb->pb_module_name );
+			break;
+		case PERL_PATH:
+			if ( !pb->pb_module_path )
+				return 1;
+			ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL );
+			break;
+		case PERL_CONFIG:
+			if ( !pb->pb_module_config )
+				return 1;
+			ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL );
+			break;
 		}
-
+	} else if ( c->op == LDAP_MOD_DELETE ) {
-#ifdef PERL_IS_5_6
+		/* FIXME: none of this affects the state of the perl
-		snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", argv[1] );
+		 * interpreter at all. We should probably destroy it
-		eval_pv( eval_str, 0 );
+		 * and recreate it...
-
-		if (SvTRUE(ERRSV)) {
-			STRLEN n_a;
-
-			fprintf(stderr , "Error %s\n", SvPV(ERRSV, n_a)) ;
-		}
-#else
-		snprintf( eval_str, EVAL_BUF_SIZE, "%s.pm", argv[1] );
-		perl_require_pv( eval_str );
-
-		if (SvTRUE(GvSV(errgv))) {
-			fprintf(stderr , "Error %s\n", SvPV(GvSV(errgv), na)) ;
-		}
-#endif /* PERL_IS_5_6 */
-		else {
-			dSP; ENTER; SAVETMPS;
-			PUSHMARK(sp);
-			XPUSHs(sv_2mortal(newSVpv(argv[1], 0)));
-			PUTBACK;
-
-#ifdef PERL_IS_5_6
-			count = call_method("new", G_SCALAR);
-#else
-			count = perl_call_method("new", G_SCALAR);
-#endif
-
-			SPAGAIN;
-
-			if (count != 1) {
-				croak("Big trouble in config\n") ;
-			}
-
-			perl_back->pb_obj_ref = newSVsv(POPs);
-
-			PUTBACK; FREETMPS; LEAVE ;
-		}
-
-	} else if ( strcasecmp( argv[0], "perlModulePath" ) == 0 ) {
-		if ( argc < 2 ) {
-			fprintf( stderr,
-				"%s: line %d: missing module in \"PerlModulePath <module>\" line\n",
-				fname, lineno );
-			return( 1 );
-		}
-
-		snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", argv[1] );
-#ifdef PERL_IS_5_6
-		loc_sv = eval_pv( eval_str, 0 );
-#else
-		loc_sv = perl_eval_pv( eval_str, 0 );
-#endif
-
-		/* XXX loc_sv return value is ignored. */
-
-	} else if ( strcasecmp( argv[0], "filterSearchResults" ) == 0 ) {
-		perl_back->pb_filter_search_results = 1;
-	} else {
-		return_code = SLAP_CONF_UNKNOWN;
-		/*
-		 * Pass it to Perl module if defined
 		 */
+		switch( c-> type ) {
+		case PERL_MODULE:
+			ch_free( pb->pb_module_name.bv_val );
+			BER_BVZERO( &pb->pb_module_name );
+			break;
+		case PERL_PATH:
+			if ( c->valx < 0 ) {
+				ber_bvarray_free( pb->pb_module_path );
+				pb->pb_module_path = NULL;
+			} else {
+				int i = c->valx;
+				ch_free( pb->pb_module_path[i].bv_val );
+				for (; pb->pb_module_path[i].bv_val; i++ )
+					pb->pb_module_path[i] = pb->pb_module_path[i+1];
+			}
+			break;
+		case PERL_CONFIG:
+			if ( c->valx < 0 ) {
+				ber_bvarray_free( pb->pb_module_config );
+				pb->pb_module_config = NULL;
+			} else {
+				int i = c->valx;
+				ch_free( pb->pb_module_config[i].bv_val );
+				for (; pb->pb_module_config[i].bv_val; i++ )
+					pb->pb_module_config[i] = pb->pb_module_config[i+1];
+			}
+			break;
+		}
+	} else {
+		switch( c->type ) {
+		case PERL_MODULE:
+#ifdef PERL_IS_5_6
+			snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
+			eval_pv( eval_str, 0 );
+#else
+			snprintf( eval_str, EVAL_BUF_SIZE, "%s.pm", c->argv[1] );
+			perl_require_pv( eval_str );
+#endif /* PERL_IS_5_6 */
 
-		{
+			if (SvTRUE(ERRSV)) {
+				STRLEN len;
+
+				snprintf( c->cr_msg, sizeof( c->cr_msg ), "%s: error %s",
+					c->log, SvPV(ERRSV, len ));
+				Debug( LDAP_DEBUG_ANY, "%s\n", c->cr_msg, 0, 0 );
+				rc = 1;
+			} else {
+				dSP; ENTER; SAVETMPS;
+				PUSHMARK(sp);
+				XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0)));
+				PUTBACK;
+
+				count = call_method("new", G_SCALAR);
+
+				SPAGAIN;
+
+				if (count != 1) {
+					croak("Big trouble in config\n") ;
+				}
+
+				pb->pb_obj_ref = newSVsv(POPs);
+
+				PUTBACK; FREETMPS; LEAVE ;
+				ber_str2bv( c->argv[1], 0, 1, &pb->pb_module_name );
+			}
+			break;
+
+		case PERL_PATH:
+			snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", c->argv[1] );
+			loc_sv = eval_pv( eval_str, 0 );
+			/* XXX loc_sv return value is ignored. */
+			ber_str2bv( c->argv[1], 0, 0, &bv );
+			value_add_one( &pb->pb_module_path, &bv );
+			break;
+
+		case PERL_CONFIG: {
 			dSP ;  ENTER ; SAVETMPS;
 
 			PUSHMARK(sp) ;
-			XPUSHs( perl_back->pb_obj_ref );
+			XPUSHs( pb->pb_obj_ref );
 
 			/* Put all arguments on the perl stack */
-			for( args = 0; args < argc; args++ ) {
+			for( args = 1; args < c->argc; args++ ) {
-				XPUSHs(sv_2mortal(newSVpv(argv[args], 0)));
+				XPUSHs(sv_2mortal(newSVpv(c->argv[args], 0)));
 			}
 
 			PUTBACK ;
 
-#ifdef PERL_IS_5_6
 			count = call_method("config", G_SCALAR);
-#else
-			count = perl_call_method("config", G_SCALAR);
-#endif
 
 			SPAGAIN ;
 
@@ -138,14 +201,20 @@ perl_back_db_config(
 				croak("Big trouble in config\n") ;
 			}
 
-			return_code = POPi;
+			rc = POPi;
 
 			PUTBACK ; FREETMPS ;  LEAVE ;
-
+			}
+			break;
 		}
-
-		return return_code;
 	}
-
+	return rc;
-	return 0;
+}
+
+int
+perl_back_init_cf( BackendInfo *bi )
+{
+	bi->bi_cf_ocs = perlocs;
+
+	return config_register_schema( perlcfg, perlocs );
 }

servers/slapd/back-perl/init.c

@@ -45,7 +45,7 @@ perl_back_initialize(
 	bi->bi_destroy = 0;
 
 	bi->bi_db_init = perl_back_db_init;
-	bi->bi_db_config = perl_back_db_config;
+	bi->bi_db_config = 0;
 	bi->bi_db_open = perl_back_db_open;
 	bi->bi_db_close = 0;
 	bi->bi_db_destroy = perl_back_db_destroy;
@@ -79,7 +79,7 @@ perl_back_initialize(
 	ldap_pvt_thread_mutex_init( &perl_interpreter_mutex );
 
 #ifdef PERL_SYS_INIT3
-	PERL_SYS_INIT3(&argc, &embedding, (char **)NULL);
+	PERL_SYS_INIT3(&argc, &embedding, (char ***)NULL);
 #endif
 	PERL_INTERPRETER = perl_alloc();
 	perl_construct(PERL_INTERPRETER);
@@ -88,7 +88,7 @@ perl_back_initialize(
 #endif
 	perl_parse(PERL_INTERPRETER, perl_back_xs_init, argc, embedding, (char **)NULL);
 	perl_run(PERL_INTERPRETER);
-	return 0;
+	return perl_back_init_cf( bi );
 }
 
 int

servers/slapd/back-perl/perl_back.h

@@ -46,6 +46,9 @@ extern ldap_pvt_thread_mutex_t  perl_interpreter_mutex;
 /* All the old style variables are prefixed with PL_ now */
 # define errgv	PL_errgv
 # define na	PL_na
+#else
+# define call_method(m, f)	perl_call_method(m, f)
+# define ERRSV	GvSV(errgv)
 #endif
 
 #if defined( HAVE_WIN32_ASPERL ) || defined( USE_ITHREADS )
@@ -63,7 +66,9 @@ extern PerlInterpreter *PERL_INTERPRETER;
 
 
 typedef struct perl_backend_instance {
-	char	*pb_module_name;
+	struct berval	pb_module_name;
+	BerVarray pb_module_path;
+	BerVarray pb_module_config;
 	SV	*pb_obj_ref;
 	int	pb_filter_search_results;
 } PerlBackend;

servers/slapd/back-perl/proto-perl.h

@@ -27,7 +27,6 @@ extern BI_close		perl_back_close;
 extern BI_db_init	perl_back_db_init;
 extern BI_db_open	perl_back_db_open;
 extern BI_db_destroy	perl_back_db_destroy;
-extern BI_db_config	perl_back_db_config;
 
 extern BI_op_bind	perl_back_bind;
 extern BI_op_search	perl_back_search;
@@ -37,6 +36,7 @@ extern BI_op_modrdn	perl_back_modrdn;
 extern BI_op_add	perl_back_add;
 extern BI_op_delete	perl_back_delete;
 
+extern int perl_back_init_cf( BackendInfo *bi );
 LDAP_END_DECL
 
 #endif /* PROTO_PERL_H */