# $Id: CosNaming_impl.pm 1354 2006-06-14 00:27:26Z rvosa $
# Subversion: $Rev: 117 $

# Copyright (c) 1997 Lunatech Research / Bart Schuller <schuller@lunatech.com>
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
use COPE::CosNaming_types;
use COPE::CosNaming_skel;
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

# IDL:omg.org/CosNaming/NamingContext:1.0
package CosNaming::NamingContext_impl;
@CosNaming::NamingContext_impl::ISA = qw(CORBA::BOA::_Servant);
use COPE::CORBA::Exception;
use Exception::Class::TCF;

my $logger = Log::Log4perl::get_logger('CosNaming.NamingContext_impl');

sub _skelname() {
   $logger->info("CosNaming::NamingContext_skel");
   "CosNaming::NamingContext_skel";
}

# The object and context hashes are indexed by a combination of
# the id and kind parts of a name component.  As these strings can
# not contain a null character they can be concatenated to make a unique key.
sub _key {
    $logger->info("Creating key");
    my $nc   = $_[0];
    my $id   = $nc->{'id'};
    my $kind = $nc->{'kind'};
    return length($kind) ? ( $id . chr(0) . $kind ) : $id;
}

# Throw an exception if an entry already exists.
sub _check_new {
    $logger->info("Check for duplicate entries");
    if ( defined $_[0] ) {
        $logger->fatal("CosNaming::NamingContext::AlreadyBound");
        throw new CosNaming::NamingContext::AlreadyBound;
    }
}

# IDL:omg.org/CosNaming/NamingContext/bind:1.0
sub bind {
    $logger->info("Binding");
    my ( $self, $n, $obj ) = @_;
    my $key = _key( pop @$n );
    $self = $self->resolve($n) if ( scalar(@$n) > 0 );
    _check_new( $self->{'objects'}{$key} );
    $self->{'objects'}{$key} = $obj;
}

# IDL:omg.org/CosNaming/NamingContext/rebind:1.0
sub rebind {
    $logger->info("Rebinding");
    my ( $self, $n, $obj ) = @_;
    my $key = _key( pop @$n );
    $self = $self->resolve($n) if ( scalar(@$n) > 0 );
    $self->{'objects'}{$key} = $obj;
}

# IDL:omg.org/CosNaming/NamingContext/bind_context:1.0
sub bind_context {
    $logger->info("Binding context");
    my ( $self, $n, $nc ) = @_;
    my $key = _key( pop @$n );

    #    _check_ctx($nc);
    $self = $self->resolve($n) if ( @$n > 0 );
    _check_new( $self->{'contexts'}{$key} );
    $self->{'contexts'}{$key} = $nc;
}

# IDL:omg.org/CosNaming/NamingContext/rebind_context:1.0
sub rebind_context {
    $logger->info("Rebinding context");
    my ( $self, $n, $nc ) = @_;
    my $key = _key( pop @$n );

    #    _check_ctx($nc);
    $self = $self->resolve($n) if ( @$n > 0 );
    $self->{'contexts'}{$key} = $nc;
}

# Check that an object is a naming context.
#sub _check_ctx {
#    if (!$_[0]->isa('CosNaming::NamingContext_impl')) {
#	throw new CORBA::BAD_PARAM;
#    }
#}
# IDL:omg.org/CosNaming/NamingContext/resolve:1.0
sub resolve {
    $logger->info("Resolving");
    my ( $self, $n ) = @_;
    if ( !@$n ) {
        throw CosNaming::NamingContext::InvalidName;
    }
    my $c   = shift @$n;
    my $key = _key($c);
    my $o   = $self->{'contexts'}{$key};
    if ( defined $o ) {
        if ( $o->{destroyed} ) {

            # This is a destroyed local naming context.
            # Remove its name and throw a naming exception.
            delete $self->{'contexts'}{$key};
            unshift @$n, $c;    # Restore name
            $logger->fatal("CosNaming::NamingContext::NotFound");
            throw new CosNaming::NamingContext::NotFound
              why => CosNaming::NamingContext::NotFoundReason::missing_node,
              rest_of_name => $n;
        }
        return $o unless @$n;
        try {
            $o = $o->resolve($n);
          }
          catch 'CORBA::OBJECT_NOT_EXIST' => sub {
            if ( @$n == 1 ) {

                # $o is a reference to a non-existent remote
                # naming context object.  As this exception is defined
                # to return authoritative information, the right thing
                # to do is to delete its name.
                # This gets rid of references to local naming contexts
                # that have been destroyed, but still have names.
                delete $self->{'contexts'}{$key};
                unshift @$n, $c;    # Restore name
                $logger->fatal("CosNaming::NamingContext::NotFound");
                throw new CosNaming::NamingContext::NotFound
                  why => CosNaming::NamingContext::NotFoundReason::missing_node,
                  rest_of_name => $n;
            }
            else {

                # Who knows ...
                $logger->fatal("CosNaming::NamingContext::CannotProceed");
                throw new CosNaming::NamingContext::CannotProceed,
                  cxt          => $o,
                  rest_of_name => $n;
            }
          },
          'CORBA::SystemException' => sub {
            $logger->fatal("CosNaming::NamingContext::CannotProceed");
            throw new CosNaming::NamingContext::CannotProceed,
              cxt          => $o,
              rest_of_name => $n;
          };
        return $o;
    }
    $o = $self->{'objects'}{$key};
    if ( defined $o ) {
        if ( !@$n ) {
            return $o;
        }
        else {
            unshift @$n, $c;
            $logger->fatal("CosNaming::NamingContext::NotFound");
            throw new CosNaming::NamingContext::NotFound
              why => CosNaming::NamingContext::NotFoundReason::not_context,
              rest_of_name => $n;
        }
    }
    unshift @$n, $c;
    $logger->fatal("CosNaming::NamingContext::NotFound");
    throw new CosNaming::NamingContext::NotFound
      why          => CosNaming::NamingContext::NotFoundReason::missing_node,
      rest_of_name => $n;
}

# IDL:omg.org/CosNaming/NamingContext/unbind:1.0
sub unbind {
    $logger->info("Unbinding");
    my ( $self, $n ) = @_;
    my $c   = pop @$n;
    my $key = _key($c);
    unless ( $c ) {
        $logger->fatal("CosNaming::NamingContext::InvalidName");
        throw CosNaming::NamingContext::InvalidName;
    }
    $self = $self->resolve($n) if ( @$n > 0 );
    if (   !defined( delete $self->{'objects'}{$key} )
        && !defined( delete $self->{'contexts'}{$key} ) )
    {
        $logger->fatal("CosNaming::NamingContext::NotFound");
        throw new CosNaming::NamingContext::NotFound
          why => CosNaming::NamingContext::NotFoundReason::missing_node,
          rest_of_name => [$c];
    }
}

# IDL:omg.org/CosNaming/NamingContext/new_context:1.0
sub new_context {
    $logger->info("Returning new context");
    return CosNaming::NamingContext_impl->new();
}

# IDL:omg.org/CosNaming/NamingContext/bind_new_context:1.0
sub bind_new_context {
    $logger->info("Binding new context");
    my ( $self, $n ) = @_;
    my $ctx = CosNaming::NamingContext_impl->new();
    $self->bind_context( $n, $ctx );
    return $ctx;
}

# IDL:omg.org/CosNaming/NamingContext/destroy:1.0
sub destroy {
    $logger->info("Destroying");
    my ($self) = @_;
    if ( %{ $self->{'objects'} } || %{ $self->{'contexts'} } ) {
        throw CosNaming::NamingContext::NotEmpty;
    }

    # Mark this naming context as having been destroyed.
    # If it still has local names, then it will not vanish when deactivated.
    # Any remaining names will be removed by resolve() when they are next used.
    $self->{'destroyed'} = 1;
    my $boa = $CORBA::BOA::_The_Boa;
    $boa->deactivate_object( $boa->_object_id($self) );
}

# IDL:omg.org/CosNaming/NamingContext/list:1.0
sub list {
    $logger->info("Listing bindings");
    my ( $self, $how_many, $bl, $bi ) = @_;
    my @nc;
    my $bindinglist = [
        map {
            @nc = split /\000/;
            {
                binding_name => [
                    {
                        'id'   => $nc[0],
                        'kind' => defined( $nc[1] ) ? $nc[1] : ''
                    }
                ],
                binding_type => CosNaming::BindingType::ncontext
            }
          } keys %{ $self->{'contexts'} }
    ];
    map {
        @nc = split /\000/;
        push @$bindinglist,
          {
            binding_name => [
                {
                    'id'   => $nc[0],
                    'kind' => defined( $nc[1] ) ? $nc[1] : ''
                }
            ],
            binding_type => CosNaming::BindingType::ncontext
          }
    } keys %{ $self->{'objects'} };
    if ( @$bindinglist > $how_many ) {
        $#bindinglist = $how_many - 1;
    }
    @$bl = @$bindinglist;
    $$bi = CORBA::Object->_nil();    # TODO ***** Not complete *****
}

# IDL:omg.org/CosNaming/BindingIterator:1.0
package CosNaming::BindingIterator_impl;

$logger = Log::Log4perl::get_logger('CosNaming.BindingIterator_impl');

@CosNaming::BindingIterator_impl::ISA = qw(CORBA::BOA::_Servant);
sub _skelname() {
    $logger->info("CosNaming::BindingIterator_skel");
    "CosNaming::BindingIterator_skel"
}

# TODO IDL:omg.org/CosNaming/BindingIterator/next_one:1.0
sub next_one {
    $logger->info("Returning next one");
    $logger->fatal("Not implemented");
    my ( $self, $b ) = @_;
}

# TODO IDL:omg.org/CosNaming/BindingIterator/next_n:1.0
sub next_n {
    $logger->info("Returning next n");
    $logger->fatal("Not implemented");
    my ( $self, $how_many, $bl ) = @_;
}

# TODO IDL:omg.org/CosNaming/BindingIterator/destroy:1.0
sub destroy {
    $logger->info("Destroying");
    $logger->fatal("Not implemented");
    my ($self) = @_;
}
1;

__END__

=head1 NAME

CosNaming::BindingIterator_impl

A class to ...

=head1 SYNOPSIS

use CosNaming::BindingIterator_impl;

=head1 DESCRIPTION

The CosNaming::BindingIterator_impl class implements ...

=head1 OPTIONS

 -D            - show debugging information
 -h            - show help
 -v            - show version
 Other options ...

=head1 SUBROUTINES

=head2 _skelname

Parameters:
    none

Insert description of subroutine here...

=head2 _key (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head2 _check_new (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head2 bind (method)

Parameters:
    n
    obj

Insert description of method here...

=head2 rebind (method)

Parameters:
    n
    obj

Insert description of method here...

=head2 bind_context (method)

Parameters:
    n
    nc

Insert description of method here...

=head2 rebind_context (method)

Parameters:
    n
    nc

Arguments:
    $_[0]

Insert description of method here...

=head2 resolve (method)

Parameters:
    n

Insert description of method here...

=head2 unbind (method)

Parameters:
    n

Insert description of method here...

=head2 new_context

Parameters:
    none

Insert description of subroutine here...

=head2 bind_new_context (method)

Parameters:
    n

Insert description of method here...

=head2 destroy (method)

Parameters:
    none

Insert description of method here...

=head2 list (method)

Parameters:
    how_many
    bl
    bi

Insert description of method here...

=head2 _skelname

Parameters:
    none

Insert description of subroutine here...

=head2 next_one (method)

Parameters:
    b

Insert description of method here...

=head2 next_n (method)

Parameters:
    how_many
    bl

Insert description of method here...

=head2 destroy (method)

Parameters:
    none

Insert description of method here...

=head1 FILES

Files used by the CosNaming::BindingIterator_impl class ...

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut