/* $OpenLDAP$ */ /* This work is part of OpenLDAP Software . * * Copyright 1999-2020 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 * . */ #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' " "EQUALITY booleanMatch " "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; ibe->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 ); 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 ); }