Adding upstream version 2.4.57+dfsg.upstream/2.4.57+dfsgupstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 255 insertions, 0 deletions

diff --git a/servers/slapd/back-perl/config.c b/servers/slapd/back-perl/config.c
new file mode 100644
index 0000000..6caf446
--- /dev/null
+++ b/servers/slapd/back-perl/config.c
@@ -0,0 +1,255 @@
+/* $OpenLDAP$ */
+/* This work is part of OpenLDAP Software <http://www.openldap.org/>.
+ *
+ * Copyright 1999-2021 The OpenLDAP Foundation.
+ * Portions Copyright 1999 John C. Quillan.
+ * Portions Copyright 2002 myinternet Limited.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted only as authorized by the OpenLDAP
+ * Public License.
+ *
+ * A copy of this license is available in file LICENSE in the
+ * top-level directory of the distribution or, alternatively, at
+ * <http://www.OpenLDAP.org/license.html>.
+ */
+
+#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_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_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 'olcDbPerlConfig' "
+		"DESC 'Perl DB configuration' "
+		"SUP olcDatabaseConfig "
+		"MUST ( olcPerlModulePath $ olcPerlModule ) "
+		"MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
+			Cft_Database, perlcfg, NULL, NULL },
+	{ NULL }
+};
+
+static ConfigOCs ovperlocs[] = {
+	{ "( OLcfgDbOc:11.2 "
+		"NAME 'olcovPerlConfig' "
+		"DESC 'Perl overlay configuration' "
+		"SUP olcOverlayConfig "
+		"MUST ( olcPerlModulePath $ olcPerlModule ) "
+		"MAY ( olcPerlFilterSearchResults $ olcPerlModuleConfig ) )",
+			Cft_Overlay, perlcfg, NULL, NULL },
+	{ NULL }
+};
+
+/**********************************************************
+ *
+ * Config
+ *
+ **********************************************************/
+int
+perl_back_db_config(
+	BackendDB *be,
+	const char *fname,
+	int lineno,
+	int argc,
+	char **argv
+)
+{
+	int rc = config_generic_wrapper( be, fname, lineno, argc, argv );
+	/* backward compatibility: map unknown directives to perlModuleConfig */
+	if ( rc == SLAP_CONF_UNKNOWN ) {
+		char **av = ch_malloc( (argc+2) * sizeof(char *));
+		int i;
+		av[0] = "perlModuleConfig";
+		av++;
+		for ( i=0; i<argc; i++ )
+			av[i] = argv[i];
+		av[i] = NULL;
+		av--;
+		rc = config_generic_wrapper( be, fname, lineno, argc+1, av );
+		ch_free( av );
+	}
+	return rc;
+}
+
+static int
+perl_cf(
+	ConfigArgs *c
+)
+{
+	PerlBackend *pb = (PerlBackend *) c->be->be_private;
+	SV* loc_sv;
+	int count ;
+	int args;
+	int rc = 0;
+	char eval_str[EVAL_BUF_SIZE];
+	struct berval bv;
+
+	if ( c->op == SLAP_CONFIG_EMIT ) {
+		switch( c-> type ) {
+		case PERL_MODULE:
+			if ( !pb->pb_module_name )
+				return 1;
+			c->value_string = ch_strdup( 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 ) {
+		/* FIXME: none of this affects the state of the perl
+		 * interpreter at all. We should probably destroy it
+		 * and recreate it...
+		 */
+		switch( c-> type ) {
+		case PERL_MODULE:
+			ch_free( pb->pb_module_name );
+			pb->pb_module_name = NULL;
+			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 {
+		PERL_SET_CONTEXT( PERL_INTERPRETER );
+		switch( c->type ) {
+		case PERL_MODULE:
+			snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] );
+			eval_pv( eval_str, 0 );
+
+			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 ;
+				pb->pb_module_name = ch_strdup( c->argv[1] );
+			}
+			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( pb->pb_obj_ref );
+
+			/* Put all arguments on the perl stack */
+			for( args = 1; args < c->argc; args++ )
+				XPUSHs(sv_2mortal(newSVpv(c->argv[args], 0)));
+
+			ber_str2bv( c->line + STRLENOF("perlModuleConfig "), 0, 0, &bv );
+			value_add_one( &pb->pb_module_config, &bv );
+
+			PUTBACK ;
+
+			count = call_method("config", G_SCALAR);
+
+			SPAGAIN ;
+
+			if (count != 1) {
+				croak("Big trouble in config\n") ;
+			}
+
+			rc = POPi;
+
+			PUTBACK ; FREETMPS ;  LEAVE ;
+			}
+			break;
+		}
+	}
+	return rc;
+}
+
+int
+perl_back_init_cf( BackendInfo *bi )
+{
+	bi->bi_cf_ocs = perlocs;
+
+	return config_register_schema( perlcfg, perlocs );
+}