From: John Quillan Date: Sun, 4 Apr 1999 04:16:14 +0000 (+0000) Subject: Fix bug in compare.c where obj_ref to pb_obj_ref X-Git-Tag: OPENLDAP_SLAPD_BACK_LDAP~261 X-Git-Url: https://git.sur5r.net/?a=commitdiff_plain;h=3f1fd3bceebb47aaee74966ca208a14605cc5121;p=openldap Fix bug in compare.c where obj_ref to pb_obj_ref Added call to perl "config" method so the the perl module can have its own configuration options. Fix bug in init.c where the address of the be_private object was being retrieved when it was already a pointer. Added the dn parameter to the modify.c call to the modify method. Not sure why this wasn't there in the beginning. Expects and array from the search method instead of a scalar in search.c so that it can return search results and a return code. Added the demo file SampleLDAP.pm --- diff --git a/servers/slapd/back-perl/SampleLDAP.pm b/servers/slapd/back-perl/SampleLDAP.pm new file mode 100644 index 0000000000..4f78bfb8a3 --- /dev/null +++ b/servers/slapd/back-perl/SampleLDAP.pm @@ -0,0 +1,273 @@ +=head1 Introduction + +This is a sample Perl module for the OpenLDAP server slapd. +It also contains the documentation that you will need to +get up and going. + +WARNING: the interfaces of this backen to the perl module +MAY change. Any suggestions would greatly be appreciated. + + +=head1 Overview + +The Perl back end works by embedding a Perl interpreter into +the slapd backend. Then when the configuration file indicates +that we are going to be using a Perl backend it will get an +option that tells it what module to use. It then creates a +new Perl object that handles all the request for that particular +instance of the back end. + + +=head1 Interface + +You will need to create a method for each one of the +following actions that you wish to handle. + + * new # Creates a new object. + * search # Performs the ldap search + * compare # does a compare + * modify # modify's and entry + * add # adds an entry to back end + * modrdn # modifies a an entries rdn + * delete # deletes an ldap entry + * config # process unknow config file lines + +=head2 new + +This method is called when the config file encounters a +B line. The module in that line is then effectively +used into the perl interpreter, then the new method is called +to create a new object. Note that multiple instances of that +object may be instantiated, as with any perl object. + +The new method doesn't receive any arguments other than the +class name. + +RETURN: + +=head2 search + +This method is called when a search request comes from a client. +It arguments are as follow. + + * obj reference + * filter string + * size limit + * time limit + * attributes only flag ( 1 for yes ) + * list of attributes that are to be returned. (could be empty) + +RETURN: + +=head2 compare + +This method is called when a compare request comes from a client. +Its arguments are as follows. + + * obj reference + * dn + +RETURN: + +=head2 modify + +This method is called when a modify request comes from a client. +Its arguments are as follows. + + * obj reference + * dn + * lists formatted as follows + { ADD | DELETE | REPLACE }, key, value + +RETURN: + +=head2 add + +This method is called when a add request comes from a client. +Its arguments are as follows. + + * obj reference + * entry in string format. + +RETURN: + +=head2 modrdn + +This method is called when a modrdn request comes from a client. +Its arguments are as follows. + + * obj reference + * dn + * new rdn + * delete old dn flage ( 1 means yes ) + +RETURN: + +=head2 delete + +This method is called when a delete request comes from a client. +Its arguments are as follows. + + * obj reference + * dn + +RETURN: + +=head2 config + + * obj reference + * arrray of arguments on line + +RETURN: non zero value if this is not a valid option. + +=head1 Configuration + +The perl section of the config file recognizes the following +options. It should also be noted that any option not recoginized +will be sent to the B method of the perl module as noted +above. + + database perl # startn section for the perl database + + suffix "o=AnyOrg, c=US" + + perlModulePath /path/to/libs # addes the path to @INC variable same + # as "use lib '/path/to/libs'" + + perlModule ModName # use the module name ModName from ModName.pm + + + +=cut + +package SampleLDAP; + +sub new +{ + my $class = shift; + + my $this = {}; + bless $this, $class; + + return $this; +} + +sub search +{ + my $this = shift; + my( $filterStr, $sizeLim, $timeLim, $attrOnly, @attrs ) = @_; + + $filterStr =~ s/\(|\)//g; + $filterStr =~ s/=/: /; + + my @match_dn = (); + foreach my $dn ( keys %$this ) { + if ( $this->{ $dn } =~ /$filterStr/im ) { + push @match_dn, $dn; + last if ( scalar @match_dn == $sizeLim ); + + } + } + + my @match_entries = (); + + foreach my $dn ( @match_dn ) { + push @match_entries, $this->{ $dn }; + } + + return ( 0 , @match_entries ); + +} + +sub compare +{ + my $this = shift; + my ( $dn ) = @_; + + return 1; +} + +sub modify +{ + my $this = shift; + + my ( $dn, @list ) = @_; + + while ( @list > 0 ) { + my $action = shift @list; + my $key = shift @list; + my $value = shift @list; + + if( $action eq "ADD" ) { + $this->{ $dn } .= "$key: $value\n"; + + } + elsif( $action eq "DELETE" ) { + $this->{ $dn } =~ s/^$key:\s*$value\n//mi ; + + } + elsif( $action eq "REPLACE" ) { + $this->{ $dn } =~ s/$key: .*$/$key: $value/im ; + } + } + + return 0; +} + +sub add +{ + my $this = shift; + + my ( $entryStr ) = @_; + + my ( $dn ) = ( $entryStr =~ /dn:\s(.*)$/m ); + + # + # This needs to be here untill a normalize dn is + # passed to this routine. + # + $dn = uc( $dn ); + $dn =~ s/\s*//g; + + + $this->{$dn} = $entryStr; + + return 0; +} + +sub modrdn +{ + my $this = shift; + + my ( $dn, $newdn, $delFlag ) = @_; + + $this->{ $newdn } = $this->{ $dn }; + + if( $delFlag ) { + delete $this->{ $dn }; + } + return 0; + +} + +sub delete +{ + my $this = shift; + + my ( $dn ) = @_; + + delete $this->{$dn}; +} + +sub config +{ + my $this = shift; + + my ( @args ) = @_; + + return 1; +} + +1; + + diff --git a/servers/slapd/back-perl/compare.c b/servers/slapd/back-perl/compare.c index 03656cf273..25cc3808d8 100644 --- a/servers/slapd/back-perl/compare.c +++ b/servers/slapd/back-perl/compare.c @@ -49,7 +49,7 @@ perl_back_compare( dSP; ENTER; SAVETMPS; PUSHMARK(sp); - XPUSHs( perl_back->obj_ref ); + XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( dn , 0))); /* XPUSHs(sv_2mortal(newSVpv( cred->bv_val , cred->bv_len))); */ PUTBACK; diff --git a/servers/slapd/back-perl/config.c b/servers/slapd/back-perl/config.c index c2e4298e67..41f36a9a24 100644 --- a/servers/slapd/back-perl/config.c +++ b/servers/slapd/back-perl/config.c @@ -40,8 +40,9 @@ perl_back_db_config( PerlBackend *perl_back = (PerlBackend *) be->be_private; char eval_str[EVAL_BUF_SIZE]; int count ; - - /***** SECURITY PROBLEM HERE FIX LATER *****/ + int args; + int return_code; + if ( strcasecmp( argv[0], "perlModule" ) == 0 ) { if ( argc < 2 ) { @@ -65,7 +66,7 @@ perl_back_db_config( PUTBACK; count = perl_call_method("new", G_SCALAR); - + SPAGAIN; if (count != 1) { @@ -93,9 +94,39 @@ perl_back_db_config( * Pass it to Perl module if defined */ - fprintf( stderr, - "Unknown perl backend config: %s\n", argv[0]); - return( 1 ); + { + dSP ; ENTER ; SAVETMPS; + + PUSHMARK(sp) ; + XPUSHs( perl_back->pb_obj_ref ); + + /* Put all arguments on the perl stack */ + for( args = 0; args < argc; args++ ) { + XPUSHs(sv_2mortal(newSVpv(argv[args], 0))); + } + + PUTBACK ; + + count = perl_call_method("config", G_SCALAR); + + SPAGAIN ; + + if (count != 1) { + croak("Big trouble in config\n") ; + } + + return_code = POPi; + + PUTBACK ; FREETMPS ; LEAVE ; + + } + + /* if the module rejected it then we should reject it */ + if ( return_code != 0 ) { + fprintf( stderr, + "Unknown perl backeng config: %s\n", argv[0]); + exit( 1 ); + } } return 0; diff --git a/servers/slapd/back-perl/init.c b/servers/slapd/back-perl/init.c index 560a1716c0..59fecd7d6d 100644 --- a/servers/slapd/back-perl/init.c +++ b/servers/slapd/back-perl/init.c @@ -15,14 +15,16 @@ #include */ + + #include #include - #include "slap.h" #include "perl_back.h" + PerlInterpreter *perl_interpreter = NULL; ldap_pvt_thread_mutex_t perl_interpreter_mutex; @@ -96,7 +98,7 @@ perl_back_db_init( ) { be->be_private = (PerlBackend *) ch_malloc( sizeof(PerlBackend) ); - memset(&be->be_private, 0, sizeof(PerlBackend)); + memset( be->be_private, 0, sizeof(PerlBackend)); Debug( LDAP_DEBUG_TRACE, "perl backend db init\n", 0, 0, 0 ); diff --git a/servers/slapd/back-perl/modify.c b/servers/slapd/back-perl/modify.c index c0f8227a01..8ee8b82573 100644 --- a/servers/slapd/back-perl/modify.c +++ b/servers/slapd/back-perl/modify.c @@ -42,9 +42,10 @@ perl_back_modify( { dSP; ENTER; SAVETMPS; - + PUSHMARK(sp); XPUSHs( perl_back->pb_obj_ref ); + XPUSHs(sv_2mortal(newSVpv( dn , 0))); for (; modlist != NULL; modlist = modlist->ml_next ) { LDAPMod *mods = &modlist->ml_mod; @@ -63,7 +64,7 @@ perl_back_modify( break; } - + XPUSHs(sv_2mortal(newSVpv( mods->mod_type, 0 ))); for ( i = 0; diff --git a/servers/slapd/back-perl/modrdn.c b/servers/slapd/back-perl/modrdn.c index 12808fdf5e..1118829099 100644 --- a/servers/slapd/back-perl/modrdn.c +++ b/servers/slapd/back-perl/modrdn.c @@ -54,7 +54,7 @@ perl_back_modrdn( { dSP; ENTER; SAVETMPS; - + PUSHMARK(sp) ; XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( dn , 0 ))); @@ -79,7 +79,7 @@ perl_back_modrdn( } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); - + if( return_code != 0 ) { send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR, "", "" ); diff --git a/servers/slapd/back-perl/search.c b/servers/slapd/back-perl/search.c index b53809ba63..693fcd89fc 100644 --- a/servers/slapd/back-perl/search.c +++ b/servers/slapd/back-perl/search.c @@ -27,19 +27,19 @@ **********************************************************/ int perl_back_search( - Backend *be, - Connection *conn, - Operation *op, - char *base, - int scope, - int deref, - int sizelimit, - int timelimit, - Filter *filter, - char *filterstr, - char **attrs, - int attrsonly -) + Backend *be, + Connection *conn, + Operation *op, + char *base, + int scope, + int deref, + int sizelimit, + int timelimit, + Filter *filter, + char *filterstr, + char **attrs, + int attrsonly + ) { char test[500]; int count ; @@ -49,6 +49,7 @@ perl_back_search( Entry *e; char *buf; int i; + int return_code; ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); @@ -67,36 +68,59 @@ perl_back_search( } PUTBACK; - count = perl_call_method("search", G_SCALAR); + count = perl_call_method("search", G_ARRAY ); SPAGAIN; - if (count != 1) { + if (count < 1) { croak("Big trouble in back_search\n") ; } + + if ( count > 1 ) { - printf( "Before send search entry\n"); - buf = POPp; - - if ( (e = str2entry( buf )) == NULL ) { - Debug( LDAP_DEBUG_ANY, "str2entry(%s) failed\n", buf, 0, 0 ); - - } else { - send_search_entry( be, - conn, - op, - e, - attrs, - attrsonly ); + for ( i = 1; i < count; i++ ) { + + buf = POPp; + + if ( (e = str2entry( buf )) == NULL ) { + Debug( LDAP_DEBUG_ANY, "str2entry(%s) failed\n", buf, 0, 0 ); + + } else { + send_search_entry( be, + conn, + op, + e, + attrs, + attrsonly ); - entry_free( e ); + entry_free( e ); + } + } } + /* + * We grab the return code last because the stack comes + * from perl in reverse order. + * + * ex perl: return ( 0, $res_1, $res_2 ); + * + * ex stack: <$res_2> <$res_1> <0> + */ + + return_code = POPi; + + + PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); - send_ldap_result( conn, op, err, matched, info ); + if( return_code != 0 ) { + send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR, "", "" ); + + } else { + send_ldap_result( conn, op, LDAP_SUCCESS, "", "" ); + } }