#!/usr/bin/perl
#
# Brent Baccala <baccala@freesoft.org>     26 Sep 2000
#
# This script is designed for use with openldap's shell backend.
# In the slapd.conf file, it should be configured as the
# external program for the operations "search", "add", "modify",
# "modrdn", and "delete".  It reads the requests from slapd on STDIN and
# forwards them to another LDAP server, using various openldap client
# programs.
#
# If you know nothing about LDAP, suffice it to say that we're dealing
# with a directory of objects, each identified by a unique
# Distinguished Name (DN) and each containing a list of attributes,
# each attribute possibly missing, non-unique or duplicated.  One of
# the most important attributes is "objectclass", which is an ASCII
# string defining the type of object.  The server uses a schema
# definition to define which attributes are possible and/or required
# for each objectclass.
#
# It has some slight drawbacks, including an inability to handle multivalued
# attributes in search results (it only returns a single value for each).



# The LDAP URL to forward the requests to

$URL = "ldap://localhost:2345/";

# Standard arguments to pass to all the child processes.
# If you want to specify authentication, this is the place to do it.

@stdargs = ( "-H", $URL );

# Trace file to see what this script is doing.
# Comment the line out if you don't want a trace file.

# $tracefile = "perl.out";

# The client programs
# $clientpath can be left empty if the programs are in the path

$clientpath = "clients/tools/";

$ldapadd = $clientpath . "ldapadd";
$ldapmodify = $clientpath . "ldapmodify";
$ldapdelete = $clientpath . "ldapdelete";
$ldapmodrdn = $clientpath . "ldapmodrdn";
$ldapsearch = $clientpath . "ldapsearch";

# Regular expression that matches attributes and pseudo-attributes that
# should be filtered out from add/modify requests, either because they
# aren't really attributes (msgid, suffix), or because they are generated
# by the server and would cause it to barf if set explicitly.

$ignores = "((msgid)|(suffix)|(creatorsName)|(createTimestamp)|(modifiersName)|(modifyTimestamp))";

# Regular expression that matches the possible changetypes that can
# appear in a change request.  See slapd.replog(5)

$changetypes = "((add)|(replace)|(delete)|(modrdn))";

# In a search request, the server feeds us the scope and dereference fields
# in the numeric form used by the protocol.  ldapsearch(1) takes these
# fields as arguments in symbolic form.  These arrays convert between
# the two representations.

@scopes = ("base", "one", "sub");
@derefs = ("never", "always", "search", "find");




# The script proper.  Initialize the result code to 1 (operationsError),
# so we just fall through on any problems.  The first line of input
# should be an operation code.  Call the right client program and pass
# it any fields.  The openldap clients are very nice about returning
# LDAP response codes as their exit status if they fail.  We take
# advantage of this to set $result.

$result = 1;

$operation = <>;
chop($operation);

if (defined $tracefile) {
    open(TRACEFILE, ">>$tracefile");
    print TRACEFILE "$operation\n";
}

if ($operation eq "ADD") {

    while (<>) {
	next if ( /^$ignores:/o );
	if (/^(.*): (.*)$/) {
	    $Attributes{$1} = $2;
	}
	print TRACEFILE if defined $tracefile;
    }

    $dn = $Attributes{dn};
    delete $Attributes{dn};

    my $pid = open(PROGRAM, "|-");

    if (defined $pid) {

	if (! $pid) {  # child

	    exec ($ldapadd, @stdargs);
	    exit 1;

	} else { # parent

	    print PROGRAM "dn: $dn\n";
	    foreach $attr (keys %$Attributes) {
		print PROGRAM "$attr: $$Attributes{$attr}\n";
	    }

	    close(PROGRAM);
	    $result = ($? >> 8);

	}
    }

} elsif ($operation eq "MODIFY") {

    my $pid = open(PROGRAM, "|-");

    if (defined $pid) {

	if (! $pid) {  # child

	    exec ($ldapmodify, @stdargs);
	    exit 1;

	} else { # parent

	    # We now read a series of change blocks from the server.
	    # We pass them on to the child, with two modifications.
	    # Some of the change blocks get droppped completely (those
	    # matching the $ignores regex).  We also insert a "-" line
	    # after each change block, because this is what the client
	    # expects, but not what the server sends.

	    my $changeblockseen = 0;

	    while (<>) {

		next if (/^-$/);
		next if (/^$ignores:/o || /^$changetypes: $ignores$/);

		if (/^$changetypes:/) {
		    print PROGRAM "-\n" if ($changeblockseen);
		    $changeblockseen=1;
		}

		print PROGRAM;
		print TRACEFILE if defined $tracefile;
	    }
	    print PROGRAM "-\n" if ($changeblockseen);
	    close(PROGRAM);
	    $result = ($? >> 8);

	}
    }


} elsif ($operation eq "DELETE") {

    # This deletes an entire object, identified by its DN.  If you only
    # want to delete an attribute within an object, use MODIFY with
    # a changetype of "delete" on the attribute in question.

    while (<>) {
	if (/^dn: (.*)$/) {
	    $dn = $1;
	}
    }

    if (defined($dn)) {
	print TRACEFILE "$dn\n" if defined $tracefile;
	system ($ldapdelete, @stdargs, $dn);
	$result = ($? >> 8);
    }

} elsif ($operation eq "MODRDN") {

    while (<>) {
	if (/^dn: (.*)$/) {
	    $dn = $1;
	} elsif (/^newrdn: (.*)$/) {
	    $rdn = $1;
	} elsif (/^deleteoldrdn: (.*)$/) {
	    $deleteoldrdn = $1;
	}
    }

    if (defined($dn) and defined($rdn)) {
	print TRACEFILE "$dn -> $rdn\n" if defined $tracefile;
	system ($ldapmodrdn, @stdargs,
		$deleteoldrdn ? "-r" : (),
		$dn, $rdn);
	$result = ($? >> 8);
    }

} elsif ($operation eq "SEARCH") {

    while (<>) {

	print TRACEFILE if defined $tracefile;

	if (/^base: (.*)$/) {
	    $base = $1;
	} elsif (/^scope: (.*)$/) {
	    $scope = $scopes[$1];
	} elsif (/^deref: (.*)$/) {
	    $deref = $derefs[$1];
	} elsif (/^sizelimit: (.*)$/) {
	    $sizelimit = $1;
	} elsif (/^timelimit: (.*)$/) {
	    $timelimit = $1;
	} elsif (/^filter: (.*)$/) {
	    $filter = $1;
	} elsif (/^attrsonly: (.*)$/) {
	    $attrsonly = $1;
	} elsif (/^attrs: (.*)$/) {
	    if ($1 eq "all") {
		@attrs = ();
	    } else {
		@attrs = split / /, $1;
	    }
	}
    }

    my $pid = open(PROGRAM, "-|");

    if (defined $pid) {

	if (! $pid) {  # child

	    exec ($ldapsearch, @stdargs, "-LLL",
		  "-b", $base, "-s", $scope, "-a", $deref,
		  defined($timelimit) ? ("-l", $timelimit) : (),
		  defined($sizelimit) ? ("-z", $sizelimit) : (),
		  $attrsonly ? "-A" : (),
		  $filter, @attrs);
	    exit 1;

	} else { # parent

	    @DNs = ();

	    while (<PROGRAM>) {
		if (/^dn: (.*)$/) {
		    unshift @DNs, $1;
		} elsif (/^([^:]*): (.*)$/ and defined $DNs[0]) {
		    $Attributes{lc($1)} = 1;
		    if (not exists $AttributeValues{$DNs[0], lc($1)}) {
			$AttributeValues{$DNs[0], lc($1)} = [];
		    }
		    push @{$AttributeValues{$DNs[0], lc($1)}}, $2;
		}
		print TRACEFILE if defined $tracefile;
	    }
	    close(PROGRAM);
	    $result = ($? >> 8);

	    # At this point, @DNs contains a list (possibly empty) of
	    # the returned objects' DNs, and %AttributeValues is a hash
	    # containing their attributes, keyed on DN and attribute name.
	    # @attrs is the list of attributes originally requested.
	    # %Attributes is a hash containing 1 for each attribute seen.

	    foreach $dn (@DNs) {
		print "dn: $dn\n";
		foreach $attr (keys(%Attributes)) {
		    if (exists $AttributeValues{$dn, lc($attr)}) {
			foreach $value (@{$AttributeValues{$dn, lc($attr)}}) {
			    print "$attr: $value\n";
			}
		    }
		}
		print "\n";
	    }

	}
    }

}

done: print TRACEFILE "RESULT code $result\n\n" if defined $tracefile;

print "RESULT\n";
print "code: $result\n";