ITS#1659

servers/slapd/back-perl/README

@@ -0,0 +1,25 @@
+
+Differences from 2.0 Perl API:
+
+- Perl 5.6 is supported
+
+- backend methods return actual LDAP result codes, not
+  true/false; this gives the Perl module finer control
+  of the error returned to the client
+
+- a filterSearchResults configuration file directive was
+  added to tell the backend glue that the results returned
+  from the Perl module are candidates only
+
+- the "init" method is called after the backend has been
+  initialized - this lets you do some initialization after
+  *all* configuration file directives have been read
+
+- the interface for the search method is improved to
+  pass the scope, deferencing policy, size limit, etc.
+  See SampleLDAP.pm for details.
+
+These changes were sponsored by myinternet pty ltd.
+
+Luke Howard <lukeh@padl.com>
+

servers/slapd/back-perl/SampleLDAP.pm

@@ -31,7 +31,8 @@ following actions that you wish to handle.
    * add        # adds an entry to back end
    * modrdn     # modifies a an entries rdn
    * delete     # deletes an ldap entry
-   * config     # process unknow config file lines
+   * config     # process unknown config file lines
+   * init       # called after backend is initialized
 
 =head2 new
 
@@ -52,9 +53,12 @@ This method is called when a search request comes from a client.
 It arguments are as follow.
 
   * obj reference
-  * filter string
+  * base DN
+  * scope
+  * alias deferencing policy
   * size limit
   * time limit
+  * filter string
   * attributes only flag ( 1 for yes )
   * list of attributes that are to be returned. (could be empty)
 
@@ -122,6 +126,12 @@ RETURN:
 
 RETURN: non zero value if this is not a valid option.
 
+=head2 init
+
+  * obj reference
+
+RETURN: non zero value if initialization failed.
+
 =head1 Configuration
 
 The perl section of the config file recognizes the following 
@@ -138,7 +148,9 @@ above.
 
   perlModule ModName       # use the module name ModName from ModName.pm
 
-
+  filterSearchResults      # search results are candidates that need to be
+                           # filtered, rather than search results to be 
+                           # returned directly to the client
 
 =cut
 
@@ -160,7 +172,7 @@ sub new
 sub search
 {
 	my $this = shift;
-	my( $filterStr, $sizeLim, $timeLim, $attrOnly, @attrs ) = @_;
+	my($base, $scope, $deref, $sizeLim, $timeLim, $filterStr, $attrOnly, @attrs ) = @_;
         print STDERR "====$filterStr====\n";
 	$filterStr =~ s/\(|\)//g;
 	$filterStr =~ s/=/: /;
@@ -188,12 +200,12 @@ sub compare
 {
 	my $this = shift;
 	my ( $dn, $avaStr ) = @_;
-	my $rc = 0;
+	my $rc = 5; # LDAP_COMPARE_FALSE
 
 	$avaStr =~ s/=/: /;
 
 	if ( $this->{ $dn } =~ /$avaStr/im ) {
-		$rc = 1;
+		$rc = 6; # LDAP_COMPARE_TRUE
 	}
 
 	return $rc;

servers/slapd/back-perl/add.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -47,7 +48,11 @@ perl_back_add(
 
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("add", G_SCALAR);
+#else
 		count = perl_call_method("add", G_SCALAR);
+#endif
 
 		SPAGAIN;
 
@@ -63,14 +68,8 @@ perl_back_add(
 	ldap_pvt_thread_mutex_unlock( &entry2str_mutex );
 	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );	
 
-	if( return_code != 0 ) {
-		send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR,
-			NULL, NULL, NULL, NULL );
-
-	} else {
-		send_ldap_result( conn, op, LDAP_SUCCESS,
-			NULL, NULL, NULL, NULL );
-	}
+	send_ldap_result( conn, op, return_code,
+		NULL, NULL, NULL, NULL );
 
 	Debug( LDAP_DEBUG_ANY, "Perl ADD\n", 0, 0, 0 );
 	return( 0 );

servers/slapd/back-perl/bind.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -56,7 +57,11 @@ perl_back_bind(
 		XPUSHs(sv_2mortal(newSVpv( cred->bv_val , cred->bv_len)));
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("bind", G_SCALAR);
+#else
 		count = perl_call_method("bind", G_SCALAR);
+#endif
 
 		SPAGAIN;
 

servers/slapd/back-perl/close.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this

servers/slapd/back-perl/compare.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -60,7 +61,11 @@ perl_back_compare(
 		XPUSHs(sv_2mortal(newSVpv( avastr , 0)));
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("compare", G_SCALAR);
+#else
 		count = perl_call_method("compare", G_SCALAR);
+#endif
 
 		SPAGAIN;
 
@@ -77,8 +82,8 @@ perl_back_compare(
 
 	ch_free( avastr );
 
-	send_ldap_result( conn, op, return_code ? LDAP_COMPARE_TRUE :
-		LDAP_COMPARE_FALSE, NULL, NULL, NULL, NULL );
+	send_ldap_result( conn, op, return_code,
+		NULL, NULL, NULL, NULL );
 
 	Debug( LDAP_DEBUG_ANY, "Perl COMPARE\n", 0, 0, 0 );
 

servers/slapd/back-perl/config.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -53,21 +54,32 @@ perl_back_db_config(
 			return( 1 );
 		}
 
-		strncpy(eval_str, argv[1], EVAL_BUF_SIZE );
+#ifdef PERL_IS_5_6
+		snprintf( eval_str, EVAL_BUF_SIZE, "use %s;", argv[1] );
+		eval_pv( eval_str, 0 );
+
+		if (SvTRUE(ERRSV)) {
+			fprintf(stderr , "Error %s\n", SvPV(ERRSV,  na)) ;
+#else
+		snprintf( eval_str, EVAL_BUF_SIZE, "%s", argv[1] );
 
 		perl_require_pv( strcat( eval_str, ".pm" ));
 
 		if (SvTRUE(GvSV(errgv))) {
 			fprintf(stderr , "Error %s\n", SvPV(GvSV(errgv), na)) ;
-
+#endif /* PERL_IS_5_6 */
 		} else {
 			dSP; ENTER; SAVETMPS;
 			PUSHMARK(sp);
 			XPUSHs(sv_2mortal(newSVpv(argv[1], 0)));
 			PUTBACK;
 
+#ifdef PERL_IS_5_6
+			count = call_method("new", G_SCALAR);
+#else
 			count = perl_call_method("new", G_SCALAR);
-			
+#endif
+
 			SPAGAIN;
 
 			if (count != 1) {
@@ -87,9 +99,15 @@ perl_back_db_config(
 			return( 1 );
 		}
 
-		sprintf( eval_str, "push @INC, '%s';", argv[1] );
+		snprintf( eval_str, EVAL_BUF_SIZE, "push @INC, '%s';", argv[1] );
+#ifdef PERL_IS_5_6
+		loc_sv = eval_pv( eval_str, 0 );
+#else
 		loc_sv = perl_eval_pv( eval_str, 0 );
+#endif
 
+	} else if ( strcasecmp( argv[0], "filterSearchResults" ) == 0 ) {
+		perl_back->pb_filter_search_results = 1;
 	} else {
 		/*
 		 * Pass it to Perl module if defined
@@ -108,7 +126,11 @@ perl_back_db_config(
 
 			PUTBACK ;
 
+#ifdef PERL_IS_5_6
+			count = call_method("config", G_SCALAR);
+#else
 			count = perl_call_method("config", G_SCALAR);
+#endif
 
 			SPAGAIN ;
 

servers/slapd/back-perl/delete.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -46,7 +47,11 @@ perl_back_delete(
 
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("delete", G_SCALAR);
+#else
 		count = perl_call_method("delete", G_SCALAR);
+#endif
 
 		SPAGAIN;
 
@@ -61,15 +66,9 @@ perl_back_delete(
 
 	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );	
 
-	if( return_code != 0 ) {
-		send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR,
+	send_ldap_result( conn, op, return_code,
 			NULL, NULL, NULL, NULL );
 
-	} else {
-		send_ldap_result( conn, op, LDAP_SUCCESS,
-			NULL, NULL, NULL, NULL );
-	}
-
 	Debug( LDAP_DEBUG_ANY, "Perl DELETE\n", 0, 0, 0 );
 	return( 0 );
 }

servers/slapd/back-perl/external.h

@@ -10,6 +10,7 @@ extern BI_close	perl_back_close;
 extern BI_destroy	perl_back_destroy;
 
 extern BI_db_init	perl_back_db_init;
+extern BI_db_open	perl_back_db_open;
 extern BI_db_destroy	perl_back_db_destroy;
 
 extern BI_db_config	perl_back_db_config;

servers/slapd/back-perl/init.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -33,15 +34,16 @@ ldap_pvt_thread_mutex_t	perl_interpreter_mutex;
 
 #ifdef SLAPD_PERL_DYNAMIC
 
-int back_perl_LTX_init_module(int argc, char *argv[]) {
-    BackendInfo bi;
+int back_perl_LTX_init_module(int argc, char *argv[])
+{
+	BackendInfo bi;
 
-    memset( &bi, '\0', sizeof(bi) );
-    bi.bi_type = "perl";
-    bi.bi_init = perl_back_initialize;
+	memset( &bi, '\0', sizeof(bi) );
+	bi.bi_type = "perl";
+	bi.bi_init = perl_back_initialize;
 
-    backend_add(&bi);
-    return 0;
+	backend_add(&bi);
+	return 0;
 }
 
 #endif /* SLAPD_PERL_DYNAMIC */
@@ -80,7 +82,7 @@ perl_back_initialize(
 
 	bi->bi_db_init = perl_back_db_init;
 	bi->bi_db_config = perl_back_db_config;
-	bi->bi_db_open = 0;
+	bi->bi_db_open = perl_back_db_open;
 	bi->bi_db_close = 0;
 	bi->bi_db_destroy = perl_back_db_destroy;
 
@@ -117,22 +119,66 @@ perl_back_open(
 
 int
 perl_back_db_init(
-	Backend	*be
+	BackendDB	*be
 )
 {
 	be->be_private = (PerlBackend *) ch_malloc( sizeof(PerlBackend) );
 	memset( be->be_private, '\0', sizeof(PerlBackend));
 
+	((PerlBackend *)be->be_private)->pb_filter_search_results = 0;
+
 	Debug( LDAP_DEBUG_TRACE, "perl backend db init\n", 0, 0, 0 );
 
 	return 0;
 }
 
+int
+perl_back_db_open(
+	BackendDB	*be
+)
+{
+	int count;
+	int return_code;
+
+	PerlBackend *perl_back = (PerlBackend *) be->be_private;
+
+	ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex );
+
+	{
+		dSP; ENTER; SAVETMPS;
+
+		PUSHMARK(sp);
+		XPUSHs( perl_back->pb_obj_ref );
+
+		PUTBACK;
+
+#ifdef PERL_IS_5_6
+		count = call_method("init", G_SCALAR);
+#else
+		count = perl_call_method("init", G_SCALAR);
+#endif
+
+		SPAGAIN;
+
+		if (count != 1) {
+			croak("Big trouble in perl_back_db_open\n");
+		}
+
+		return_code = POPi;
+
+		PUTBACK; FREETMPS; LEAVE;
+	}
+
+	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );
+
+	return return_code;
+}
+
 
 static void
 perl_back_xs_init()
 {
-    char *file = __FILE__;
-    dXSUB_SYS;
-        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+	char *file = __FILE__;
+	dXSUB_SYS;
+	newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 }

servers/slapd/back-perl/modify.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -79,7 +80,11 @@ perl_back_modify(
 
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("modify", G_SCALAR);
+#else
 		count = perl_call_method("modify", G_SCALAR);
+#endif
 
 		SPAGAIN;
 
@@ -94,14 +99,8 @@ perl_back_modify(
 
 	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );
 
-	if( return_code != 0 ) {
-		send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR,
-			NULL, NULL, NULL, NULL );
-
-	} else {
-		send_ldap_result( conn, op, LDAP_SUCCESS,
-			NULL, NULL, NULL, NULL );
-	}
+	send_ldap_result( conn, op, return_code,
+		NULL, NULL, NULL, NULL );
 
 	Debug( LDAP_DEBUG_ANY, "Perl MODIFY\n", 0, 0, 0 );
 	return( 0 );

servers/slapd/back-perl/modrdn.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -69,7 +70,11 @@ perl_back_modrdn(
 		}
 		PUTBACK ;
 
+#ifdef PERL_IS_5_6
+		count = call_method("modrdn", G_SCALAR);
+#else
 		count = perl_call_method("modrdn", G_SCALAR);
+#endif
 
 		SPAGAIN ;
 
@@ -84,14 +89,8 @@ perl_back_modrdn(
 
 	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );
 	
-	if( return_code != 0 ) {
-		send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR,
-			NULL, NULL, NULL, NULL );
-
-	} else {
-		send_ldap_result( conn, op, LDAP_SUCCESS,
-			NULL, NULL, NULL, NULL );
-	}
+	send_ldap_result( conn, op, return_code,
+		NULL, NULL, NULL, NULL );
 
 	Debug( LDAP_DEBUG_ANY, "Perl MODRDN\n", 0, 0, 0 );
 	return( 0 );

servers/slapd/back-perl/perl_back.h

@@ -5,15 +5,25 @@
 LDAP_BEGIN_DECL
 
 /*
+ * From Apache mod_perl: test for Perl version.[ja
  */
+#ifdef pTHX_
+#define PERL_IS_5_6
+#endif
+
 #define EVAL_BUF_SIZE 500
 
+#ifdef pTHX_
+#define PERL_IS_5_6
+#endif
+
 extern PerlInterpreter *perl_interpreter;
 extern ldap_pvt_thread_mutex_t  perl_interpreter_mutex;
 
 typedef struct perl_backend_instance {
-  char *pb_module_name;
-  SV   *pb_obj_ref;
+	char	*pb_module_name;
+	SV	*pb_obj_ref;
+	int	pb_filter_search_results;
 } PerlBackend;
 
 LDAP_END_DECL

servers/slapd/back-perl/search.c

@@ -1,6 +1,7 @@
 /* $OpenLDAP$ */
 /*
  *	 Copyright 1999, John C. Quillan, All rights reserved.
+ *	 Portions Copyright 2002, myinternet pty ltd. All rights reserved.
  *
  *	 Redistribution and use in source and binary forms are permitted only
  *	 as authorized by the OpenLDAP Public License.	A copy of this
@@ -61,9 +62,12 @@ perl_back_search(
 
 		PUSHMARK(sp) ;
 		XPUSHs( perl_back->pb_obj_ref );
-		XPUSHs(sv_2mortal(newSVpv( filterstr->bv_val , 0)));
+		XPUSHs(sv_2mortal(newSVpv( nbase->bv_val , 0)));
+		XPUSHs(sv_2mortal(newSViv( scope )));
+		XPUSHs(sv_2mortal(newSViv( deref )));
 		XPUSHs(sv_2mortal(newSViv( sizelimit )));
 		XPUSHs(sv_2mortal(newSViv( timelimit )));
+		XPUSHs(sv_2mortal(newSVpv( filterstr->bv_val , 0)));
 		XPUSHs(sv_2mortal(newSViv( attrsonly )));
 
 		for ( an = attrs; an && an->an_name.bv_val; an++ ) {
@@ -71,7 +75,11 @@ perl_back_search(
 		}
 		PUTBACK;
 
+#ifdef PERL_IS_5_6
+		count = call_method("search", G_ARRAY );
+#else
 		count = perl_call_method("search", G_ARRAY );
+#endif
 
 		SPAGAIN;
 
@@ -89,9 +97,18 @@ perl_back_search(
 					Debug( LDAP_DEBUG_ANY, "str2entry(%s) failed\n", buf, 0, 0 );
 
 				} else {
-					send_search_entry( be, conn, op,
-						e, attrs, attrsonly, NULL );
-							 
+					int send_entry;
+
+					if (perl_back->pb_filter_search_results)
+						send_entry = (test_filter( be, conn, op, e, filter ) == LDAP_COMPARE_TRUE);
+					else
+						send_entry = 1;
+
+					if (send_entry) {
+						send_search_entry( be, conn, op,
+							e, attrs, attrsonly, NULL );
+					}
+
 					entry_free( e );
 				}
 			}
@@ -115,13 +132,7 @@ perl_back_search(
 
 	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );	
 
-	if( return_code != 0 ) {
-		send_ldap_result( conn, op, LDAP_OPERATIONS_ERROR,
-			NULL, NULL, NULL, NULL );
-
-	} else {
-		send_ldap_result( conn, op, LDAP_SUCCESS,
-			NULL, NULL, NULL, NULL );
-	}
+	send_ldap_result( conn, op, return_code,
+		NULL, NULL, NULL, NULL );
 }