diff options
Diffstat (limited to 'servers/slapd/back-perl/config.c')
| -rw-r--r-- | servers/slapd/back-perl/config.c | 255 |
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 ); +} |