path: root/ldap/admin/src/scripts/Util.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 Util;

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
                getHashedPassword debug createInfFromConfig shellEscape
                isValidServerID isValidUser makePaths getLogin remove_tree remove_pidfile);
@EXPORT_OK = qw(portAvailable getAvailablePort isValidDN addSuffix getMappedEntries
                process_maptbl check_and_add_entry getMappedEntries
                getHashedPassword debug createInfFromConfig shellEscape
                isValidServerID isValidUser makePaths getLogin remove_tree remove_pidfile);

use strict;

use Socket;

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

use Carp;

$Util::debuglevel = 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 <= $Util::debuglevel) {
        print STDERR "+" x $level, @rest;
    }
}

# 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: $!";
}

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 ();
}

# 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;
}

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 ($outfh, $inffile) = tempfile(SUFFIX => '.inf');
    if (!$outfh || !$inffile) {
        push @{$errs}, "error_opening_tempinf", $fname, $!;
        if ($outfh) {
            close $outfh;
        }
        $conn->close();
        return 0;
    }
    print $outfh "[General]\n";
    print $outfh "FullMachineName = ", $ent->getValues('nsslapd-localhost'), "\n";
    print $outfh "SuiteSpotUserID = ", $ent->getValues('nsslapd-localuser'), "\n";
    print $outfh "[slapd]\n";
    print $outfh "RootDN = ", $ent->getValues('nsslapd-rootdn'), "\n";
    print $outfh "RootDNPwd = ", $ent->getValues('nsslapd-rootpw'), "\n";
    print $outfh "ServerPort = ", $ent->getValues('nsslapd-port'), "\n";
    print $outfh "ServerIdentifier = $id\n";

    my $suffix;
    $ent = $conn->search("cn=ldbm database,cn=plugins,cn=config",
                         "one", "(objectclass=*)");
    if (!$ent) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        close $outfh;
        $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, $!;
        close $outfh;
        $conn->close();
        return 0;
    }
    my $inst_dir = $ent->getValue('nsslapd-instancedir');

    $conn->close();

    if ($inst_dir) {
        print $outfh "inst_dir = $inst_dir\n";
    }
    print $outfh "Suffix = $suffix\n";
    close $outfh;

    my $inf = new Inf($inffile);

    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 (@dirnames) {
        next if (-d $_);
        $! = 0; # clear
        mkdir $_, $mode;
        if ($!) {
            return ('error_creating_directory', $_, $!);
        }
        chown $uid, $gid, $_;
        if ($!) {
            return ('error_chowning_directory', $_, $!);
        }
        chmod $mode, $_;
        $mode_string = sprintf "%lo", $mode;
        debug(1, "makePaths: created directory $_ mode $mode_string user $user group $group\n");
        debug(2, "\t" . `ls -ld $_`);
    }

    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, $instdir, $instname) = @_;
    my $serv_id;
    my $run_dir;
    my $product_name;
    my $pidfile;

    # Get the serv_id from the start-slapd script.
    unless(open(INFILE,"$instdir/start-slapd")) {
        print("Cannot open start-slapd file for reading "); return 0;
    }
    while(<INFILE>) {
        if (/start-dirsrv /g) {
            my @servline=split(/start-dirsrv /, );
            @servline=split(/\s+/, $servline[1]);
            $serv_id=$servline[0];
        }
    }
    close(INFILE);

    # Get the run_dir and product_name from the instance initconfig script.
    unless(open(INFILE,"@initconfigdir@/@package_name@-$serv_id")) {
        print("Couldn't open @initconfigdir@/@package_name@-$serv_id "); return 0;
    }
    while(<INFILE>) {
        if (/RUN_DIR=/g) {
            my @rundir_line=split(/RUN_DIR=+/, );
            @rundir_line=split(/;/, $rundir_line[1]);
            $run_dir = $rundir_line[0];
            chop($run_dir);
        } elsif (/PRODUCT_NAME=/g) {
            my @product_line=split(/PRODUCT_NAME=+/, );
            @product_line=split(/;/, $product_line[1]);
            $product_name = $product_line[0];
            chop($product_name);
        }
    }
    close(INFILE);

    # 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: