Import Ben Collins <bcollins@debian.org> Back-TCL for SLAPD.

acconfig.h

@@ -198,7 +198,7 @@
 /* define this to use SLAPD passwd backend */
 #undef SLAPD_PASSWD
 
-/* define this to use SLAPD perl backend */
+/* define this to use SLAPD Perl backend */
 #undef SLAPD_PERL
 
 /* define this for phonetic support */
@@ -210,6 +210,9 @@
 /* define this to use SLAPD shell backend */
 #undef SLAPD_SHELL
 
+/* define this to use SLAPD TCL backend */
+#undef SLAPD_TCL
+
 /* define this to be empty if your compiler doesn't support volatile */
 #undef volatile
 

configure.in

@@ -87,6 +87,7 @@ OL_ARG_WITH(ldbm_type,[      --with-ldbm-type	use LDBM type], auto,
 OL_ARG_ENABLE(passwd,[    --enable-passwd	enable passwd backend], no)dnl
 OL_ARG_ENABLE(perl,[    --enable-perl	enable perl backend], no)dnl
 OL_ARG_ENABLE(shell,[    --enable-shell	enable shell backend], no)dnl
+OL_ARG_ENABLE(tcl,[    --enable-tcl	enable tcl backend], no)dnl
 
 dnl SLURPD OPTIONS
 AC_ARG_WITH(xxslurpdoptions,[SLURPD Options:])
@@ -126,6 +127,9 @@ if test $ol_enable_slapd = no ; then
 	if test $ol_enable_shell = yes ; then
 		AC_MSG_WARN([slapd disabled, ignoring --enable_shell argument])
 	fi
+	if test $ol_enable_tcl = yes ; then
+		AC_MSG_WARN([slapd disabled, ignoring --enable_tcl argument])
+	fi
 	if test $ol_enable_aclgroups = yes ; then
 		AC_MSG_WARN([slapd disabled, ignoring --enable_aclgroups argument])
 	fi
@@ -154,6 +158,7 @@ if test $ol_enable_slapd = no ; then
 	ol_enable_passwd=no
 	ol_enable_perl=no
 	ol_enable_shell=no
+	ol_enable_tcl=no
 	ol_enable_aclgroups=no
 	ol_enable_wrappers=no
 	ol_enable_phonetic=no
@@ -179,7 +184,8 @@ elif test $ol_enable_ldbm = no ; then
 
 	if test $ol_enable_passwd = no -a \
 		$ol_enable_perl = no -a \
-		$ol_enable_shell = no ; then
+		$ol_enable_shell = no -a \
+		$ol_enable_tcl = no ; then
 		AC_MSG_ERROR([slapd requires a backend])
 	fi
 
@@ -247,6 +253,7 @@ BUILD_LDBM=no
 BUILD_PASSWD=no
 BUILD_PERL=no
 BUILD_SHELL=no
+BUILD_TCL=no
 BUILD_THREAD=no
 
 SLAPD_PERL_LDFLAGS=
@@ -1291,6 +1298,39 @@ if test $ol_enable_dmalloc != no ; then
 	AC_CHECK_LIB(dmalloc, dmalloc_shutdown)
 fi
 
+if test $ol_enable_tcl != no ; then
+	AC_CHECK_HEADERS(tcl.h)
+
+	if test $ac_cv_header_tcl_h != yes ; then
+		have_tcl=no
+	else
+		AC_CHECK_LIB(tcl,main,
+			[have_tcl=yes; SLAPD_LIBS="$SLAPD_LIBS -ltcl"],
+			[have_tcl=no])
+
+		if test $have_tcl != yes; then
+			AC_CHECK_LIB(tcl7.6,main,
+				[have_tcl=yes; SLAPD_LIBS="$SLAPD_LIBS -ltcl7.6"],
+				[have_tcl=no])
+		fi
+
+		if test $have_tcl != yes; then
+			AC_CHECK_LIB(tcl8.0,main,
+				[have_tcl=yes; SLAPD_LIBS="$SLAPD_LIBS -ltcl8.0"],
+				[have_tcl=no])
+		fi
+	fi
+
+	if test $have_tcl != yes ; then
+		AC_MSG_WARN([could not find -ltcl])
+		if test $ol_enable_tcl = yes ; then
+			AC_MSG_ERROR([could not find tcl, select appropriate options or disable])
+		fi
+
+		ol_enable_tcl=no
+	fi
+fi
+
 # ud needs termcap (should insert check here)
 ol_link_termcap=no
 AC_CHECK_HEADERS(termcap.h ncurses.h)
@@ -1584,6 +1624,12 @@ if test "$ol_enable_shell" != no ; then
 	BUILD_SHELL=yes
 fi
 
+if test "$ol_enable_tcl" != no ; then
+	AC_DEFINE(SLAPD_TCL,1)
+	BUILD_SLAPD=yes
+	BUILD_TCL=yes
+fi
+
 if test "$ol_enable_slurpd" != no -a "$ol_link_threads" != no -a \
 	$BUILD_SLAPD = yes ; then
 	BUILD_SLURPD=yes
@@ -1602,6 +1648,7 @@ AC_SUBST(BUILD_SLAPD)
   AC_SUBST(BUILD_PASSWD)
   AC_SUBST(BUILD_PERL)
   AC_SUBST(BUILD_SHELL)
+  AC_SUBST(BUILD_TCL)
 AC_SUBST(BUILD_SLURPD)
 
 AC_SUBST(LDAP_LIBS)
@@ -1655,6 +1702,7 @@ servers/slapd/back-ldbm/Makefile:build/top.mk:servers/slapd/back-ldbm/Makefile.i
 servers/slapd/back-passwd/Makefile:build/top.mk:servers/slapd/back-passwd/Makefile.in:build/srv.mk \
 servers/slapd/back-perl/Makefile:build/top.mk:servers/slapd/back-perl/Makefile.in:build/srv.mk \
 servers/slapd/back-shell/Makefile:build/top.mk:servers/slapd/back-shell/Makefile.in:build/srv.mk \
+servers/slapd/back-tcl/Makefile:build/top.mk:servers/slapd/back-tcl/Makefile.in:build/srv.mk \
 servers/slapd/shell-backends/Makefile:build/top.mk:servers/slapd/shell-backends/Makefile.in:build/srv.mk \
 servers/slapd/tools/Makefile:build/top.mk:servers/slapd/tools/Makefile.in \
 servers/slurpd/Makefile:build/top.mk:servers/slurpd/Makefile.in:build/srv.mk \

include/portable.h.in

@@ -190,7 +190,7 @@
 /* define this to use SLAPD passwd backend */
 #undef SLAPD_PASSWD
 
-/* define this to use SLAPD perl backend */
+/* define this to use SLAPD Perl backend */
 #undef SLAPD_PERL
 
 /* define this for phonetic support */
@@ -202,6 +202,9 @@
 /* define this to use SLAPD shell backend */
 #undef SLAPD_SHELL
 
+/* define this to use SLAPD TCL backend */
+#undef SLAPD_TCL
+
 /* define this to be empty if your compiler doesn't support volatile */
 #undef volatile
 
@@ -513,6 +516,9 @@
 /* Define if you have the <syslog.h> header file.  */
 #undef HAVE_SYSLOG_H
 
+/* Define if you have the <tcl.h> header file.  */
+#undef HAVE_TCL_H
+
 /* Define if you have the <tcpd.h> header file.  */
 #undef HAVE_TCPD_H
 

servers/slapd/back-tcl/Makefile.in

@@ -0,0 +1,45 @@
+########################################################################### 
+# 
+# Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+# license is available at http://www.OpenLDAP.org/license.html or
+# in file LICENSE in the top-level directory of the distribution.
+# 
+##########################################################################
+XSRCS	= version.c
+
+SRCS	= tcl_init.c tcl_search.c tcl_close.c tcl_config.c tcl_bind.c \
+	tcl_unbind.c tcl_compare.c tcl_modify.c tcl_add.c tcl_modrdn.c \
+	tcl_delete.c tcl_abandon.c tcl_util.c
+OBJS	= tcl_init.o tcl_search.o tcl_close.o tcl_config.o tcl_bind.o \
+	tcl_unbind.o tcl_compare.o tcl_modify.o tcl_add.o tcl_modrdn.o \
+	tcl_delete.o tcl_abandon.o tcl_util.o
+
+LDAP_INCDIR= ../../../include       
+LDAP_LIBDIR= ../../../libraries
+
+BUILD_OPT = "--enable-tcl"
+BUILD_SRV = @BUILD_TCL@
+
+PROGRAMS =		libback-tcl.a
+
+XINCPATH = -I.. -I$(srcdir)/..
+
+all-local-srv:	FORCE
+	$(MAKE) $(MFLAGS) libback-tcl.a
+
+libback-tcl.a:	version.o
+	$(AR) ruv $@ $(OBJS) version.o
+	@$(RANLIB) $@
+	@touch ../.backend
+
+version.c: $(OBJS) $(LDAP_LIBDEPEND)
+	$(RM) $@
+	(u=$${USER-root} v=`$(CAT) $(VERSIONFILE)` d=`$(PWD)` h=`$(HOSTNAME)` \
+	t=`$(DATE)`; $(SED) -e "s|%WHEN%|$${t}|" \
+	-e "s|%WHOANDWHERE%|$${u}@$${h}:$${d}|" \
+	-e "s|%VERSION%|$${v}|" \
+	< $(srcdir)/Version.c > $@)
+

servers/slapd/back-tcl/README.back-tcl

@@ -0,0 +1,206 @@
+Tcl Backend Interface for OpenLDAP
+
+
+----------------------------
+Synopsis of slapd.conf setup
+----------------------------
+
+database	tcl
+suffix          o=Suffix
+
+# The full path to the tcl script used for this database
+scriptpath      /usr/lib/ldap/database.tcl
+
+# The procs for each ldap function. This similar to how
+# the shell backend setup works, but these refer to
+# the tcl procs in the 'scriptpath' script that handle them
+search          <proc>
+add             <proc>
+delete          <proc>
+modify          <proc>
+bind            <proc>
+unbind          <proc>
+modrdn		<proc>
+compare		<proc>
+abandon		<proc>
+
+# This is one of the biggest pluses of using the tcl backend.
+# The realm let's you group several databases to the same interpretor.
+# This basically means they share the same global variables and proc
+# space. So global variables, as well as all the procs are callable
+# between databases. If no tclrealm is specified, it is put into the
+# "default" realm.
+tclrealm        <interpretor name>
+
+
+-----------------------------------------
+Synopsis of variables passed to the procs
+-----------------------------------------
+
+abandon { action msgid suffix }
+
+	action - Always equal to ABANDON
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one is
+		 and entry in a tcl formatted list (surrounded by {}'s)
+
+add { action msgid suffix entry }
+
+	action - Always equal to ADD
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one is
+		 and entry in a tcl formatted list (surrounded by {}'s)
+	entry  - Full entry to add. Each "type: val" is an element in a
+		 tcl formatted list.
+
+bind { action msgid suffix dn method cred_len cred }
+
+	action   - Always equal to BIND
+	msgid    - The msgid of this ldap session
+	suffix   - List of suffix(es) associated with the call. Each one
+		   is and entry in a tcl formatted list (surrounded by {}'s)
+	dn       - DN being bound to
+	method   - One of the ldap authentication methods
+	cred_len - Length of cred
+	cred     - Credentials being used to authenticate, according to
+		   RFC, if this value is empty, then it should be
+		   considered an anonomous bind (??)
+
+compare { action msgid suffix dn ava_type ava_value }
+
+	action    - Always equal to COMPARE
+	msgid     - The msgid of this ldap session
+	suffix    - List of suffix(es) associated with the call. Each one
+		    is and entry in a tcl formatted list (surrounded by {}'s)
+	dn        - DN for compare
+	ava_type  - Type for comparison
+	ava_value - Value to compare
+
+delete { action msgid suffix dn }
+
+	action    - Always equal to DELETE
+	msgid     - The msgid of this ldap session
+	suffix    - List of suffix(es) associated with the call. Each one
+		    is and entry in a tcl formatted list (surrounded by {}'s)
+	dn        - DN to delete
+
+modify { action msgid suffix dn mods }
+
+	action - Always equal to MODIFY
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one
+		 is and entry in a tcl formatted list (surrounded by {}'s)
+	dn     - DN to modify
+	mods   - Tcl list of modifications. List is formatted in this way:
+
+		 {
+		   { {op: type} {type: val} }
+		   { {op: type} {type: val} {type: val} }
+		   ...
+		 }
+
+		 Newlines are not present in the actual var, they are
+		 present here for clarification. "op" is the type of
+		 modification (add, delete, replace).
+
+modrdn { action msgid suffix dn newrdn deleteoldrdn }
+
+	action - Always equal to MODRDN
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one
+		 is and entry in a tcl formatted list (surrounded by {}'s)
+	dn     - DN who's RDN is being renamed
+	newrdn - New RDN
+	deleteoldrdn - Boolean stating whether or not the old RDN should
+		 be removed after being renamed
+
+search { action msgid suffix base scope deref sizelimit timelimit
+	 filterstr attrsonly attrlist }
+
+	action - Always equal to SEARCH
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one
+		 is and entry in a tcl formatted list (surrounded by {}'s)
+	base   - Base for this search
+	scope  - Scope of search, ( 0 | 1 | 2 )
+	deref  - Alias dereferencing ( 0 | 1 | 2 | 3 )
+	sizelimit - Script should try not to return more data that this
+	timelimit - Time limit for search
+	filterstr - Filter string as sent by the requestor.
+	attrsonly - Boolean for whether to list only the attributes
+		 instead of attributes and their values.
+	attrlist  - Tcl list if to retrieve.
+
+unbind { action msgid suffix dn }
+
+	action - Always equal to UNBIND
+	msgid  - The msgid of this ldap session
+	suffix - List of suffix(es) associated with the call. Each one
+		 is and entry in a tcl formatted list (surrounded by {}'s)
+	dn     - DN to unbind
+
+
+------------------------------------
+Synopsis of Return Method and Syntax
+------------------------------------
+
+There are only 2 return types. All procs must return a result to show
+status of the operation. The result is in this form: 
+
+  { RESULT {code: <integer>} {matched: <partialdn>} {info: <string>} {} }
+
+This is best accomplished with this type of tcl code
+
+  lappend ret_val "RESULT"
+  lappend ret_val "code: 0"
+  lappend ret_val ""
+  return $ret_val
+
+The final empty string (item in list) is neccesary to point to the end of
+list. The 'code', 'matched', and 'info' values are not neccesary, and
+default values are given if not specified. The 'code' value is usually an
+LDAP error in decimal notation from ldap.h. The 'info', may be sent back
+to the client, depending on the function. LDAP uses the value of 'code' to
+indicate whether or not the authentication is acceptible in the bind proc.
+
+The other type of return is for searches. It is similar format to the
+shell backend return (as is most of the syntax here). It's format follows:
+
+    {dn: o=Company, c=US} {attr: val} {objectclass: val} {}
+    {dn: o=CompanyB, c=US} {attr: val} {objectclass: val} {}
+
+Again, newlines are for visual purposes here. Also note the {} marking the
+end of the entry (same affect as a newline in ldif format). Here is some
+example code again, showing a full search proc example.
+
+# Note that 'args' let's you lump all possible args into one var, used
+# here for simplicity of exmaple
+proc ldap:search { args } {
+  # perform some operations
+
+  lappend ret_val "dn: $rdn,$base"
+  lappend ret_val "objectclass: $objcl"
+  lappend ret_val "sn: $rdn"
+  lappend ret_val "mail: $email"
+  lappend ret_val ""
+# Now setup the result
+  lappend ret_val "RESULT"
+  lappend ret_val "code: 0"
+  lappend ret_val ""
+
+  return $ret_val
+}
+
+NOTE: Newlines in the return value is acceptible in search entries (ie.
+when returning base64 encoded binary entries).
+
+-------------------------------------
+Synopsis of Builtin Commands and Vars
+-------------------------------------
+
+ldap:debug <msg>
+
+  Allows you to send debug messages through OpenLDAP's native debuging
+  system, this is sent as a LDAP_DEBUG_ANY and will be logged. Useful for
+  debugging scripts or logging bind failures.
+

servers/slapd/back-tcl/TODO

@@ -0,0 +1,2 @@
+* lock mutex on a per interpreter basis instead of global
+* Add a version callable from the tcl script for checking features

servers/slapd/back-tcl/Version.c

@@ -0,0 +1,10 @@
+/*
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+static char Versionstr[] = "  tcl backend %VERSION% (%WHEN%)\n\t%WHOANDWHERE%\n";

servers/slapd/back-tcl/external.h

@@ -0,0 +1,54 @@
+#ifndef _TCL_EXTERNAL_H
+#define _TCL_EXTERNAL_H
+
+LDAP_BEGIN_DECL
+
+extern int	tcl_back_initialize LDAP_P(( BackendInfo *bi ));
+extern int	tcl_back_open LDAP_P(( BackendInfo *bi ));
+extern int	tcl_back_close LDAP_P(( BackendInfo *bi ));
+extern int	tcl_back_destroy LDAP_P(( BackendInfo *bi ));
+
+extern int	tcl_back_db_init LDAP_P(( BackendDB *bd ));
+extern int	tcl_back_db_open LDAP_P(( BackendDB *bd ));
+extern int	tcl_back_db_destroy LDAP_P(( BackendDB *bd ));
+
+extern int	tcl_back_db_config LDAP_P(( BackendDB *bd,
+	char *fname, int lineno, int argc, char **argv ));
+
+extern int tcl_back_bind LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op,
+	char *dn, int method, struct berval *cred, char** edn ));
+
+extern int	tcl_back_unbind LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op ));
+
+extern int	tcl_back_search LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op,
+	char *base, int scope, int deref, int sizelimit, int timelimit,
+	Filter *filter, char *filterstr, char **attrs, int attrsonly ));
+
+extern int	tcl_back_compare LDAP_P((BackendDB *bd,
+	Connection *conn, Operation *op,
+	char *dn, Ava 	*ava ));
+
+extern int	tcl_back_modify LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op,
+	char *dn, LDAPModList *ml ));
+
+extern int	tcl_back_modrdn LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op,
+	char *dn, char*newrdn, int deleteoldrdn ));
+
+extern int	tcl_back_add LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op, Entry *e ));
+
+extern int	tcl_back_delete LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op, char *dn ));
+
+extern int	tcl_back_abandon LDAP_P(( BackendDB *bd,
+	Connection *conn, Operation *op, int msgid ));
+
+LDAP_END_DECL
+
+#endif /* _TCL_EXTERNAL_H */
+

servers/slapd/back-tcl/tcl_abandon.c

@@ -0,0 +1,54 @@
+/*
+ * abandon.c - tcl abandon routine
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_abandon (
+	Backend	*be,
+	Connection	*conn,
+	Operation	*op,
+	int		msgid
+)
+{
+	char *suf_tcl, *results, *command;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_abandon == NULL) {
+		return;
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_abandon) + strlen(suf_tcl)
+		+ 20);
+	sprintf(command, "%s ABANDON {%ld} {%s}",
+		ti->ti_abandon, op->o_msgid, suf_tcl);
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		Debug(LDAP_DEBUG_ANY, "tcl_abandon_error: %s\n", results, 0, 0);
+	}
+
+}

servers/slapd/back-tcl/tcl_add.c

@@ -0,0 +1,66 @@
+/*
+ * add.c - tcl add routine
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_add (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	Entry * e
+)
+{
+	char *command, *suf_tcl, *entrystr, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_add == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"add not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	entrystr = tcl_clean_entry(e);
+
+	command = (char *) ch_malloc (strlen(ti->ti_add) + strlen(suf_tcl) + 
+	strlen(entrystr) + 32);
+	sprintf(command, "%s ADD {%ld} {%s} {%s}",
+		ti->ti_add, op->o_msgid, suf_tcl, entrystr);
+	Tcl_Free(suf_tcl);
+	free (entrystr);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_add_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+	return (err);
+}
+

servers/slapd/back-tcl/tcl_bind.c

@@ -0,0 +1,68 @@
+/*
+ * bind.c - tcl bind routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_bind (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	char *dn,
+	int method,
+	struct berval *cred,
+	char** edn
+)
+{
+	char *command, *suf_tcl, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	*edn = NULL;
+
+	if (ti->ti_bind == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"bind not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_bind) + strlen(suf_tcl) +
+		strlen(dn) + strlen(cred->bv_val) + 64);
+	sprintf(command, "%s BIND {%ld} {%s} {%s} {%d} {%lu} {%s}",
+		ti->ti_bind, op->o_msgid, suf_tcl, dn, method, cred->bv_len,
+		cred->bv_val);
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_bind_error: %s\n", results, 0, 0);
+	} else {
+		err = interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+	return (err);
+}

servers/slapd/back-tcl/tcl_close.c

@@ -0,0 +1,56 @@
+/*
+ * close.c - tcl close routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int
+tcl_back_close (
+	BackendInfo * bi
+)
+{
+	return 0;
+}
+
+int
+tcl_back_destroy(
+		BackendInfo *bi
+)
+{
+		ldap_pvt_thread_mutex_destroy( &tcl_interpreter_mutex );
+
+		return 0;
+}
+
+int
+tcl_back_db_destroy(
+		BackendDB *bd
+)
+{
+	struct tclinfo *ti = (struct tclinfo *) bd->be_private;
+	struct i_info *ti_tmp;
+
+	ti->ti_ii->count--;
+	if (!ti->ti_ii->count && strcasecmp("default", ti->ti_ii->name)) {
+		/* no more db's using this and it's not the default */
+		for(ti_tmp = global_i; ti_tmp->next != ti->ti_ii; ti_tmp = ti_tmp->next)
+			;
+		ti_tmp->next = ti->ti_ii->next;
+		free(ti->ti_ii);
+		free(ti);
+	}
+	free( bd->be_private );
+	bd->be_private = NULL;
+}

servers/slapd/back-tcl/tcl_compare.c

@@ -0,0 +1,67 @@
+/*
+ * compare.c - tcl compare routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int
+tcl_back_compare (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	char *dn,
+	Ava * ava
+)
+{
+	char *command, *suf_tcl, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_compare == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"compare not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_compare) +
+		strlen(suf_tcl) + strlen(dn) + strlen(ava->ava_type) +
+		strlen(ava->ava_value.bv_val) + 64);
+	sprintf(command, "%s COMPARE {%ld} {%s} {%s} {%s: %s}",
+		ti->ti_compare, op->o_msgid, suf_tcl, dn, ava->ava_type,
+	ava->ava_value.bv_val);
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_compare_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+	return (0);
+
+}

servers/slapd/back-tcl/tcl_config.c

@@ -0,0 +1,219 @@
+/*
+ * config.c - tcl backend configuration file routine
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+struct i_info *global_i;
+
+int tcl_back_db_config (
+	BackendDB * bd,
+	char *fname,
+	int lineno,
+	int argc,
+	char **argv
+)
+{
+	struct tclinfo *ti = (struct tclinfo *) bd->be_private;
+	int script_loaded = 0;
+
+	if (ti == NULL) {
+		fprintf (stderr, "%s: line %d: tcl backend info is null!\n", fname,
+			lineno);
+		exit (1);
+	}
+	if (ti->ti_ii == NULL) {
+		ti->ti_ii = global_i;
+	}
+
+	/* Script to load */
+	if (strcasecmp (argv[0], "scriptpath") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing script in \"scriptpath <script>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->script_path = (char *) strdup (argv[1]);
+
+	/* use local interpreter */
+	} else if (strcasecmp (argv[0], "tclrealm") == 0) {
+		struct i_info *ii;
+
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing script in \"tclrealm <name>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_ii = NULL;
+
+		ii = global_i;
+		do {
+			if (ii != NULL && !strcasecmp (ii->name, argv[1]))
+			ti->ti_ii = ii;
+			if (ii->next != NULL)
+			ii = ii->next;
+		} while (ii->next != NULL);
+
+		if (ti->ti_ii == NULL) {	/* we need to make a new one */
+			ii->next = (struct i_info *) ch_malloc (sizeof (struct i_info));
+
+			ii->next->count = 0;
+			ii->next->name = (char *) strdup (argv[1]);
+			ii->next->next = NULL;
+			ii->next->interp = Tcl_CreateInterp ();
+			Tcl_Init (ii->next->interp);
+			ti->ti_ii = ii;
+		}
+
+	/* proc for binds */
+	} else if (strcasecmp (argv[0], "bind") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"bind <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_bind = (char *) strdup (argv[1]);
+
+	/* proc for unbinds */
+	} else if (strcasecmp (argv[0], "unbind") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+			"%s: line %d: missing proc in \"unbind <proc>\" line\n",
+			fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_unbind = (char *) strdup (argv[1]);
+
+	/* proc for search */
+	} else if (strcasecmp (argv[0], "search") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"search <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_search = (char *) strdup (argv[1]);
+
+	/* proc for compares */
+	} else if (strcasecmp (argv[0], "compare") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"compare <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_compare = (char *) strdup (argv[1]);
+
+	/* proc for modify */
+	} else if (strcasecmp (argv[0], "modify") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"modify <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_modify = (char *) strdup (argv[1]);
+
+	/* proc for modrdn */
+	} else if (strcasecmp (argv[0], "modrdn") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"modrdn <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_modrdn = (char *) strdup (argv[1]);
+
+	/* proc for add */
+	} else if (strcasecmp (argv[0], "add") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"add <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_add = (char *) strdup (argv[1]);
+
+	/* proc for delete */
+	} else if (strcasecmp (argv[0], "delete") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"delete <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_delete = (char *) strdup (argv[1]);
+
+	/* proc for abandon */
+	} else if (strcasecmp (argv[0], "abandon") == 0) {
+		if (argc < 2) {
+			Debug (LDAP_DEBUG_ANY,
+				"%s: line %d: missing proc in \"abandon <proc>\" line\n",
+				fname, lineno, 0);
+			exit (1);
+		}
+		ti->ti_search = (char *) strdup (argv[1]);
+
+	} else {
+		fprintf (stderr,
+			"Unknown tcl backend config: %s\n", argv[0]);
+		exit (1);
+	}
+
+	return 0;
+}
+
+int tcl_back_db_open (
+	BackendDB * bd
+)
+{
+	struct tclinfo *ti = (struct tclinfo *) bd->be_private;
+
+	/* raise that count for the interpreter */
+	ti->ti_ii->count++;
+
+	/* now let's (try to) load the script */
+	readtclscript (ti->script_path, ti->ti_ii->interp);
+
+	/* Intall the debug command */
+	Tcl_CreateCommand( ti->ti_ii->interp, "ldap:debug", &tcl_ldap_debug,
+	NULL, NULL);
+
+	return 0;
+}
+
+void readtclscript (char *script, Tcl_Interp * my_tcl)
+{
+	int code;
+	FILE *f;
+	f = fopen (script, "r");
+	if (f == NULL) {
+		Debug (LDAP_DEBUG_ANY, "Could not open scriptpath %s\n", script,
+			0, 0);
+		exit (1);
+	}
+	fclose (f);
+	code = Tcl_EvalFile (my_tcl, script);
+	if (code != TCL_OK) {
+		Debug (LDAP_DEBUG_ANY, "%s: %s\n", script,
+			Tcl_GetVar (my_tcl, "errorInfo", TCL_GLOBAL_ONLY), 0);
+		Debug (LDAP_DEBUG_ANY, "%s: error at line\n", script,
+	  		my_tcl->errorLine, 0);
+		exit (1);
+	}
+}

servers/slapd/back-tcl/tcl_delete.c

@@ -0,0 +1,63 @@
+/*
+ * delete.c - tcl delete routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+tcl_back_delete (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	char *dn
+)
+{
+	char *command, *suf_tcl, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_delete == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"delete not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_delete) + strlen(suf_tcl)
+		+ strlen(dn) + 64);
+	sprintf(command, "%s DELETE {%ld} {%s} {%s}",
+		ti->ti_delete, op->o_msgid, suf_tcl, dn);
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_delete_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+
+	return (0);
+}

servers/slapd/back-tcl/tcl_init.c

@@ -0,0 +1,99 @@
+/*
+ * tcl_init.c - tcl backend initialization
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include <ac/socket.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+ldap_pvt_thread_mutex_t tcl_interpreter_mutex;
+
+int
+tcl_back_initialize(
+	BackendInfo	*bi
+)
+{
+	/* Initialize the global interpreter array */
+	global_i = (struct i_info *) ch_malloc (sizeof (struct i_info));
+	global_i->count = 0;
+	global_i->name = "default";
+	global_i->next = NULL;
+	global_i->interp = Tcl_CreateInterp ();
+	Tcl_Init (global_i->interp);
+
+	/* Initialize the global interpreter lock */
+	ldap_pvt_thread_mutex_init( &tcl_interpreter_mutex );
+	bi->bi_open = NULL;
+	bi->bi_config = NULL;
+	bi->bi_close = NULL;
+	bi->bi_destroy = NULL;
+
+	bi->bi_db_init = tcl_back_db_init;
+	bi->bi_db_config = tcl_back_db_config;
+	bi->bi_db_open = tcl_back_db_open;
+	bi->bi_db_close = NULL;
+	bi->bi_db_destroy = tcl_back_db_destroy;
+
+	bi->bi_op_bind = tcl_back_bind;
+	bi->bi_op_unbind = tcl_back_unbind;
+	bi->bi_op_search = tcl_back_search;
+	bi->bi_op_compare = tcl_back_compare;
+	bi->bi_op_modify = tcl_back_modify;
+	bi->bi_op_modrdn = tcl_back_modrdn;
+	bi->bi_op_add = tcl_back_add;
+	bi->bi_op_delete = tcl_back_delete;
+	bi->bi_op_abandon = tcl_back_abandon;
+
+	bi->bi_acl_group = NULL;
+
+	return 0;
+}
+
+int
+tcl_back_db_init(
+	Backend	*be
+)
+{
+	struct tclinfo	*ti;
+
+	ti = (struct tclinfo *) ch_calloc( 1, sizeof(struct tclinfo) );
+
+	/*
+	 * For some reason this causes problems
+	 * specifically set to NULL
+	 */
+	ti->ti_bind = NULL;
+	ti->ti_unbind = NULL;
+	ti->ti_search = NULL;
+	ti->ti_compare = NULL;
+	ti->ti_modify = NULL;
+	ti->ti_modrdn = NULL;
+	ti->ti_add = NULL;
+	ti->ti_delete = NULL;
+	ti->ti_abandon = NULL;
+
+	be->be_private = ti;
+
+	return ti == NULL;
+}
+
+int
+tcl_back_db_destroy(
+	Backend	*be
+)
+{
+	free( be->be_private );
+	return 0;
+}

servers/slapd/back-tcl/tcl_modify.c

@@ -0,0 +1,112 @@
+/*
+ * modify.c - tcl modify routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_modify (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	char *dn,
+	LDAPModList * modlist
+)
+{
+	char *command, *suf_tcl, *bp, *tcl_mods, *results;
+	int i, code, err = 0, len, bsize;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_modify == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"modify not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	tcl_mods = (char *) ch_malloc( BUFSIZ );
+	tcl_mods[0] = '\0';
+	bsize = BUFSIZ;
+	bp = tcl_mods;
+
+	for ( ; modlist != NULL; modlist = modlist->ml_next ) {
+		LDAPMod *mods = &modlist->ml_mod;
+		char *op = NULL;
+
+		switch ( mods->mod_op & ~LDAP_MOD_BVALUES ) {
+		case LDAP_MOD_ADD:
+			op = "add";
+			break;
+		case LDAP_MOD_DELETE:
+			op = "delete";
+			break;
+		case LDAP_MOD_REPLACE:
+			op = "replace";
+			break;
+		}
+
+		len = strlen( mods->mod_type ) + strlen ( op ) + 7;
+		while ( bp + len - tcl_mods > bsize ) {
+			bsize += BUFSIZ;
+			tcl_mods = (char *) ch_realloc( tcl_mods, bsize );
+		}
+		sprintf(bp, "{ {%s: %s} ", op, mods->mod_type);
+		bp += len;
+		for( i = 0;
+			mods->mod_bvalues != NULL && mods->mod_bvalues[i] != NULL;
+			i++ )
+		{
+			len = strlen( mods->mod_type ) + strlen (
+				mods->mod_bvalues[i]->bv_val ) + 5 +
+				(mods->mod_bvalues[i+1] == NULL ? 2 : 0);
+			while ( bp + len - tcl_mods > bsize ) {
+				bsize += BUFSIZ;
+				tcl_mods = (char *) ch_realloc( tcl_mods, bsize );
+			}
+			sprintf(bp, "{%s: %s} %s", mods->mod_type,
+			mods->mod_bvalues[i]->bv_val, mods->mod_bvalues[i+1] ==
+			NULL ? "} " : "");
+			bp += len;
+		}
+	}
+
+	command = (char *) ch_malloc (strlen(ti->ti_modify) + strlen(suf_tcl)
+		+ strlen(dn) + strlen(tcl_mods) + 64);
+	/* This space is simply for aesthetics--\  */
+	sprintf(command, "%s MODIFY {%ld} {%s} {%s} { %s}",
+		ti->ti_modify, op->o_msgid, suf_tcl, dn, tcl_mods);
+	Tcl_Free(suf_tcl);
+	free(tcl_mods);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_modify_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+
+	return (0);
+}

servers/slapd/back-tcl/tcl_modrdn.c

@@ -0,0 +1,65 @@
+/*
+ * modrdn.c - tcl modify rdn routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_modrdn (
+	Backend * be,
+	Connection * conn,
+	Operation * op,
+	char *dn,
+	char *newrdn,
+	int deleteoldrdn
+)
+{
+	char *command, *suf_tcl, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_modrdn == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"modrdn not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_modrdn) + strlen(suf_tcl)
+		+ strlen(dn) + strlen(newrdn) + 64);
+	sprintf(command, "%s MODRDN {%ld} {%s} {%s} {%s} %d",
+		ti->ti_add, op->o_msgid, suf_tcl, dn, newrdn, deleteoldrdn ? 1 : 0);
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_modrdn_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+
+	return (0);
+}

servers/slapd/back-tcl/tcl_search.c

@@ -0,0 +1,81 @@
+/*
+ * search.c - tcl search routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_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
+)
+{
+	char *attrs_tcl = NULL, *suf_tcl, *results, *command;
+	int i, err = 0, code;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+	Entry *e;
+
+	if (ti->ti_search == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"search not implemented");
+		return (-1);
+	}
+
+	for ( i = 0; attrs != NULL && attrs[i] != NULL; i++ )
+		;
+	if (i > 0)
+		attrs_tcl = Tcl_Merge(i, attrs);
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_search) + strlen(suf_tcl)
+		+ strlen(base) + 40 + strlen(filterstr) + (attrs_tcl == NULL ? 5
+		: strlen(attrs_tcl)) + 72);
+	sprintf(command, "%s SEARCH {%ld} {%s} {%s} {%d} {%d} {%d} {%d} {%s} {%d} {%s}",
+		ti->ti_search, op->o_msgid, suf_tcl, base, scope, deref,
+		sizelimit, timelimit, filterstr, attrsonly ? 1 : 0, attrs_tcl == 
+		NULL ? "{all}" : attrs_tcl);
+	Tcl_Free( attrs_tcl );
+	Tcl_Free( suf_tcl );
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		err = LDAP_OPERATIONS_ERROR;
+		Debug(LDAP_DEBUG_ANY, "tcl_search_error: %s\n", results, 0, 0);
+	} else {
+		interp_send_results ( be, conn, op, results, NULL, 0 );
+	}
+
+	if (err != LDAP_SUCCESS)
+		send_ldap_result (conn, op, err, NULL, "internal backend error");
+	return (0);
+
+}

servers/slapd/back-tcl/tcl_unbind.c

@@ -0,0 +1,55 @@
+/*
+ * unbind.c - tcl unbind routines
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int tcl_back_unbind (
+	Backend * be,
+	Connection * conn,
+	Operation * op
+)
+{
+	char *command, *suf_tcl, *results;
+	int i, code, err = 0;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+
+	if (ti->ti_unbind == NULL) {
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"unbind not implemented");
+		return;
+	}
+
+	for ( i = 0; be->be_suffix[i] != NULL; i++ )
+		;
+	suf_tcl = Tcl_Merge(i, be->be_suffix);
+
+	command = (char *) ch_malloc (strlen(ti->ti_unbind) + strlen(suf_tcl)
+		+ strlen(conn->c_dn ? conn->c_dn : "") + 64);
+	sprintf(command, "%s UNBIND {%ld} {%s} {%s}",
+		ti->ti_unbind, op->o_msgid, suf_tcl, conn->c_dn ? conn->c_dn : "");
+	Tcl_Free(suf_tcl);
+
+	ldap_pvt_thread_mutex_lock( &tcl_interpreter_mutex );
+	code = Tcl_GlobalEval(ti->ti_ii->interp, command);
+	results = (char *) strdup(ti->ti_ii->interp->result);
+	ldap_pvt_thread_mutex_unlock( &tcl_interpreter_mutex );
+	free(command);
+
+	if (code != TCL_OK) {
+		Debug(LDAP_DEBUG_ANY, "tcl_unbind_error: %s\n", results, 0, 0);
+	}
+	return 0;
+}

servers/slapd/back-tcl/tcl_util.c

@@ -0,0 +1,152 @@
+/*
+ * result.c - tcl backend utility functions
+ *
+ * Copyright 1999, Ben Collins <bcollins@debian.org>, 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
+ * license is available at http://www.OpenLDAP.org/license.html or
+ * in file LICENSE in the top-level directory of the distribution.
+ */
+
+#include "portable.h"
+
+#include <stdio.h>
+
+#include <ac/string.h>
+#include <ac/socket.h>
+#include <ac/unistd.h>
+
+#include "slap.h"
+#include "tcl_back.h"
+
+int
+interp_send_results(
+    Backend	*be,
+    Connection	*conn,
+    Operation	*op,
+    char	*result,
+    char	**attrs,
+    int		attrsonly
+)
+{
+	int	bsize, len, argcPtr, i, err, code;
+	char	*buf, *bp, **argvPtr, *line, *matched, *info;
+	Entry	*e;
+	struct tclinfo *ti = (struct tclinfo *) be->be_private;
+	/* read in the result and send it along */
+	buf = (char *) ch_malloc( BUFSIZ );
+	buf[0] = '\0';
+	bsize = BUFSIZ;
+	bp = buf;
+	code = Tcl_SplitList(ti->ti_ii->interp, result, &argcPtr, &argvPtr);
+	if (code != TCL_OK) {
+		argcPtr = 0;
+		send_ldap_result (conn, op, LDAP_UNWILLING_TO_PERFORM, NULL,
+			"internal backend error");
+		return -1;
+	}
+	for ( i = 0 ; i < argcPtr ; i++ ) {
+		line = argvPtr[i];
+		Debug( LDAP_DEBUG_ANY, "tcl search reading line (%s)\n",
+		    line, 0, 0 );
+		/* ignore lines beginning with DEBUG: */
+		if ( strncasecmp( line, "DEBUG:", 6 ) == 0 ) {
+			continue;
+		}
+		len = strlen( line ) + 1;
+		while ( bp + len - buf > bsize ) {
+			bsize += BUFSIZ;
+			buf = (char *) ch_realloc( buf, bsize );
+		}
+		sprintf( bp, "%s\n", line );
+		bp += len;
+
+		/* line marked the end of an entry or result */
+		if ( line[0] == '\0' ) {
+			if ( strncasecmp( buf, "RESULT", 6 ) == 0 ) {
+				break;
+			}
+			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 );
+			}
+
+			bp = buf;
+		}
+	}
+
+	(void) str2result( buf, &err, &matched, &info );
+
+	/* otherwise, front end will send this result */
+	if ( err != 0 || op->o_tag != LDAP_REQ_BIND ) {
+		send_ldap_result( conn, op, err, matched, info );
+	}
+
+	free( buf );
+	Tcl_Free( result );
+	Tcl_Free( (char *) argvPtr );
+	return( err );
+}
+
+char *tcl_clean_entry (Entry *e)
+{
+    char *entrystr, *mark1, *mark2, *buf, *bp, *dup;
+    int len, bsize;
+
+    pthread_mutex_lock( &entry2str_mutex );
+    entrystr = entry2str( e, &len, 0 );
+    pthread_mutex_unlock( &entry2str_mutex );
+
+    buf = (char *) ch_malloc( BUFSIZ );
+    buf[0] = '\0';
+    bsize = BUFSIZ;
+    bp = buf;
+    bp++[0] = ' ';
+
+    mark1 = entrystr;
+    do {
+		if (mark1[0] == '\n') {
+	    	mark1++;
+		}
+		dup = (char *) strdup(mark1);
+		if (dup[0] != '\0') {
+	    	if ((mark2 = (char *) strchr (dup, '\n')) != NULL) {
+				mark2[0] = '\0';
+	    	}
+	    	len = strlen( dup ) + 3;
+	    	while ( bp + len - buf > bsize ) {
+				bsize += BUFSIZ;
+				buf = (char *) ch_realloc( buf, bsize );
+	    	}
+	    	if (mark1[0] == '\0') {
+				sprintf(bp, "{} ");
+	    	} else {
+				sprintf(bp, "{%s} ", dup);
+	    	}
+	    	bp += len;
+	    	if (mark2 != NULL) {
+				mark2[0] = '\n';
+	    	}
+		}
+		free(dup);
+    } while ((mark1 = (char *) strchr (mark1, '\n')) != NULL);
+    return buf;
+}
+
+int tcl_ldap_debug (
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int argc,
+    char *argv[]
+)
+{
+    if (argv[1] != NULL) {
+		Debug(LDAP_DEBUG_ANY, "tcl_debug: %s\n", argv[1], 0, 0);
+    }
+    return TCL_OK;
+}

servers/slapd/backend.c

@@ -27,6 +27,9 @@
 #ifdef SLAPD_SHELL
 #include "back-shell/external.h"
 #endif
+#ifdef SLAPD_TCL
+#include "back-tcl/external.h"
+#endif
 
 static BackendInfo binfo[] = {
 #ifdef SLAPD_LDBM
@@ -43,6 +46,9 @@ static BackendInfo binfo[] = {
 #endif
 #ifdef SLAPD_SHELL
 	{"shell",	shell_back_initialize},
+#endif
+#ifdef SLAPD_TCL
+	{"tcl",		tcl_back_initialize},
 #endif
 	{NULL}
 };