libcipux-storage-perl 3.4.0.2-6.1 / usr / share / perl5 / CipUX / Storage.pm

# +==========================================================================+
# || CipUX::Storage                                                         ||
# ||                                                                        ||
# || CipUX storage abstraction layer                                        ||
# ||                                                                        ||
# || Copyright (C) 2007 - 2009 by Christian Kuelker. All rights reserved!   ||
# ||                                                                        ||
# || License: GNU GPL version 2 or any later version.                       ||
# ||                                                                        ||
# +==========================================================================+
# ID:       $Id$
# Revision: $Revision$
# Head URL: $HeadURL$
# Date:     $Date$
# Source:   $Source$

package CipUX::Storage;

use 5.008001;
use strict;
use warnings;
use utf8;
use Carp;
use Class::Std;
use Data::Dumper;
use English qw( -no_match_vars);
use Log::Log4perl qw(:easy);
use Net::LDAP;
use Readonly;
use base qw(CipUX);

{    # BEGIN CLASS

    use version; our $VERSION = qv('3.4.0.2');
    use re 'taint';    # Keep tainted any data captured by parens
    delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};    # Make %ENV safe

    # +======================================================================+
    # || CONST                                                              ||
    # +======================================================================+
    Readonly::Scalar my $EMPTY_STRING => q{};

    # TODO: make the global configurable
    Readonly::Scalar my $MIN_OID_NUMBER =>
        10101;    ## no critic (RequireNumberSeparators)
     # +======================================================================+
     # || OBJECT                                                             ||
     # +======================================================================+
    my %storage_cfg : ATTR( :get<storage_cfg> );
    my %access_cfg : ATTR( :get<access_cfg> );

    # +======================================================================+
    # || GLOBAL                                                             ||
    # +======================================================================+
    my $schema = undef;    # contains LDAP schema if add_node
                           # exception messages

    # +======================================================================+
    # || CONSTRUCTOR                                                        ||
    # +======================================================================+
    sub BUILD {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $ident, $arg_r ) = @_;

        # add prefix for cfg, if needed
        my $pref
            = exists $arg_r->{pref}
            ? $self->l( $arg_r->{pref} )
            : $EMPTY_STRING;

        my $cache_dir
            = exists $arg_r->{cache_dir}
            ? $self->l( $arg_r->{cache_dir} )
            : $EMPTY_STRING;

        # +------------------------------------------------------------------+
        # | main
        my $cfg_hr = $self->cfg(
            { 'sub' => 'storage', pref => $pref, cache_dir => $cache_dir } );
        $storage_cfg{$ident} = $cfg_hr->{structure};

        my $access_cfg_hr = $self->cfg(
            { 'sub' => 'access', pref => $pref, cache_dir => $cache_dir } );
        $access_cfg{$ident} = $access_cfg_hr->{ldap};

        # +------------------------------------------------------------------+
        # | API
        return;
    }

    # +======================================================================+
    # || DESTRUCTOR                                                         ||
    # +======================================================================+
    sub DEMOLISH {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $ident ) = @_;

        # +------------------------------------------------------------------+
        # | main
        delete $storage_cfg{$ident};
        delete $access_cfg{$ident};
        undef $schema;

        # +------------------------------------------------------------------+
        # | API
        return;

    }

    # +======================================================================+
    # || open module features                                               ||
    # +======================================================================+

    # +======================================================================+
    # || get_value                                                          ||
    # +======================================================================+
    sub get_value {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $obj
            = ( exists $arg_r->{obj} and defined $arg_r->{obj} )
            ? $self->l( $arg_r->{obj} )
            : q{*};

        my $type
            = exists $arg_r->{type}
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        my $scope
            = exists $arg_r->{scope}
            ? $self->l( $arg_r->{scope} )
            : $self->perr('scope');    # one|all

        my $filter
            = exists $arg_r->{filter}
            ? $self->l( $arg_r->{filter} )
            : $EMPTY_STRING;

        my $attr_ar
            = exists $arg_r->{attr_ar} ? $self->a( $arg_r->{attr_ar} ) : [];

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> obj: ', $obj );
        $logger->debug( '> obj: ', { filter => \&Dumper, value => $obj } );
        $logger->debug( '> type: ',   $type );
        $logger->debug( '> scope: ',  $scope );
        $logger->debug( '> filter: ', $filter );
        $logger->debug( '> attr_ar: ',
            { filter => \&Dumper, value => $attr_ar } );

        # calc rel values
        my $ldap_hr = $self->_ldap_struct(
            {
                type   => $type,
                scope  => $scope,
                obj    => $obj,
                filter => $filter
            }
        );

        my $sattr_ar = [];
        push @{$sattr_ar}, @{$attr_ar};
        push @{$sattr_ar}, $ldap_hr->{dn_attr};    # add: uid|cn

        my $ldap = $self->_ldap_start();

        my $rslt = $ldap->search(
            base   => $ldap_hr->{search},
            deref  => 'always',
            attrs  => $sattr_ar,
            filter => $ldap_hr->{filter} . $filter
        );

        # if the search went wrong
        my $msg = 'Search failed! ';
        $msg .= " base [$ldap_hr->{search}] ";
        $msg .= " filter [$ldap_hr->{filter}] ";
        if ( $rslt->code ) {
            $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
        }

        $self->_ldap_end( { ldap => $ldap } );

        my %ret = ();

        foreach my $entry ( $rslt->entries ) {
            foreach my $attr ( $entry->attributes ) {
                push @{ $ret{ $entry->get_value( $ldap_hr->{dn_attr} ) }
                        {$attr} },
                    $entry->get_value($attr);
            }
        }

        $logger->debug( 'ret: ', { filter => \&Dumper, value => \%ret } );

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return \%ret;

    } ## end sub get_value

   # +=======================================================================+
   # || set_value                                                           ||
   # +=======================================================================+
    sub set_value {    ## no critic (ProhibitExcessComplexity)

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $obj
            = ( exists $arg_r->{obj} and defined $arg_r->{obj} )
            ? $self->l( $arg_r->{obj} )
            : q{*};

        # add|delete|replace
        my $changes
            = exists $arg_r->{changes}
            ? $self->l( $arg_r->{changes} )
            : $self->perr('changes');

        my $scope
            = exists $arg_r->{scope}
            ? $self->l( $arg_r->{scope} )
            : $self->perr('scope');    # one|all

        my $escope
            = exists $arg_r->{escope}
            ? $self->l( $arg_r->{escope} )
            : 'none';                  # one|all|none

        my $type
            = exists $arg_r->{type}
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        my $value
            = exists $arg_r->{value}
            ? $self->l( $arg_r->{value} )
            : $EMPTY_STRING;

        my $attr_ar
            = exists $arg_r->{attr_ar}
            ? $self->a( $arg_r->{attr_ar} )
            : $self->perr('attr_ar');

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> obj: ',     $obj );
        $logger->debug( '> changes: ', $changes );
        $logger->debug( '> scope: ',   $scope );
        $logger->debug( '> escope: ',  $escope );
        $logger->debug( '> type: ',    $type );
        $logger->debug( '> value: ',   $value );
        $logger->debug( '> attr_ar: ',
            { filter => \&Dumper, value => $attr_ar } );

        # calc rel values
        my $ldap_hr = $self->_ldap_struct(
            { type => $type, obj => $obj, scope => $scope } );

        my $ldap = $self->_ldap_start();

        # prepare all to-be-stored attribute => value pairs
        my $target_ar = [];
        if ( defined $value and $value ne $EMPTY_STRING ) {
            foreach my $attr ( @{$attr_ar} ) {

                #  [ $attribute => $value ]
                #  push( @{$target_ar}, { $attr => $value } );
                #  [ $attribute => $value ]
                if (    defined $value
                    and $value ne $EMPTY_STRING
                    and defined $attr
                    and $attr ne $EMPTY_STRING )
                {
                    push @{$target_ar}, $attr => $value;
                    $logger->debug( 'add attr: ',  $attr );
                    $logger->debug( 'add value: ', $value );
                }
                else {
                    my $msg = 'EXC: tried to add empty value or attr!';
                    $logger->debug($msg);
                }
            } ## end foreach my $attr ( @{$attr_ar...
        }
        else {
            $target_ar = $attr_ar;
        }

        if ( $scope eq 'all' ) {

            # get all uid|cn
            my $obj_id_hr = $self->get_value(
                {
                    scope   => 'all',
                    type    => $type,
                    obj     => $obj,
                    attr_ar => [ $ldap_hr->{dn_attr} ]
                }
            );

            # over all uid|cn
            foreach my $oid ( sort keys %{$obj_id_hr} ) {
                $logger->debug( 'oid: ', $oid );
                my $dn = "$ldap_hr->{dn_attr}=";
                $dn .= "$oid,$ldap_hr->{struc_rdn},"
                    . $access_cfg{ ident $self}->{base_dn};
                $logger->debug( 'dn: ', $dn );

                my $rslt = $ldap->modify( $dn,
                    changes => [ $changes => $target_ar ] );
                my $msg = "Can not change entry [$dn]!";
                if ( $rslt->codei ) {
                    $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
                }

            } ## end foreach my $oid ( sort keys...
        }
        else {    # scope one
            my $dn = "$ldap_hr->{dn_attr}=";
            $dn .= "$obj,$ldap_hr->{struc_rdn},"
                . $access_cfg{ ident $self}->{base_dn};
            $logger->debug( 'dn: ',      $dn );
            $logger->debug( 'changes: ', $changes );

            # build an array for LDAP attribute deletion
            my @del_target = ();
            if ( $escope eq 'all' ) {
                foreach my $attr ( @{$target_ar} ) { # remove unneeded entries
                    if ( ref($attr) ne 'ARRAY' ) {
                        push @del_target, $attr;
                    }
                }
            } ## end if ( $escope eq 'all' )

            $logger->debug( 'target_ar: ',
                { filter => \&Dumper, value => $target_ar } );
            $logger->debug( 'del_target array: ',
                { filter => \&Dumper, value => \@del_target } );

            my $rslt = undef;
            if ( $escope eq 'all' ) {    # erase all entries of an attribute
                $rslt = $ldap->modify( $dn, delete => \@del_target );
            }
            else {                       # make an ordinary change|delete|add
                $rslt = $ldap->modify( $dn,
                    changes => [ $changes => $target_ar ] );
            }
            my $msg = "Can not change entry [$dn]!";
            if ( $rslt->code ) {
                $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
            }

        } ## end else [ if ( $scope eq 'all' )

        $self->_ldap_end( { ldap => $ldap } );

        # +------------------------------------------------------------------+
        # | API
        return;

    } ## end sub set_value

    # +======================================================================+
    # || add_node                                                           ||
    # +======================================================================+
    sub add_node {    ## no critic (ProhibitExcessComplexity)

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $obj
            = ( exists $arg_r->{obj} and defined $arg_r->{obj} )
            ? $self->l( $arg_r->{obj} )
            : $self->perr('obj');

        my $type
            = exists $arg_r->{type}
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        my $attr_hr
            = exists $arg_r->{attr_hr}
            ? $self->h( $arg_r->{attr_hr} )
            : $self->perr('attr_hr');

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> obj: ',  $obj );
        $logger->debug( '> type: ', $type );
        $logger->debug( '> attr_hr: ',
            { filter => \&Dumper, value => $attr_hr } );

        # calc rel values
        my $ldap_hr = $self->_ldap_struct( { type => $type, obj => $obj } );

        # initialize the communication with LDAP
        my $ldap = $self->_ldap_start();

        # collect data about auxiliary and mandatory attributes.  if this
        # becomes a performance issue, it could perhaps be done only once
        # a day or once a startup. But add is a rather seldom operation
        # compared to set and get, so is probably OK to do on every
        # invocation, as then the information is ensured to be valid
        # every time.

        my @mandatory_attr = ();
        my %mandatory_attr = ();
        my %given_attr     = ();
        my %auxillary_attr = ();

        # get the schema for making checks
        if ( not defined $schema ) {
            $logger->debug('retrieve schema from LDAP');
            $schema = $ldap->schema;
        }
        else {
            my $msg = 'LDAP schema already there, will not retrieve';
            $logger->debug($msg);
        }

        # copy the hash to $cattr_ar
        my $cattr_ar = ();    # copy of data to give Net::LDAP->add

        # $schema->dump();
        foreach my $attr ( sort keys %{$attr_hr} ) {
            $logger->debug( 'attr: ', $attr );

           # unfortunately we have to make a copy, because:
           # (1) the hash or hashref cannot be passed to Net::LDAP->add
           # (2) only the hash or hashref can be analyzed
           # So the trick is to parse the hash but commit the array reference.
           # This module has not the duty to correct the hash. It was done by
           # CipUX::Object, hopefully.
           # But this module has the duty to croak if it can be forseen that
           # somethings is wrong or missing.
           # And it will throw an exception if somthing went wrong.
            push @{$cattr_ar}, $attr;
            push @{$cattr_ar}, $attr_hr->{$attr};

            if ( $attr eq 'objectClass' ) {
                $logger->debug( '-> found obj.Class: ', $attr );

                # go over every objectClass ($oc)
                foreach my $oc ( @{ $attr_hr->{$attr} } ) {

                    # Nice try LDAP-kun, but this is too obvious!
                    next if $oc eq 'top';

                    my $msg = '-> found obj.Class name';
                    $logger->debug( $msg . q{: }, $oc );

                    # remember mandatory
                    my @must = $schema->must($oc);
                    push @mandatory_attr, @must;

                    # go over every mandatory attribute ($n) not objectClass
                    foreach my $n (@must) {

                        # Dear LDAP-kun, this is obvious too.
                        next if $n->{name} eq 'objectClass';

                        # remember mandatory
                        $mandatory_attr{ $n->{name} } = 1;

                        my $msg2 = '--> mandatory attr';
                        $logger->debug( $msg2 . q{: }, $n->{name} );
                    } ## end foreach my $n (@must)

                    my @may = $schema->may($oc);

                    # go over all optional attributes
                    # First optional attr has the name '$may[0]->{name}'
                    foreach my $n (@may) {

                        # remember optional
                        $auxillary_attr{ $n->{name} } = 1;

                        my $msg3 = '--> auxillary attr';
                        $logger->debug( $msg3 . q{: }, $n->{name} );
                    } ## end foreach my $n (@may)

                } ## end foreach my $oc ( @{ $attr_hr...
            }
            else {
                $logger->debug( '-> generic attribute: ', $attr );

                # remember given non objectClasses with value
                $given_attr{$attr} = $attr_hr->{$attr};
            } ## end else [ if ( $attr eq 'objectClass')

        } ## end foreach my $attr ( sort keys...

        # check 1:
        # check given data for add: croak if 'not possible attr' are given
        foreach my $attr ( sort keys %{$attr_hr} ) {
            $logger->debug( 'check attr: ', $attr );
            if ( $mandatory_attr{$attr} or $attr eq 'objectClass' ) {
                $logger->debug( '-> attr mandatory: OK: ', $attr );
            }
            elsif ( $auxillary_attr{$attr} ) {
                $logger->debug( '-> attr auxillary: OK: ', $attr );
            }
            else {
                my $msg = '-> EXCEPTION: given attribute not possible!';
                $logger->debug( $msg . q{: }, $attr );

                if ( $attr eq $EMPTY_STRING ) {
                    $self->exc(
                        { msg => 'EXCEPTION given attr was empty!' } );
                }

                $msg = "The given attr [$attr] is not valid ";
                $msg .= 'for the given object classes. Add is not possible! ';
                $msg .= '(If you have not given the right objectClass, then ';
                $msg .= 'this is the reason why it is not possible!)';
                $msg .= 'So please check given objectClass or attribute.';
                $self->exc( { msg => $msg } );
            } ## end else [ if ( $mandatory_attr{$attr...
        } ## end foreach my $attr ( sort keys...

        # check 2:
        # check given data for add: if all mandatory attr are given
        # croak if attribute is missing
        foreach my $attr ( sort @mandatory_attr ) {
            my $n = $attr->{name};
            $logger->debug( 'check mandatory attr: ', $n );
            if ( defined $attr_hr->{$n} ) {
                $logger->debug( '-> mandatory attr OK: ', $n );
            }
            else {
                my $msg = '-> EXCEPTION: mandatory attribute not given!';
                $logger->debug( $msg . q{: }, $n );

                $msg = "EXCEPTION mandatory attr [$n] is missing!";
                $msg .= ' Please provide -x or --mattrvalue command line';
                $msg .= " option! Example: -x $n=<VALUE>";
                $self->exc( { msg => $msg } );
            } ## end else [ if ( defined $attr_hr->...
        } ## end foreach my $attr ( sort @mandatory_attr)

        $logger->debug( 'cattr_ar: ',
            { filter => \&Dumper, value => $cattr_ar } );

        # commit the stuff
        my $rslt = $ldap->add( $ldap_hr->{dn}, attr => $cattr_ar );
        my $msg = "Can not add entry [$ldap_hr->{dn}]!";
        if ( $rslt->code ) {
            $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
        }

        $self->_ldap_end( { ldap => $ldap } );

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $rslt;

    } ## end sub add_node

    # +======================================================================+
    # || delete_node                                                        ||
    # +======================================================================+
    sub delete_node {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $obj
            = ( exists $arg_r->{obj} and defined $arg_r->{obj} )
            ? $self->l( $arg_r->{obj} )
            : $self->perr('obj');

        my $type
            = ( exists $arg_r->{type} and defined $arg_r->{type} )
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> obj: ',  $obj );
        $logger->debug( '> type: ', $type );
        $logger->debug( 'self:', { filter => \&Dumper, value => $self } );
        $logger->debug( 'ident:',
            { filter => \&Dumper, value => ident $self } );

        # calc rel value
        my $ldap_hr = $self->_ldap_struct( { type => $type, obj => $obj } );
        $logger->debug( 'ldap_hr: ',
            { filter => \&Dumper, value => $ldap_hr } );

        # start the LDAP communication
        $logger->debug('starting communication ...');
        my $ldap = $self->_ldap_start();

        # delete the object
        $logger->debug('issue delete command ...');
        my $rslt = $ldap->delete( $ldap_hr->{dn} );

        # throw an exception if something went wrong
        my $msg = "Can not delete entry [$ldap_hr->{dn}]!";
        if ( $rslt->code ) {
            $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
        }

        # terminate LDAP communication
        $logger->debug('terminate communication ...');
        $self->_ldap_end( { ldap => $ldap } );

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $rslt;

    } ## end sub delete_node

    # +======================================================================+
    # || rename_node                                                        ||
    # +======================================================================+
    sub rename_node {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $obj
            = exists $arg_r->{obj}
            and defined $arg_r->{obj}
            ? $self->l( $arg_r->{obj} )
            : $self->perr('obj');

        my $value
            = exists $arg_r->{value}
            ? $self->l( $arg_r->{value} )
            : $self->perr('value');

        my $type
            = exists $arg_r->{type}
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> obj: ',   $obj );
        $logger->debug( '> value: ', $value );
        $logger->debug( '> type: ',  $type );

        # calc rel values
        my $ldap_hr = $self->_ldap_struct( { type => $type, obj => $obj } );

        # calculating relative DN
        my $rdn = $ldap_hr->{dn_attr} . q{=} . $value;

        $logger->debug( 'new rdn: ', $rdn );

        # start LDAP communication
        my $ldap = $self->_ldap_start();

        # do the modification
        my $rslt = $ldap->moddn( $ldap_hr->{dn}, newrdn => $rdn );

        # throw an exception if something went wrong
        my $msg = "Can not modify entry [$ldap_hr->{dn}]!";
        if ( $rslt->code ) {
            $self->exc( { msg => "$msg (" . $rslt->error . ')' } );
        }

        # terminate LDAP communication
        $self->_ldap_end( { ldap => $ldap } );

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $rslt;

    } ## end sub rename_node

    # +======================================================================+
    # || get_sid                                                            ||
    # +======================================================================+
    sub get_sid {

        # +------------------------------------------------------------------+
        # | API
        my $self = shift;

        my $sattr_ar = [];

        my $ldap = $self->_ldap_start();
        my $rslt = $ldap->search(
            base  => $access_cfg{ ident $self}->{base_dn},
            deref => 'always',
            scope => 'one',
            attrs => ['sambaSID'],

            # FIXME: replace this hardcoded value with configfile lookup
            filter => '(sambaDomainname=skolelinux)'
        );

        if ( $rslt->code ) {
            $self->exc( { msg => q{ (} . $rslt->error . q{)} } );
        }

        $self->_ldap_end( { ldap => $ldap } );

        my @entry = $rslt->entries;

        # +------------------------------------------------------------------+
        # | API
        return $entry[0]->get_value('sambaSID');

    } ## end sub get_sid

    # +======================================================================+
    # || _ldap_start                                                        ||
    # +======================================================================+
    sub _ldap_start : PRIVATE {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        # global API
        my $uri      = $access_cfg{ ident $self}->{uri};
        my $bind_dn  = $access_cfg{ ident $self}->{bind_dn};
        my $password = $access_cfg{ ident $self}->{password};

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( 'uri: ',     $uri );
        $logger->debug( 'bind_dn: ', $bind_dn );

        if ( not defined $password ) {
            my $msg = '(EXCEPTION): password is not defined';
            $msg .= " in cipux-access.ini or similar file.\n";
            croak $msg;
        }

        #$logger->debug( "password: [$password]" );

        my $msg = 'Can not create Net::LDAP object with URI [' . $uri . ']. ';

        # new connection
        my $ldap = Net::LDAP->new($uri) or $self->exc( { msg => "$msg $@" } );

        # bind to LDAP
        $msg = $ldap->bind( $bind_dn, password => $password );
        if ( $msg->code ) {
            $self->exc(
                { msg => "Can not bind to LDAP server! ($msg->error)" } );
        }

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $ldap;

    } ## end sub _ldap_start

    # +======================================================================+
    # || _ldap_end                                                          ||
    # +======================================================================+
    sub _ldap_end : PRIVATE {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        # TODO: find out what ref and make a CipUX h/a call
        my $ldap
            = exists $arg_r->{ldap} ? $arg_r->{ldap} : $self->perr('ldap');

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( 'ldap: ', $ldap );

        my $msg = $ldap->unbind;    # take down tie
        if ( $msg->code ) {
            $self->exc(
                { msg => "Can not unbind from LDAP server! ($msg->error)" } );
        }

        $msg = $ldap->disconnect;    # take down session

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $msg;

    } ## end sub _ldap_end

    # +======================================================================+
    # || list_storage_type                                                  ||
    # +======================================================================+
    sub list_storage_type {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');

        # we want only the keys (type names)
        my @return = sort keys %{ $storage_cfg{ ident $self} };

        $logger->debug( 'list_storage_type return: ',
            { filter => \&Dumper, value => \@return } );
        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return \@return;

    }

    # +======================================================================+
    # || _ldap_struct                                                       ||
    # +======================================================================+
    sub _ldap_struct : PRIVATE {    ## no critic (ProhibitExcessComplexity)

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        my $type
            = exists $arg_r->{type}
            ? $self->l( $arg_r->{type} )
            : $self->perr('type');

        my $obj = exists $arg_r->{obj} ? $self->l( $arg_r->{obj} ) : undef;

        my $scope
            = exists $arg_r->{scope} ? $self->l( $arg_r->{scope} ) : undef;

        my $filter
            = exists $arg_r->{filter} ? $self->l( $arg_r->{filter} ) : undef;

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');
        $logger->debug( '> type: ', $type );
        if ( defined $obj ) {
            $logger->debug( '> obj: ', $obj );
        }
        if ( defined $scope ) {
            $logger->debug( '> scope: ', $scope );
        }
        if ( defined $filter ) {
            $logger->debug( '> filter: ', $filter );
        }

        $logger->debug( 'self:', { filter => \&Dumper, value => $self } );
        $logger->debug( 'ident:',
            { filter => \&Dumper, value => ident $self } );

        #my $cfg_structure_hr = $self->get_storage_cfg();
        my $cfg_structure_hr = $storage_cfg{ ident $self};

        #$cfg_structure_hr = $cfg_structure_hr->{structure};
        #$logger->debug( 'cfg_structure_hr:',
        #    { filter => \&Dumper, value => $cfg_structure_hr } );

        # test type for all subs:
        my $type_ar = $self->list_storage_type(
            { cfg_structure_hr => $cfg_structure_hr } );

        #$logger->info( 'type_ar:',
        #    { filter => \&Dumper, value => $type_ar } );

        my %type = ();
        foreach my $t ( @{$type_ar} ) {
            $type{$t} = 1;
        }
        my $list_type = join ', ', @{$type_ar};

        my $cfg1
            = defined( $access_cfg{ ident $self}->{access_cfg} )
            ? $access_cfg{ ident $self}->{access_cfg}
            : 'undef';

        if ( not defined $type{$type} ) {
            my $msg = "type [$type], specified by option -t or --type, ";
            $msg .= 'is not defined in configuration file ';
            $msg .= "[$cfg1]! ";
            $msg .= "Valid types are: [$list_type]";
            $self->exc( { msg => $msg } );
        } ## end if ( not defined $type...

        my %ldap = ();

        # relative values to $access_cfg{ident $self}->{structure} and $type
        #my $clc_hr = $$storage_cfg{ident $self}{ 'structure' }->{$type};
        my $clc_hr = $storage_cfg{ ident $self}->{$type};
        my $msg1   = 'Undefined variable [dn_attr] in configuration ';
        $msg1 .= 'space [cipux-storage.*]! Please edit the file ';
        $msg1 .= 'and give it a value.';
        $ldap{dn_attr} = $self->l( $clc_hr->{dn_attr} )
            || $self->exc( { msg => $msg1 } );
        $msg1 = 'Undefined variable [filter] in configuration ';
        $msg1 .= 'space [cipux-storage.*]! Please edit the file ';
        $msg1 .= 'and give it a value.';
        $ldap{filter} = $self->lf( $clc_hr->{filter} )
            || $self->exc( { msg => $msg1 } );

        $msg1 = 'Undefined variable [struc_rdn] in configuration ';
        $msg1 .= 'file [cipux-storage.*]! Please edit the file ';
        $msg1 .= 'and give it a value.';

        #$ldap{struc_rdn} = $self->l( $clc_hr->{struc_rdn} )
        #  || $self->exc( { msg => $msg } );
        $ldap{struc_rdn} = $self->l( $clc_hr->{struc_rdn} ) || $EMPTY_STRING;

        $logger->debug( '      dn_attr: ', $ldap{dn_attr} );

        #$logger->debug('      filter: ', $ldap{filter}  ,"\n");
        $logger->debug( '      struc_rdn: ', $ldap{struc_rdn} );

        my @search = ();

        if ( $ldap{struc_rdn} ne $EMPTY_STRING ) {
            push @search, $ldap{struc_rdn};
        }
        if ( $access_cfg{ ident $self}->{base_dn} ne $EMPTY_STRING ) {
            push @search, $access_cfg{ ident $self}->{base_dn};
        }

        $ldap{search}
            = $ldap{struc_rdn} . q{,} . $access_cfg{ ident $self}->{base_dn};
        $ldap{search} = join q{,}, @search;
        $logger->debug( '      search: ', $ldap{search} );

        if ( defined $obj ) {
            unshift @search, $obj;
            $ldap{dn} = "$ldap{dn_attr}=";

            #  $ldap{dn} .= "$obj,";
            #  $ldap{dn} .= "$ldap{struc_rdn},";
            #  $ldap{dn} .= "$access_cfg{ident $self}->{base_dn}";
            $ldap{dn} .= join q{,}, @search;

            $logger->debug( '      dn: ', $ldap{dn} );
        } ## end if ( defined $obj )

        if ( defined $scope ) {
            if ( not defined $obj ) {
                $self->perr('obj (needed for scope)');
            }

            if ( $scope eq 'one' ) {
                $ldap{filter} =~ s/\?/$obj/gmsx;
            }
            elsif ( $scope eq 'all' ) {
                $ldap{filter} =~ s/\?/\*/gmsx;
            }
            else {
                my $msg2 = 'The value of the variable "scope" in methode ';
                $msg2 .= 'should be "all" or "one"! Please give an ';
                $msg2 .= 'apropriate value.';
                $self->exc( { $msg2 => $msg2 } );
            } ## end else [ if ( $scope eq 'one' )

            # additional filter from CipUX::Object or CipUX::Task
            if ( defined $filter ) {
                $logger->debug( 'add to filter: ', $filter );
                $ldap{filter} .= $filter;
            }

            $logger->debug( 'mod filter: ', $ldap{filter} );
            $logger->debug( 'scope: ',      $scope );
        } ## end if ( defined $scope )

        $logger->debug( '< ldap struct: ',
            { filter => \&Dumper, value => \%ldap } );

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return \%ldap;

    } ## end sub _ldap_struct

    # +======================================================================+
    # || oid_number_supremum                                                ||
    # +======================================================================+
    sub oid_number_supremum {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;

        # +------------------------------------------------------------------+
        # | prepare
        my $logger = get_logger(__PACKAGE__);
        $logger->debug('BEGIN');

        my %oid_info = (
            'cipux_account.user'  => 'uidNumber',
            'cipux_account.group' => 'gidNumber',
            'cipux_share.user'    => 'uidNumber',
            'cipux_share.group'   => 'gidNumber',
        );

        my $supremum = $MIN_OID_NUMBER;

        # +------------------------------------------------------------------+
        # | main
        foreach my $cipux_object_type ( keys %oid_info ) {

            my $attr         = $oid_info{$cipux_object_type};
            my $scope        = 'all';
            my $type         = $cipux_object_type;
            my $obj          = q{*};
            my $attrvalue_hr = { $attr => [], };

            my $value_hr = $self->get_value(
                {
                    scope   => $scope,
                    type    => $type,
                    obj     => $obj,
                    attr_ar => [ %{$attrvalue_hr} ]

                }
            );

            $logger->debug("got storage $type");
            $logger->debug( 'value_hr: ',
                { filter => \&Dumper, value => $value_hr } );

            # 'testprof' => {
            #               'uid'       => [ 'testprof' ],
            #               'uidNumber' => [ '11032'    ]
            #               }

            foreach my $oid ( keys %{$value_hr} ) {
                my $num = $value_hr->{$oid}->{$attr}->[0];
                $logger->debug("Attribute: $attr");
                $logger->debug("Number $num");
                if ( not defined $supremum ) {
                    $supremum = $num;
                }
                $supremum = $self->max( $supremum, $num );

            } ## end foreach my $oid ( keys %{$value_hr...

        } ## end foreach my $cipux_object_type...

        $logger->debug('END');

        # +------------------------------------------------------------------+
        # | API
        return $MIN_OID_NUMBER if $supremum < $MIN_OID_NUMBER;

        return $supremum + 1;

    } ## end sub oid_number_supremum

}    # END INSIDE-OUT CLASS

1;

__END__

=pod

=for stopword CipUX LDAP openLDAP objectClass cipux perl cipuxAccount posixAccount destructor cipux-storage.perl uidNumber gidNumber sambaSID cipux-access.ini ldap uri debian TODO Readonly utf8 Kuelker

=head1 NAME

CipUX::Storage - Storage abstraction layer for CipUX

=head1 VERSION

version 3.4.0.2

=head1 SYNOPSIS

  use CipUX::Storage;

=head1 DESCRIPTION

The CipUX Storage abstraction layer is a generic abstract class, which can be
used to access LDAP servers via Perl by issuing simple actions and via shell
command line interface. It was tested with openLDAP version 3. The layer is
capable of operating on different sets of LDAP nodes. A set of nodes might be
defined by an LDAP objectClass or LDAP attribute. Example: cipuxAccount or
posixAccount.  The number of objects inside a set might be ranged from one to
many. The abstraction layer performs a method on a set of nodes. Valid methods
are: 'get', 'set', 'get-all', 'set-all' on LDAP attribute values and  'add',
'delete', 'rename' on LDAP nodes.

It provides the functions get_value, set_value to modify LDAP attribute values.
The function add_node, delete_node and rename_node for adding, deleting and
renaming LDAP objects.

=head1 SUBROUTINES/METHODS

The following functions will be exported by CipUX::Storage.


=head2 BUILD

This is the constructor, see new.


  use CipUX::Storage;

  use base qw(CipUX::Storage);

  my $storage = CipUX::Storage->new();


=head2 DEMOLISH

This is the destructor.


=head2 get_value

The get_value queries the LDAP and returns one ore more values depending
on the parameter 'scope'.

B<Syntax:>

  eval {

      my $object    = 'ckuelker';
      my $attribute = 'cipuxFirstname';
      my $type      = 'all_user_node';
      $value_hr = $ldap->get_value({
                                       scope=>'one',
                                       type=>$type,
                                       obj=>$object,
                                       attr_ar=>[$attribute]
                                      });
  } or croak "ERROR: can't get value: $@!" if $@;

returns one value:


    %$ret_hr = (
              'ckuelker' => {
                               'cipuxFirstname' => ['Christian'],
                            }
                );


  eval {

      my $object    = '';
      my $attribute = 'cipuxFirstname';
      my $type      = 'all_user_node';
      $value_hr = $ldap->get_value({
                                       scope=>'all',
                                       type=>$type,
                                       obj=>$object,
                                       attr_ar=>[$attribute]
                                      });
  } or croak "ERROR: can't get value: $@!" if $@;


  %$ret_hr = (
              'ckuelker' => {
                               'cipuxFirstname' => ['Christian'],
                               'cipuxLastname' =>  ['Kuelker'],
                            },
              'xoswald' => {
                               'cipuxFirstname' => ['Xavier'],
                               'cipuxLastname' =>  ['Oswald'],
                            },

          );

=head3 Return values

    %ret = (
              'ckuelker' => {
                               'cipuxFirstname' => ['Christian'],
                               'cipuxLastname' =>  ['Kuelker'],
                            }


=head2 set_value

Sets a value for a given object in the LDAP database.

 my $rslt = set_value( {
     obj=>$obj,
     attr_ar=>$attr_ar,
     changes=>$changes,
     scope=>$scope,
     escope=>$escope,
     type=>$type
 } ;

     obj:      object
     attr_ar:  reference to an array of LDAP attributes and values
     changes:
     scope:    'one|all'        set/modify value
     escope:   'one|all|none'   erase scope
     type:

=head3 Modify Syntax

        my $msg = $ldap->modify( $dn,
                                   changes => [
                                       # add sn=Baggins
                                     add     => [ sn => 'Baggins' ],
                                       # delete all fax numbers
                                     delete  => [ faxNumber => []],
                                       # delete phone number 911
                                     delete  => [ telephoneNumber => ['911']],
                                       # change email address
                                     replace => [ mail => 'bilbo@baggins.org']
                                   ]
                                 );


=head2 add_node

Adds an LDAP node to the LDAP database.

 my $rslt = $cipux->add_node({obj=>$obj, type=>$type, attr_hr=>$attr_hr});

 obj :    The object to be added
 type:    kind of object to be added
 attr_hr: Hash reference with 'ldap_attribute=>value' structure

 $rslt:   is the reslult from Net::LDAP add


=head2 delete_node

Deletes an LDAP node from the LDAP database.

 my $rslt = $cipux->delete_node( { obj=>$obj, type=>$type } );

 obj :    The object to be added
 type:    kind of object to be added

 $rslt:   is the result from Net::LDAP delete

=head2 rename_node

Rename an LDAP node of the LDAP database.

 my $rslt = $cipux->rename_node({obj=>$obj, type=>$type, value=>$value });

 obj :    The object to be added
 type:    kind of object to be added
 value:   The new name

 $rslt:   is the result from Net::LDAP rename

=head2 _ldap_start

Binds to the LDAP server.

 my %access        = ();
 $access_cfg{ident $self}->{uri}      = 'ldap://localhost';
 $access_cfg{ident $self}->{bind_dn}  = 'cn=admin,dc=nodomain';
 $access_cfg{ident $self}->{password} = 'secret';
 my $ldap = $cipux->_ldap_start();

 $ldap:   is the LDAP Perl object returned from Net::LDAP.

=head2 _ldap_start

Unbinds from the LDAP server.

 my $msg = $cipux->_ldap_end( { ldap=>$ldap} );

 $msg:   is the message returned from Net::LDAP.

=head2 list_storage_type

Lists all CipUX LDAP nodes entities, sorted.

 my $list_ar = $cipux->list_type( { ldap=>$ldap} );

 $list_ar:   reference to an array of sorted CipUX LDAP entities.


=head2 _ldap_struct

Parses cipux-storage.perl with for object,
type, filter of a given scope. It also performs some
simple validation of that file.

 my $ldap_structure_hr = $cipux->_ldap_struct( {
     obj=>$obj,
     type=>$type,
     scope=>$scope,
     filter=>$filter
 });

 $ldap_structure_hr: returns a structure hash reference


=head2 oid_number_supremum

Searches the storage database for uidNumber and gidNumber. It returns the one
number above the largest number or the minimum number in the number range for
users and groups.

To perform the search it uses get_value (the storage layer itself).

=head2 get_sid

Retrieve sambaSID and return it if successful

=head1 Configuration files

=head2 cipux-access.ini

The CipUX access configuration has the following entries:

 [ldap]
 uri      = ldaps://ldap
 bind_dn  = cn=cipuxroot,dc=nodomain
 base_dn  = ou=CipUX,dc=nodomain
 password = secret
 system   = debian
 customer =


=head2 cipux_storage.perl

The storage structure configuration might look like this:

    $cfg = {
        'structure' => {
                all_group_node => {
                    desc         => 'access to all CN group objects',
                    struc_rdn    => 'ou=Group',
                    dn_attr      => 'cn',
                    filter       => '(cn=?)',
                },
                all_user_node => {
                    desc         => 'access to all system UID objects',
                    struc_rdn    => 'ou=User',
                    dn_attr      => 'uid',
                    filter       => '(uid=?)',
                },
                course_group_node => {
                    desc         => 'access to all system GID objects',
                    struc_rdn    => 'ou=Group',
                    dn_attr      => 'cn',
                    filter       => '&(cn=?)(groupType=public)',
                },
            },
}

=head1 DIAGNOSTICS

TODO

=head1 CONFIGURATION AND ENVIRONMENT

See cipux-access.ini and cipux-storage.perl man page for details on
configuration. CipUX::Storage do not use the environment for configuration.

=head1 DEPENDENCIES

 Carp
 Class::Std
 CipUX
 Data::Dumper
 English
 Net::LDAP
 Log::Log4perl
 Readonly
 utf8
 version

=head1 INCOMPATIBILITIES

Not known.

=head1 BUGS AND LIMITATIONS

Not known.

=head1 SEE ALSO

See the CipUX web page and the manual at L<http://www.cipux.org>

See the mailing list L<http://sympa.cipworx.org/wws/info/cipux-devel>

=head1 AUTHOR

Christian Kuelker  E<lt>christian.kuelker@cipworx.orgE<gt>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2007 - 2009 by Christian Kuelker

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; either version 2, or (at
your option) any later version.

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

=cut