git.sur5r.net Git - openldap/blob - servers/slapd/back-perl/config.c

   1 /* $OpenLDAP$ */
   2 /* This work is part of OpenLDAP Software <http://www.openldap.org/>.
   3  *
   4  * Copyright 1999-2003 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 <EXTERN.h>
  19 #include <perl.h>
  20 #undef _ /* #defined by both Perl and ac/localize.h */
  21
  22 #ifdef HAVE_WIN32_ASPERL
  23 #include "asperl_undefs.h"
  24 #endif
  25
  26 #include "portable.h"
  27
  28 #include <stdio.h>
  29
  30 #include "slap.h"
  31
  32 #include "perl_back.h"
  33
  34
  35 /**********************************************************
  36  *
  37  * Config
  38  *
  39  **********************************************************/
  40 int
  41 perl_back_db_config(
  42          BackendDB *be,
  43          const char *fname,
  44          int lineno,
  45          int argc,
  46          char **argv
  47 )
  48 {
  49         SV* loc_sv;
  50         PerlBackend *perl_back = (PerlBackend *) be->be_private;
  51         char eval_str[EVAL_BUF_SIZE];
  52         int count ;
  53         int args;
  54         int return_code;
  55
  56
  57         if ( strcasecmp( argv[0], "perlModule" ) == 0 ) {
  58                 if ( argc < 2 ) {
  59                         Debug( LDAP_DEBUG_ANY,
  60                                  "%s.pm: line %d: missing module in \"perlModule <module>\" line\n",
  61                                 fname, lineno, 0 );
  62                         return( 1 );
  63                 }
  64
  65 #ifdef PERL_IS_5_6
  66                 snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", argv[1] );
  67                 eval_pv( eval_str, 0 );
  68
  69                 if (SvTRUE(ERRSV)) {
  70                         STRLEN n_a;
  71
  72                         fprintf(stderr , "Error %s\n", SvPV(ERRSV, n_a)) ;
  73                 }
  74 #else
  75                 snprintf( eval_str, EVAL_BUF_SIZE, "%s.pm", argv[1] );
  76                 perl_require_pv( eval_str );
  77
  78                 if (SvTRUE(GvSV(errgv))) {
  79                         fprintf(stderr , "Error %s\n", SvPV(GvSV(errgv), na)) ;
  80                 }
  81 #endif /* PERL_IS_5_6 */
  82                 else {
  83                         dSP; ENTER; SAVETMPS;
  84                         PUSHMARK(sp);
  85                         XPUSHs(sv_2mortal(newSVpv(argv[1], 0)));
  86                         PUTBACK;
  87
  88 #ifdef PERL_IS_5_6
  89                         count = call_method("new", G_SCALAR);
  90 #else
  91                         count = perl_call_method("new", G_SCALAR);
  92 #endif
  93
  94                         SPAGAIN;
  95
  96                         if (count != 1) {
  97                                 croak("Big trouble in config\n") ;
  98                         }
  99
 100                         perl_back->pb_obj_ref = newSVsv(POPs);
 101
 102                         PUTBACK; FREETMPS; LEAVE ;
 103                 }
 104
 105         } else if ( strcasecmp( argv[0], "perlModulePath" ) == 0 ) {
 106                 if ( argc < 2 ) {
 107                         fprintf( stderr,
 108                                 "%s: line %d: missing module in \"PerlModulePath <module>\" line\n",
 109                                 fname, lineno );
 110                         return( 1 );
 111                 }
 112
 113                 snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", argv[1] );
 114 #ifdef PERL_IS_5_6
 115                 loc_sv = eval_pv( eval_str, 0 );
 116 #else
 117                 loc_sv = perl_eval_pv( eval_str, 0 );
 118 #endif
 119
 120                 /* XXX loc_sv return value is ignored. */
 121
 122         } else if ( strcasecmp( argv[0], "filterSearchResults" ) == 0 ) {
 123                 perl_back->pb_filter_search_results = 1;
 124         } else {
 125                 return_code = SLAP_CONF_UNKNOWN;
 126                 /*
 127                  * Pass it to Perl module if defined
 128                  */
 129
 130                 {
 131                         dSP ;  ENTER ; SAVETMPS;
 132
 133                         PUSHMARK(sp) ;
 134                         XPUSHs( perl_back->pb_obj_ref );
 135
 136                         /* Put all arguments on the perl stack */
 137                         for( args = 0; args < argc; args++ ) {
 138                                 XPUSHs(sv_2mortal(newSVpv(argv[args], 0)));
 139                         }
 140
 141                         PUTBACK ;
 142
 143 #ifdef PERL_IS_5_6
 144                         count = call_method("config", G_SCALAR);
 145 #else
 146                         count = perl_call_method("config", G_SCALAR);
 147 #endif
 148
 149                         SPAGAIN ;
 150
 151                         if (count != 1) {
 152                                 croak("Big trouble in config\n") ;
 153                         }
 154
 155                         return_code = POPi;
 156
 157                         PUTBACK ; FREETMPS ;  LEAVE ;
 158
 159                 }
 160
 161                 return return_code;
 162         }
 163
 164         return 0;
 165 }