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

use strict;

use Socket;

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

$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) {
        $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
sub getLogin {
    return (getpwuid($>))[0] || $ENV{USER} || die "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;
}

my %ignorelist = (
    "nsslapd-directory", "nsslapd-directory",
    "nsslapd-require-index", "nsslapd-require-index",
    "nsslapd-readonly", "nsslapd-readonly",
    "modifytimestamp", "modifyTimestamp",
    "createtimestamp", "createTimestamp",
    "installationtimestamp", "installationTimestamp",
    "creatorsname", "creatorsName",
    "modifiersname", "modifiersName",
    "numsubordinates", "numSubordinates"
);

my %speciallist = (
    "uniquemember", 1,
    "aci", 1
);

# compare 2 entries
# return 0 if they match 100% (exception: %ignorelist).
# return 1 if they match except %speciallist.
# return -1 if they do not match.
sub comp_entries
{
    my ($e0, $e1) = @_;
    my $rc = 0;
    foreach my $akey ( keys %{$e0} )
    {
        next if ( $ignorelist{lc($akey)} );
        my $aval0 = $e0->{$akey};
        my $aval1 = $e1->{$akey};
        my $a0max = $#{$aval0};
        my $a1max = $#{$aval1};
        my $amin = $#{$aval0};
        if ( $a0max != $a1max )
        {
            if ( $speciallist{lc($akey)} )
            {
                $rc = 1;
                if ( $a0max < $a1max )
                {
                    $amin = $a0max;
                }
                else
                {
                    $amin = $a1max;
                }
            }
            else
            {
                $rc = -1;
                return $rc;
            }
        }
        my @sval0 = sort { $a cmp $b } @{$aval0};
        my @sval1 = sort { $a cmp $b } @{$aval1};
        for ( my $i = 0; $i <= $amin; $i++ )
        {
            my $isspecial = -1;
            if ( $sval0[$i] ne $sval1[$i] )
            {
                if ( 0 > $isspecial )
                {
                    $isspecial = $speciallist{lc($akey)};
                }
                if ( $isspecial )
                {
                    $rc = 1;
                }
                else
                {
                    $rc = -1;
                    return $rc;
                }
            }
        }
    }
    return $rc;
}

# 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");
    } else {
        debug(3, "check_and_add_entry: Entry not found " . $aentry->{dn} .
              " error " . $conn->getErrorString() . "\n");
    }
    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;

            my $rc = -1;
            if ( $sentry && !$fresh )
            {
                $rc = comp_entries( $sentry, $aentry );
            }
            if ( 0 == $rc && !$fresh )
            {
                # the identical entry exists on the configuration DS.
                # no need to add the entry.
                $op = $OP_NONE;
                goto out;
            }
            elsif ( (1 == $rc) && !$fresh )
            {
                $op = $OP_MOD;
                @addtypes = keys %{$aentry}; # add all attrs
            }
            elsif ( $sentry && $sentry->{dn} )
            {
                # $fresh || $rc == -1
                # an entry having the same DN exists, but the attributes do not
                # match.  remove the entry and the subtree underneath.
                debug(1, "Deleting an entry dn: $sentry->{dn} ...\n");
                $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;
                }
            }
        }
        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 )    # $sentry exists
        {
            my $attr;
            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);
            }
            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();
                push @{$errs}, 'error_updating_entry', $sentry->{dn}, $string;
                debug(1, "ERROR: updating an entry $sentry->{dn} failed, error: $string\n");
                $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;
}

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 .= " \'$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) {
        push @{$errs}, "error_opening_dseldif", $fname, $!;
        return 0;
    }
    my $conn = new FileConn($fname, 1);

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

    my ($outfh, $inffile) = tempfile(SUFFIX => '.inf');
    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();
    }
    $conn->close();

    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

    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', $_, $!);
        }
        debug(1, "makePaths: created directory $_ mode $mode user $user group $group\n");
    }

    return ();
}

1;

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