389-ds-base/ldap/admin/src/scripts/DSUtil.pm.in

# BEGIN COPYRIGHT BLOCK
# This Program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; version 2 of the License.
# 
# This Program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along with
# this Program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA 02111-1307 USA.
# 
# In addition, as a special exception, Red Hat, Inc. gives You the additional
# right to link the code of this Program with code not covered under the GNU
# General Public License ("Non-GPL Code") and to distribute linked combinations
# including the two, subject to the limitations in this paragraph. Non-GPL Code
# permitted under this exception must only link to the code of this Program
# through those well defined interfaces identified in the file named EXCEPTION
# found in the source code files (the "Approved Interfaces"). The files of
# Non-GPL Code may instantiate templates or use macros or inline functions from
# the Approved Interfaces without causing the resulting work to be covered by
# the GNU General Public License. Only Red Hat, Inc. may make changes or
# additions to the list of Approved Interfaces. You must obey the GNU General
# Public License in all respects for all of the Program code and other code used
# in conjunction with the Program except the Non-GPL Code covered by this
# exception. If you modify this file, you may extend this exception to your
# version of the file, but you are not obligated to do so. If you do not wish to
# provide this exception without modification, you must delete this exception
# statement from your version and license this file solely under the GPL without
# exception. 
# 
# 
# Copyright (C) 2007 Red Hat, Inc.
# All rights reserved.
# END COPYRIGHT BLOCK
#

package DSUtil;

use Mozilla::LDAP::Conn;
use Mozilla::LDAP::Utils qw(normalizeDN);
use Mozilla::LDAP::API qw(:constant ldap_explode_dn ldap_err2string) ; # Direct access to C API
use Mozilla::LDAP::LDIF;

require Exporter;
@ISA       = qw(Exporter);
@EXPORT    = qw(portAvailable getAvailablePort isValidDN addSuffix getMappedEntries
                process_maptbl check_and_add_entry getMappedEntries addErr
                getHashedPassword debug createInfFromConfig shellEscape
                isValidServerID isValidUser isValidGroup makePaths getLogin getGroup
                remove_tree remove_pidfile setDebugLog checkHostname);
@EXPORT_OK = qw(portAvailable getAvailablePort isValidDN addSuffix getMappedEntries
                process_maptbl check_and_add_entry getMappedEntries addErr
                getHashedPassword debug createInfFromConfig shellEscape
                isValidServerID isValidUser isValidGroup makePaths getLogin getGroup
                remove_tree remove_pidfile setDebugLog checkHostname);

use strict;

use Socket;

use File::Temp qw(tempfile tempdir);
use File::Basename qw(dirname);
use File::Path qw(rmtree);

use Carp;

$DSUtil::debuglevel = 0;
$DSUtil::log = 0;

# use like this:
# debug(3, "message");
# this will only print "message" if $debuglevel is 3 or higher (-ddd on the command line)
sub debug {
    my ($level, @rest) = @_;
    if ($level <= $DSUtil::debuglevel) {
        print STDERR "+" x $level, @rest;
        if ($DSUtil::log) {
            $DSUtil::log->logDebug(@rest);
        }
    }
}

sub setDebugLog {
    $DSUtil::log = shift;
}

# return true if the given port number is available, false otherwise
sub portAvailable {
    my $port = shift;
    my $proto = getprotobyname('tcp');
    my $rc = socket(SOCK, PF_INET, SOCK_STREAM, $proto);
    if ($rc == 1) {
        setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, 1);
        $rc = bind(SOCK, sockaddr_in($port, INADDR_ANY));
    }
    close(SOCK);
    return $rc and ($rc == 1);
}

# returns a randomly assigned port number, or -1
# if not able to find an available port
sub getAvailablePort {
    my $MINPORT = 1024;
    my $MAXPORT = 65535;

    srand( time() ^ ($$ + ($$ << 15)) );
    while (1) {
        my $port = $MINPORT + int(rand($MAXPORT-$MINPORT));

        if (portAvailable($port)) {
            return $port;
        }
    }
}

sub isValidDN {
    my $dn = shift;
    return ($dn =~ /^[0-9a-zA-Z_-]+=.*$/);
}

sub isValidServerID {
    my $servid = shift;
    my $validchars = '#%:\w@_-';
    return $servid =~ /^[$validchars]+$/o;
}

# we want the name of the effective user id of this process e.g. if someone did
# an su root, we want getLogin to return "root" not the originating id (getlogin)
# in perl, $> is the effective numeric user id - we need to turn it into a string
# use confess here because if we cannot determine the user, something is really,
# really wrong and we need to abort immediately
sub getLogin {
    return (getpwuid($>))[0] || $ENV{USER} || confess "Error: could not determine the current user ID: $!";
}

# Look up the primary group name for the supplied user
sub getGroup {
    my $user = shift;
    my $gid = (getpwnam($user))[3] || confess "Error: could not determine the current group ID: $!"; 
    return (getgrgid($gid))[0] || confess "Error: could not determine the current group name: $!";
}

sub isValidUser {
    my $user = shift;
    # convert numeric uid to string
    my $strans = $user;
    if ($user =~ /^\d+$/) { # numeric - convert to string
        $strans = getpwuid $user;
        if (!$strans) {
            return ("dialog_ssuser_error", $user);
        }
    }
    if ($> != 0) { # if not root, the user must be our uid
        my $username = getLogin;
        if ($strans ne $username) {
            return ("dialog_ssuser_must_be_same", $username);
        }
    } else { # user is root - verify id
        my $nuid = getpwnam $strans;
        if (!defined($nuid)) {
            return ("dialog_ssuser_error", $user);
        }
        if (!$nuid) {
            debug(0, "Warning: using root as the server user id.  You are strongly encouraged to use a non-root user.\n");
        }
    }

    return ();
}

sub isValidGroup {
    my $group = shift;
    my $ngid;
    # convert numeric gid to string
    my $strans = $group;
    if ($group =~ /^\d+$/) { # numeric - convert to string
        $strans = (getgrgid($group))[0];
        if (!$strans) {
            return ("dialog_ssgroup_error", $group);
        }
    }
    # ensure the specified group is a defined group
    $ngid = getgrnam $strans;
    if (!defined($ngid)) {
        return ("dialog_ssgroup_error", $group);
    }
    
    return ();
}

# arguments
# - hostname - the hostname to look for
# - res - the Resource object to use to construct messages
# returns - the error message string, or "" upon success
sub checkHostname {
    my $hn = shift;
    my $res = shift;

    # see if hostname is an fqdn
    if ($hn !~ /\./) {
        if ($res) {
            return $res->getText('warning_hostname_not_fully_qualified', $hn);
        } else {
            return "Warning: hostname $hn is not a fully qualified host and domain name\n";
        }
    }

    # see if we can resolve the hostname
    my ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($hn);
    if (!$name) {
        if ($res) {
            return $res->getText('warning_no_such_hostname', $hn);
        } else {
            return "Warning: could not resolve hostname $hn\n";
        }
    }
    debug(1, "found for hostname $hn: name=$name\n");
    debug(1, "aliases=$aliases\n");
    debug(1, "addrtype=$addrtype\n");
    my $found = 0;
    my @hostip = ();
    # see if reverse resolution works
    foreach my $ii (@addrs) {
        my $hn2 = gethostbyaddr($ii, $addrtype);
        my $ip = join('.', unpack('C4', $ii));
        debug(1, "\thost=$hn2 ip=$ip\n");
        push @hostip, [$hn2, $ip];
        if (lc($hn) eq lc($hn2)) {
            $found = 1;
            last;
        }
    }
    if (!$found) {
        my $retstr = "";
        if ($res) {
            $retstr = $res->getText('warning_reverse_resolve', $hn, $hn);
        } else {
            $retstr = "Warning: Hostname $hn is valid, but none of the IP addresses\nresolve back to $hn\n";
        }
        for my $ii (@hostip) {
            if ($res) {
                $retstr .= $res->getText('warning_reverse_resolve_sub', $ii->[1], $ii->[0]);
            } else {
                $retstr .= "\taddress $ii->[1] resolves to host $ii->[0]\n";
            }
        }
        return $retstr;
    }

    debug(1, "hostname $hn resolves correctly\n");
    return '';
}

# delete the subtree starting from the passed entry
sub delete_all
{
    my ($conn, $bentry) = @_;
    my $sentry = $conn->search($bentry->{dn},
                               "subtree", "(objectclass=*)", 0, ("dn"));
    my @mystack = ();
    while ($sentry) {
        push @mystack, $sentry->getDN();
        $sentry = $conn->nextEntry();
    }
    # reverse order
    my $dn = pop @mystack;
    while ($dn) {
        $conn->delete($dn);
        my $rc = $conn->getErrorCode();
        if ( $rc != 0 ) {
            debug(1, "ERROR: unable to delete entry $dn, error code: $rc:" . $conn->getErrorString() . "\n");
            return 1;
        }
        $dn = pop @mystack;
    }
    return 0;
}

# if the entry does not exist on the server, add the entry.
# otherwise, do nothing
# you can use this as the callback to getMappedEntries, so
# that for each entry in the ldif file being processed, you
# can call this subroutine to add or update the entry
# use like this:
# getMappedEntries($mapper, \@ldiffiles, \&check_and_add_entry,
#                  [$conn, $fresh, $verbose]);
# where $conn is a perldap Conn
# $fresh if true will update the entry if it exists
# $verbose prints out more info
sub check_and_add_entry
{
    my ($context, $aentry, $errs) = @_;
    my $conn = $context->[0];
    my $fresh = $context->[1];
    my $verbose = $context->[2];
    my @ctypes = $aentry->getValues("changetype");
    my $sentry = $conn->search($aentry->{dn}, "base", "(objectclass=*)", 0, ("*", "aci"));
    if ($sentry) {
        debug(3, "check_and_add_entry: Found entry " . $sentry->getDN() . "\n");
        if (! @ctypes) { # entry exists, and this is not a modify op
            debug(3, "check_and_add_entry: skipping entry " . $sentry->getDN() . "\n");
            return 1; # ignore - return success
        }
    } else {
        debug(3, "check_and_add_entry: Entry not found " . $aentry->{dn} .
              " error " . $conn->getErrorString() . "\n");
        if (@ctypes) { # uh oh - attempt to del/mod an entry that doesn't exist
            debug(3, "check_and_add_entry: attepting to @ctypes the entry " . $aentry->{dn} .
                  " that does not exist\n");
            return 1; # ignore - return success
        }
    }
    do
    {
        my @addtypes; # list of attr types for mod add
        my @reptypes; # list of attr types for mod replace
        my @deltypes; # list of attr types for mod delete
        my $OP_NONE = 0;
        my $OP_ADD = 1;
        my $OP_MOD = 2;
        my $OP_DEL = 3;
        # $op stores either of the above $OP_ values
        my $op = $OP_NONE;
        if ( 0 > $#ctypes )    # aentry: complete entry
        {
            $op = $OP_ADD; # just add the entry
        }
        else    # aentry: modify format
        {
            if ( $sentry )
            {
                if ( "delete" eq lc($ctypes[0]) )
                {
                    $op = $OP_DEL;
                }
                else
                {
                    @addtypes = $aentry->getValues("add");
                    @reptypes = $aentry->getValues("replace");
                    @deltypes = $aentry->getValues("delete");
                    $op = $OP_MOD;
                }
            }
            else
            {
                $op = $OP_NONE;
            }
        }

        if ( $OP_ADD == $op )
        {
            $conn->add($aentry);
            my $rc = $conn->getErrorCode();
            if ( $rc != 0 )
            {
                my $string = $conn->getErrorString();
                push @{$errs}, 'error_adding_entry', $aentry->{dn}, $string;
                debug(1, "ERROR: adding an entry $aentry->{dn} failed, error: $string\n");
                $aentry->printLDIF();
                $conn->close();
                return 0;
            }
            debug(1, "Entry $aentry->{dn} is added\n");
        }
        elsif ( $OP_DEL == $op )
        {
            my $rc = delete_all($conn, $sentry);
            if ( 0 != $rc )
            {
                push @{$errs}, 'error_deleteall_entries', $sentry->{dn}, $conn->getErrorString();
                debug(1, "Error deleting $sentry->{dn}\n");
                return 0;
            }
            debug(1, "Entry $aentry->{dn} is deleted\n");
        }
        elsif ( 0 < $op )    # modify op
        {
            my $attr;
            my @errsToIgnore;
            if (@addtypes) {
                push @errsToIgnore, LDAP_TYPE_OR_VALUE_EXISTS;
            }                
            foreach $attr ( @addtypes )
            {
                foreach my $val ($aentry->getValues($attr))
                {
                    debug(3, "Adding attr=$attr value=$val to entry $aentry->{dn}\n");
                    $sentry->addValue( $attr, $val );
                }
            }
            foreach $attr ( @reptypes )
            {
                my @vals = $aentry->getValues($attr);
                debug(3, "Replacing attr=$attr values=" . $aentry->getValues($attr) . " to entry $aentry->{dn}\n");
                $sentry->setValues($attr, @vals);
            }
            if (@deltypes) {
                push @errsToIgnore, LDAP_NO_SUCH_ATTRIBUTE;
            }
            foreach $attr ( @deltypes )
            {
                # removeValue takes a single value only
                if (!$aentry->size($attr))
                {
                    debug(3, "Deleting attr=$attr from entry $aentry->{dn}\n");
                    $sentry->remove($attr); # just delete the attribute
                }
                else
                {
                    debug(3, "Deleting attr=$attr values=" . $aentry->getValues($attr) . " from entry $aentry->{dn}\n");
                    foreach my $val ($aentry->getValues($attr))
                    {
                        $sentry->removeValue($attr, $val);
                    }
                }
            }
            $conn->update($sentry);
            my $rc = $conn->getErrorCode();
            if ( $rc != 0 )
            {
                my $string = $conn->getErrorString();
                debug(1, "ERROR: updating an entry $sentry->{dn} failed, error: $string\n");
                if (grep /^$rc$/, @errsToIgnore) {
                    debug(1, "Ignoring error $rc returned by adding @addtypes deleting @deltypes\n");
                } else {
                    push @{$errs}, 'error_updating_entry', $sentry->{dn}, $string;
                    $aentry->printLDIF();
                    $conn->close();
                    return 0;
                }
            }
        }
        if ( $sentry )
        {
            $sentry = $conn->nextEntry();    # supposed to have no more entries
        }
    } until ( !$sentry );
out:
    return 1;
}

# the default callback used with getMappedEntries
# just adds the given entry to the given list
sub cbaddent {
    my $list = shift;
    my $ent = shift;
    push @{$list}, $ent;
    return 1;
}

# given a mapper and a list of LDIF files, produce a list of
# perldap Entry objects which have had their tokens subst-ed
# with values from the mapper
# An optional callback can be supplied.  Each entry will be
# given to this callback.  The callback should return a list
# of localizable errors.  If no callback is supplied, the
# entries will be returned in a list.
# Arguments:
#  mapper - a hash ref - the keys are the tokens to replace
#           and the values are the replacements
#  ldiffiles - an array ref - the list of LDIF files to
#           operate on
#  errs -   an array ref - this is filled in with the
#           errors encountered in processing - this is
#           suitable for passing to setup->msg or
#           Resource->getText
#  callback (optional) - a code ref - a ref to a subroutine
#           that will be called with each entry - see below
#  context (optional) - this will be passed as the first
#           argument to your given callback - see below
# Callback:
#  The callback sub will be called for each entry after
#  the entry has been converted.  The callback will be
#  called with the given context as the first argument
#  and the Mozilla::LDAP::Entry as the second argument,
#  and an errs array ref as the third argument.  The
#  callback should return true to continue processing,
#  or false if a fatal error was encountered that should
#  abort processing of any further.
# Errors:
#  This function should return an array of errors in the
#  format described below, for use with Resource::getText()
#  or Setup::msg()
# Return:
#  The return value is a list of entries.
# Example usage:
#  sub handle_entries {
#    my $context = shift;
#    my $entry = shift;
#    my $errs = shift;
#    .... do something with entry ....
#    .... if $context is Mozilla::LDAP::Conn, $conn->add($entry); ...
#    .... report errors ....
#    if ($fatalerror) {
#      push @{$errs}, 'error_token', arg1, arg2, ...;
#      return 0;
#    } else {
#      return 1;
#    }
#  }
#  $mapper = {foo => 'bar', baz => 'biff'};
#  @ldiffiles = ('foo.ldif', 'bar.ldif', ..., 'biff.ldif');
#  $conn = new Mozilla::LDAP::Conn(...);
#  my @errs;
#  @entries = getMappedEntries($mapper, \@ldiffiles, \@errs, \&handle_entries, $conn);
#  Note that this will return 0 entries since a callback was used.
#  The simpler example is this:
#  @entries = getMappedEntries($mapper, \@ldiffiles, \@errs);
#  
sub getMappedEntries {
    my $mapper = shift;
    my $ldiffiles = shift;
    my $errs = shift;
    my $callback = shift || \&cbaddent; # default - just add entry to @entries
    my @entries = ();
    my $context = shift || \@entries;
    my $error;

    if (!ref($ldiffiles)) {
        $ldiffiles = [ $ldiffiles ];
    }

    foreach my $ldiffile (@{$ldiffiles}) {
        if (!open(MYLDIF, "< $ldiffile")) {
            push @{$errs}, "error_opening_ldiftmpl", $ldiffile, $!;
            return 0;
        }
        my $in = new Mozilla::LDAP::LDIF(*MYLDIF);
        debug(1, "Processing $ldiffile ...\n");
        ENTRY: while (my $entry = Mozilla::LDAP::LDIF::readOneEntry($in)) {
            # first, fix the DN
            my $dn = $entry->getDN();
            my $origdn = $dn;
            while ( $dn =~ /%([\w_-]+)%/ ) {
                if (exists($mapper->{$1})) {
                    $dn =~ s{%([\w_-]+)%}{$mapper->{$1}}ge;
                } else {
                    push @{$errs}, 'error_mapping_token_ldiftmpl', $dn, $ldiffile, $1;
                    $error = 1;
                    last ENTRY;
                }
            }
            $entry->setDN($dn);
            # next, fix all of the values in all of the attributes
            foreach my $attr (keys %{$entry}) {
                my @newvalues = ();
                foreach my $value ($entry->getValues($attr)) {
                    # Need to repeat to handle nested subst
                    my $origvalue = $value;
                    while ( $value =~ /%([\w_-]+)%/ ) {
                        if (exists($mapper->{$1})) {
                            $value =~ s{%([\w_-]+)%}{$mapper->{$1}}ge;
                        } else {
                            push @{$errs}, 'error_mapping_token_ldiftmpl', $dn, $ldiffile, $1;
                            debug(1, "ERROR: \"$origvalue\" mapped to \"$value\".\n");
                            $error = 1;
                            last ENTRY;
                        }
                    }
                    push @newvalues, $value;
                }
                $entry->setValues( $attr, @newvalues );
            }

            if (!&{$callback}($context, $entry, $errs)) {
                debug(1, "ERROR: There was an error processing entry ". $entry->getDN(). "\n");
                debug(1, "Cannot continue processing entries.\n");
                $error = 1;
                last ENTRY;
            }                

        }
        close(MYLDIF);
        last if ($error); # do not process any more ldiffiles if an error occurred
    }

    return @entries;
}

# you should only use this function if you know for sure
# that the suffix and backend do not already exist
# use addSuffix instead
sub newSuffixAndBackend {
    my $context = shift;
    my $suffix = shift;
    my $bename = shift;
    my $nsuffix = normalizeDN($suffix);
    my @errs;

    my $dn = "cn=$bename, cn=ldbm database, cn=plugins, cn=config";
    my $entry = new Mozilla::LDAP::Entry();
    $entry->setDN($dn);
    $entry->setValues('objectclass', 'top', 'extensibleObject', 'nsBackendInstance');
    $entry->setValues('cn', $bename);
    $entry->setValues('nsslapd-suffix', $nsuffix);
    $context->add($entry);
    my $rc = $context->getErrorCode();
    if ($rc) {
        return ('error_creating_suffix_backend', $suffix, $bename, $context->getErrorString());
    }

    $entry = new Mozilla::LDAP::Entry();
    $dn = "cn=\"$nsuffix\", cn=mapping tree, cn=config";
    $entry->setDN($dn);
    $entry->setValues('objectclass', 'top', 'extensibleObject', 'nsMappingTree');
    $entry->setValues('cn', "\"$nsuffix\"");
    $entry->setValues('nsslapd-state', 'backend');
    $entry->setValues('nsslapd-backend', $bename);
    $context->add($entry);
    $rc = $context->getErrorCode();
    if ($rc) {
        return ('error_creating_suffix', $suffix, $context->getErrorString());
    }

    return ();
}

sub findbecb {
    my $entry = shift;
    my $attrs = shift;
    return $entry->hasValue('objectclass', $attrs->[0], 1) &&
        $entry->hasValue('cn', $attrs->[1], 1);
}

sub findBackend {
    my $context = shift;
    my $bename = shift;
    my $ent;
    if (ref($context) eq 'Mozilla::LDAP::Conn') {
        $ent = $context->search("cn=ldbm database,cn=plugins,cn=config", "one",
                                "(&(objectclass=nsBackendInstance)(cn=$bename)")
    } else {
        $ent = $context->search("cn=ldbm database,cn=plugins,cn=config", "one",
                                \&findbecb, ['nsBackendInstance', $bename])
    }
}

sub findsuffixcb {
    my $entry = shift;
    my $attrs = shift;
    return $entry->hasValue('cn', $attrs->[0], 1) ||
        $entry->hasValue('cn', $attrs->[1], 1);
}

sub findSuffix {
    my $context = shift;
    my $suffix = shift;
    my $nsuffix = normalizeDN($suffix);
    my $ent;
    if (ref($context) eq 'Mozilla::LDAP::Conn') {
        $ent = $context->search("cn=mapping tree,cn=config", "one",
                                "(|(cn=\"$suffix\")(cn=\"$nsuffix\"))");
    } else {
        $ent = $context->search("cn=mapping tree,cn=config", "one",
                                \&findsuffixcb, ["\"$suffix\"", "\"$nsuffix\""])
    }
}

sub getUniqueBackendName {
    my $context = shift;
    my $bename = "backend";
    my $index = 0;
    my $ent = findBackend($context, ($bename . $index));
    while ($ent) {
        ++$index;
        $ent = findBackend($context, ($bename . $index));
    }

    return $bename.$index;
}

sub addSuffix {
    my $context = shift; # Conn
    my $suffix = shift;
    my $bename = shift; # optional
    my $ent;

    if ($bename && ($ent = findBackend($context, $bename))) {
        return ('backend_already_exists', $bename, $ent->getDN());
    }

    if ($ent = findSuffix($context, $suffix)) {
        return ('suffix_already_exists', $suffix, $ent->getDN());
    }

    if (!$bename) {
        $bename = getUniqueBackendName($context);
    }

    my @errs = newSuffixAndBackend($context, $suffix, $bename);

    return @errs;
}

# process map table
# [map table sample]
# fqdn =    FullMachineName
# hostname =    `use Sys::Hostname; $returnvalue = hostname();`
# ds_console_jar ="%normbrand%-ds-%ds_version%.jar"
#
# * If the right-hand value is in ` (backquote), the value is eval'ed by perl.
#   The output should be stored in $returnvalue to pass to the internal hash.
# * If the right-hand value is in " (doublequote), the value is passed as is.
# * If the right-hand value is not in any quote, the value should be found
#   in either of the setup inf file (static) or the install inf file (dynamic).
# * Variables surrounded by @ (e.g., @admin_confdir@) are replaced with the 
#   system path at the compile time.
# * The right-hand value can contain variables surrounded by % (e.g., %asid%)
#   which refers the right-hand value (key) of this map file.
# The %token% tokens are replaced in getMappedEntries
sub process_maptbl
{
    my ($mapper, $errs, @infdata) = @_;
    my @deferredkeys = ();

    if (defined($mapper->{""})) {
        $mapper = $mapper->{""}; # side effect of Inf with no sections
    }

    KEY: foreach my $key (keys %{$mapper})
    {
        my $value = $mapper->{$key};
        if ($value =~ /^\"/)
        {
            $value =~ tr/\"//d; # value is a regular double quoted string - remove quotes
            $mapper->{$key} = $value;
        }
        elsif ($value =~ /^\`/)
        {
            push @deferredkeys, $key; # process these last
        }
        else
        {
            # get the value from one of the Inf passed in
            # they $value could be pure Key or Key:"default_value"
            my ($key_value, $default_value) = split(/:/, $value, 2);
            my $infsection;
            foreach my $thisinf (@infdata)
            {
                foreach my $section0 (keys %{$thisinf})
                {
                    $infsection = $thisinf->{$section0};
                    next if (!ref($infsection));
                    if (defined($infsection->{$key_value}))
                    {
                        $mapper->{$key} = $infsection->{$key_value};
                        next KEY;
                    }
                }
            }
            if (!defined($infsection->{$value}))
            {
                if ($default_value ne "")
                {
                    $default_value =~ tr/\"//d; # default_value is a regular double quoted string - remove quotes
                    $mapper->{$key} = $default_value;
                }
                else
                {
                    push @{$errs}, ['no_mapvalue_for_key', $value, $key];
                    return {};
                }
            }
        }
    }

    # we have to process the perl expressions to eval last, because those
    # expressions may use mappings defined elsewhere in the file, and we are not
    # guaranteed of the order in which hash keys are enumerated
    foreach my $key (@deferredkeys) {
        my $value = $mapper->{$key};
        $value =~ tr/\`//d; # value is a perl expression to eval
        my $returnvalue; # set in eval expression
        eval $value;
        $mapper->{$key} = $returnvalue; # perl expression sets $returnvalue
    }

    return $mapper;
}

# given a string, escape the characters in the string
# so that it can be safely passed to the shell via
# the system() call or `` backticks
sub shellEscape {
    my $val = shift;
    # first, escape the double quotes and slashes
    $val =~ s/([\\"])/\\$1/g; # " font lock fun
    # next, escape the rest of the special chars
    my $special = '!$\' @#%^&*()|[\]{};:<>?/`';
    $val =~ s/([$special])/\\$1/g;

    return $val;
}

# given a string, escape the special characters in the string.
# the characters are defined in RFC 4514.
# special = escaped / SPACE / SHARP / EQUALS
# escaped = DQUOTE / PLUS / COMMA / SEMI / LANGLE / RANGLE
# hex string "# HEX HEX" is unlikely appearing in the installation.
# thus, it won't be supported for now.
my %dnspecial = (
    '"'  => '\\"',  # '\\22'
    '\+' => '\\+',  # '\\2B'
    ','  => '\\,',  # '\\2C'
    ';'  => '\\;',  # '\\3B'
    '<'  => '\\<',  # '\\3C'
    '>'  => '\\>',  # '\\3E'
    '='  => '\\='   # '\\3D'
);

sub dnEscape {
    my $val = shift;
    # first, remove spaces surrounding ',' and leading/trailing spaces
    $val =~ s/^\s*//;
    $val =~ s/\s*$//;
    $val =~ s/\s*,\s*/,/g;
    # next, replace the special characters
    foreach my $idx (keys %dnspecial) {
        $val =~ s/$idx/$dnspecial{$idx}/g;
    }
    $val =~ s/\s*,\s*/,/g;

    return $val;
}

sub getHashedPassword {
    my $pwd = shift;
    my $alg = shift;

    if ($pwd =~ /^\{\w+\}.+/) {
        return $pwd; # already hashed
    }

    my $cmd = "@bindir@/pwdhash";
    if ($alg) {
        $cmd .= " -s $alg";
    }
    $cmd .= " -- " . shellEscape($pwd);
    my $hashedpwd = `$cmd`;
    chomp($hashedpwd);

    return $hashedpwd;
}

# this creates an Inf suitable for passing to createDSInstance
# except that it has a bogus suffix
sub createInfFromConfig {
    my $configdir = shift;
    my $inst = shift;
    my $errs = shift;
    my $fname = "$configdir/dse.ldif";
    my $id;
    ($id = $inst) =~ s/^slapd-//;
    if (! -f $fname || ! -r $fname) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        return 0;
    }
    my $conn = new FileConn($fname, 1);
    if (!$conn) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        return 0;
    }

    my $ent = $conn->search("cn=config", "base", "(objectclass=*)");
    if (!$ent) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        $conn->close();
        return 0;
    }

    my $inf = new Inf();
    $inf->{General}->{FullMachineName} = $ent->getValues('nsslapd-localhost');
    $inf->{General}->{SuiteSpotUserID} = $ent->getValues('nsslapd-localuser');
    $inf->{slapd}->{RootDN} = $ent->getValues('nsslapd-rootdn');
    $inf->{slapd}->{RootDNPwd} = $ent->getValues('nsslapd-rootpw');
    $inf->{slapd}->{ServerPort} = $ent->getValues('nsslapd-port');
    $inf->{slapd}->{ServerIdentifier} = $id;

    my $suffix;
    $ent = $conn->search("cn=ldbm database,cn=plugins,cn=config",
                         "one", "(objectclass=*)");
    if (!$ent) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        $conn->close();
        return 0;
    }
    # use the userRoot suffix if available
    while ($ent) {
        $suffix = $ent->getValues('nsslapd-suffix');
        last if ($ent->hasValue('cn', 'userRoot', 1));
        $ent = $conn->nextEntry();
    }

    # we also need the instance dir
    $ent = $conn->search("cn=config", "base", "(objectclass=*)");
    if (!$ent) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        $conn->close();
        return 0;
    }
    my $inst_dir = $ent->getValue('nsslapd-instancedir');

    $conn->close();

    if ($inst_dir) {
        $inf->{slapd}->{inst_dir} = $inst_dir;
    }
    $inf->{slapd}->{Suffix} = $suffix;

    return $inf;
}

# like File::Path mkpath, except we can set the owner and perm
# of each new path and parent path created
sub makePaths {
    my ($path, $mode, $user, $group) = @_;
    my $uid = getpwnam $user;
    my $gid = -1; # default to leave it alone
    my $mode_string = "";

    if ($group) {
        $gid = getgrnam $group;
    }
    my @dirnames = ($path);
    my $parent = $path;
    for ($parent = dirname($parent);
         $parent and ($parent ne "/");
         $parent = dirname($parent)) {
        unshift @dirnames, $parent;
    }
    for my $dir (@dirnames) {
        next if (-d $dir);
        $! = 0; # clear
        mkdir $dir, $mode;
        if ($!) {
            return ('error_creating_directory', $dir, $!);
        }
        chown $uid, $gid, $dir;
        if ($!) {
            return ('error_chowning_directory', $dir, $!);
        }
        chmod $mode, $dir;
        $mode_string = sprintf "%lo", $mode;
        debug(1, "makePaths: created directory $dir mode $mode_string user $user group $group\n");
        debug(2, "\t" . `ls -ld $dir`);
    }

    return ();
}

# remove_tree($centry, $key, $instname, [$isparent, [$dontremove]])
#     $centry: entry to look for the path to be removed
#     $key: key to look for the path in the entry
#     $instname: instance name "slapd-<ID>" to check the path
#     $isparent: specify 1 to remove from the parent dir
#     $dontremove: pattern not to be removed (e.g., ".db$")
sub remove_tree
{
    my $centry = shift;
    my $key = shift;
    my $instname = shift;
    my $isparent = shift;
    my $dontremove = shift;
    my @errs = (); # a list of array refs - each array ref is suitable for passing to Resource::getText

    foreach my $path ( @{$centry->{$key}} )
    {
        my $rmdir = "";
        my $rc = 0;
        if ( 1 == $isparent )
        {
            $rmdir = dirname($path);
        }
        else
        {
            $rmdir = $path;
        }
        if ( -d $rmdir && $rmdir =~ /$instname/ )
        {
            if ( "" eq "$dontremove" )
            {
                $rc = rmtree($rmdir);
                if ( 0 == $rc )
                {
                    push @errs, [ 'error_removing_path', $rmdir, $! ];
                    debug(1, "Warning: $rmdir was not removed.  Error: $!\n");
                }
            }
            else
            {
                # Skip the dontremove files
                $rc = opendir(DIR, $rmdir);
                if ($rc)
                {
                    while (defined(my $file = readdir(DIR)))
                    {
                        next if ( "$file" =~ /$dontremove/ );
                        next if ( "$file" eq "." );
                        next if ( "$file" eq ".." );
                        my $rmfile = $rmdir . "/" . $file;
                        my $rc0 = rmtree($rmfile);
                        if ( 0 == $rc0 )
                        {
                            push @errs, [ 'error_removing_path', $rmfile, $! ];
                            debug(1, "Warning: $rmfile was not removed.  Error: $!\n");
                        }
                    }
                    closedir(DIR);
                }
                my $newrmdir = $rmdir . ".removed";
                my $rc1 = 1;
                if ( -d $newrmdir )
                {
                    $rc1 = rmtree($newrmdir);
                    if ( 0 == $rc1 )
                    {
                        push @errs, [ 'error_removing_path', $newrmdir, $! ];
                        debug(1, "Warning: $newrmdir was not removed.  Error: $!\n");
                    }
                }
                if ( 0 < $rc1 )
                {
                    rename($rmdir, $newrmdir);
                }
            }
        }
    }

    return @errs; # a list of array refs - if (!@errs) then success
}

sub remove_pidfile
{
    my ($type, $serv_id, $instdir, $instname, $run_dir, $product_name) = @_;
    my $pidfile;

    # Construct the pidfile name as follows:
    #     PIDFILE=$RUN_DIR/$PRODUCT_NAME-$SERV_ID.pid
    #     STARTPIDFILE=$RUN_DIR/$PRODUCT_NAME-$SERV_ID.startpid
    if ($type eq "PIDFILE") {
        $pidfile = $run_dir . "/" . $product_name . "-" . $serv_id . ".pid";
    } elsif ($type eq "STARTPIDFILE") {
        $pidfile = $run_dir . "/" . $product_name . "-" . $serv_id . ".startpid";
    }

    if ( -e $pidfile && $pidfile =~ /$instname/ )
    {
        unlink($pidfile);
    }
}

1;

# emacs settings
# Local Variables:
# mode:perl
# indent-tabs-mode: nil
# tab-width: 4
# End: