1/* $OpenLDAP$ */ 2/* This work is part of OpenLDAP Software <http://www.openldap.org/>. 3 * 4 * Copyright 1999-2011 The OpenLDAP Foundation. 5 * Portions Copyright 1999 John C. Quillan. 6 * Portions Copyright 2002 myinternet Limited. 7 * All rights reserved. 8 * 9 * Redistribution and use in source and binary forms, with or without 10 * modification, are permitted only as authorized by the OpenLDAP 11 * Public License. 12 * 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>. 16 */ 17 18#include "perl_back.h" 19#include "../config.h" 20 21static ConfigDriver perl_cf; 22 23enum { 24 PERL_MODULE = 1, 25 PERL_PATH, 26 PERL_CONFIG 27}; 28 29static 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 }, 53 { NULL } 54}; 55 56static ConfigOCs perlocs[] = { 57 { "( OLcfgDbOc:11.1 " 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 }, 64 { NULL } 65}; 66 67static ConfigOCs ovperlocs[] = { 68 { "( OLcfgDbOc:11.2 " 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 }, 75 { NULL } 76}; 77 78/********************************************************** 79 * 80 * Config 81 * 82 **********************************************************/ 83int 84perl_back_db_config( 85 BackendDB *be, 86 const char *fname, 87 int lineno, 88 int argc, 89 char **argv 90) 91{ 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 *)); 96 int i; 97 av[0] = "perlModuleConfig"; 98 av++; 99 for ( i=0; i<argc; i++ ) 100 av[i] = argv[i]; 101 av[i] = NULL; 102 av--; 103 rc = config_generic_wrapper( be, fname, lineno, argc+1, av ); 104 ch_free( av ); 105 } 106 return rc; 107} 108 109static int 110perl_cf( 111 ConfigArgs *c 112) 113{ 114 PerlBackend *pb = (PerlBackend *) c->be->be_private; 115 SV* loc_sv; 116 int count ; 117 int args; 118 int rc = 0; 119 char eval_str[EVAL_BUF_SIZE]; 120 struct berval bv; 121 122 if ( c->op == SLAP_CONFIG_EMIT ) { 123 switch( c-> type ) { 124 case PERL_MODULE: 125 if ( !pb->pb_module_name ) 126 return 1; 127 c->value_string = ch_strdup( pb->pb_module_name ); 128 break; 129 case PERL_PATH: 130 if ( !pb->pb_module_path ) 131 return 1; 132 ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_path, NULL ); 133 break; 134 case PERL_CONFIG: 135 if ( !pb->pb_module_config ) 136 return 1; 137 ber_bvarray_dup_x( &c->rvalue_vals, pb->pb_module_config, NULL ); 138 break; 139 } 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 143 * and recreate it... 144 */ 145 switch( c-> type ) { 146 case PERL_MODULE: 147 ch_free( pb->pb_module_name ); 148 pb->pb_module_name = NULL; 149 break; 150 case PERL_PATH: 151 if ( c->valx < 0 ) { 152 ber_bvarray_free( pb->pb_module_path ); 153 pb->pb_module_path = NULL; 154 } else { 155 int i = c->valx; 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]; 159 } 160 break; 161 case PERL_CONFIG: 162 if ( c->valx < 0 ) { 163 ber_bvarray_free( pb->pb_module_config ); 164 pb->pb_module_config = NULL; 165 } else { 166 int i = c->valx; 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]; 170 } 171 break; 172 } 173 } else { 174 switch( c->type ) { 175 case PERL_MODULE: 176 snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", c->argv[1] ); 177 eval_pv( eval_str, 0 ); 178 179 if (SvTRUE(ERRSV)) { 180 STRLEN len; 181 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 ); 185 rc = 1; 186 } else { 187 dSP; ENTER; SAVETMPS; 188 PUSHMARK(sp); 189 XPUSHs(sv_2mortal(newSVpv(c->argv[1], 0))); 190 PUTBACK; 191 192 count = call_method("new", G_SCALAR); 193 194 SPAGAIN; 195 196 if (count != 1) { 197 croak("Big trouble in config\n") ; 198 } 199 200 pb->pb_obj_ref = newSVsv(POPs); 201 202 PUTBACK; FREETMPS; LEAVE ; 203 pb->pb_module_name = ch_strdup( c->argv[1] ); 204 } 205 break; 206 207 case PERL_PATH: 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 ); 213 break; 214 215 case PERL_CONFIG: { 216 dSP ; ENTER ; SAVETMPS; 217 218 PUSHMARK(sp) ; 219 XPUSHs( pb->pb_obj_ref ); 220 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))); 224 } 225 226 PUTBACK ; 227 228 count = call_method("config", G_SCALAR); 229 230 SPAGAIN ; 231 232 if (count != 1) { 233 croak("Big trouble in config\n") ; 234 } 235 236 rc = POPi; 237 238 PUTBACK ; FREETMPS ; LEAVE ; 239 } 240 break; 241 } 242 } 243 return rc; 244} 245 246int 247perl_back_init_cf( BackendInfo *bi ) 248{ 249 bi->bi_cf_ocs = perlocs; 250 251 return config_register_schema( perlcfg, perlocs ); 252} 253