mirror of
https://git.openldap.org/openldap/openldap.git
synced 2024-12-09 02:52:04 +08:00
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
This commit is contained in:
John Quillan
parent
82453169fc
commit
3f1fd3bcee
273
servers/slapd/back-perl/SampleLDAP.pm
Normal file
273
servers/slapd/back-perl/SampleLDAP.pm
Normal file
@ -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<perlmod> 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<config> 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;
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -15,14 +15,16 @@
|
||||
#include <ac/socket.h>
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include <EXTERN.h>
|
||||
#include <perl.h>
|
||||
|
||||
|
||||
#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 );
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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, "", "" );
|
||||
|
||||
|
||||
@ -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") ;
|
||||
}
|
||||
|
||||
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 );
|
||||
if ( count > 1 ) {
|
||||
|
||||
entry_free( e );
|
||||
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 );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* 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, "", "" );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user