# $Id: BOA.pm 1390 2006-06-15 04:43:57Z 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.
# interface CORBA::BOA
# Modified by Irving Reid and others 1997-1998 to support SSL
# and connect/disconnect callbacks.
# Modified by Giles Atkinson and otheres 1998-99.

use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package CORBA::BOA;
use COPE::CORBA::ServerRequest;
use COPE::CORBA::Client;
use COPE::CORBA::Servant;
use COPE::CORBA::Skel;
use COPE::GIOP;
use IO::Socket;
use Socket;
use Sys::Hostname;
use Exception::Class::TCF;
use COPE::CORBA::Exception;

my $logger = Log::Log4perl::get_logger('CORBA.BOA');

# Determine the local hostname as a fully-qualified domain name
# for use in IORs.  For local development on UNIX the two commented-out lines
# do not require the libnet modules and allow for faster startup
# (and the wrong result).  Or just assign a constant '127.0.0.1'.
use Net::Domain;

#my $hostname = Net::Domain::hostfqdn(); # TODO change hostfqdn() to inet_ntoa(scalar(gethostbyname(hostname)))
use Socket;
use Sys::Hostname;
my $host = hostname();
my $hostname = inet_ntoa(scalar(gethostbyname($host)));

$CORBA::BOA::_The_Boa = 0;
$CORBA::BOA::_id      = 0;
my $shutting_down = 0;
my $OMG_policy    = 1;    #No auto deletion of objects on client disconnect

# A "client handle" for operations that don't have a real client
# (like initialization)
my $global_client =
  { '_localname' => $hostname, '_localport' => '0', '_profiles' => [] };

=pod

=begin testing

ok( CORBA::BOA->new->isa('CORBA::BOA'), "Testing object adaptor constructor" );

=end testing

=cut

sub new {
    $logger->info("Creating object adaptor");
    my ( $class, $orb, $argv, $boa_identifier ) = @_;
    my $boa = {};
    $boa->{'port'}        = $orb->{'port'};
    $boa->{'max_sockets'} = $orb->{'max_sockets'};
    my $fh = IO::Socket::INET->new(
        'LocalPort' => $boa->{'port'},
        'Proto'     => "tcp",
        'Reuse'     => 1,
        'Listen'    => 5
      )
      or $logger->fatal("Can't listen on socket: $!") && die "Can't listen on socket: $!";
    $boa->{'socket'} = [ [ $fh, { '_profiles' => [] } ] ];
    $boa->{'port'}       = $fh->sockport;
    $boa->{'byte_order'} = $orb->{'byte_order'};

    # Set default client
    $global_client->{'_localport'} = $boa->{'port'};
    $global_client->{'_tag'} = $global_client->{'_localname'} . ':' . $boa->{'port'};
    $boa->{'__current_client'} = $global_client;

    return $CORBA::BOA::_The_Boa = bless $boa, $class;
}

=pod

=begin testing

ok( CORBA::BOA->new->create, "Testing object adaptor's create method" );

=end testing

=cut

sub create {
    $logger->info("Calling \"create\"");
    my ( $self, $id, $intf, $impl ) = @_;
}

=pod

=begin testing

ok( CORBA::BOA->new->_create, "Testing object adaptor's _create method" );

=end testing

=cut

sub _create {
    $logger->debug("Creating \"CORBA::Object\"");
    my ( $self, $id ) = @_;
    return bless { 'id' => $id }, 'CORBA::Object';
}

=pod

=begin testing

ok( CORBA::BOA->new->dispose, "Testing object adaptor's dispose method" );

=end testing

=cut

sub dispose {
    $logger->info("Calling \"dispose\"");
    my ( $self, $obj ) = @_;
}

=pod

=begin testing

ok( CORBA::BOA->new->get_id, "Testing object adaptor's get_id method" );

=end testing

=cut

sub get_id {
    $logger->info("Looking up object ID");
    my ( $self, $obj ) = @_;
    return $obj->{'id'};
}

=pod

=begin testing

ok( CORBA::BOA->new->change_implementation, "Testing object adaptor's change_implementation method" );

=end testing

=cut

sub change_implementation {
    $logger->info("Changing implementations in skeletons hash");
    my ( $self, $obj, $impl ) = @_;

    # Remove the old implementation from the skeletons hash
    delete $self->{'skeletons'}{ $obj->{'impl'} };
    $obj->{'impl'} = $impl;
    $self->{'skeletons'}{$impl} = $obj;
}

=pod

=begin testing

ok( CORBA::BOA->new->impl_is_ready, "Testing object adaptor's impl_is_ready method" );

=end testing

=cut

sub impl_is_ready {
    $logger->info("Implementation is ready");
    my ( $self, $impl ) = @_;
    my $server = $self->{'socket'};
    my ( $rin, $rout, $win, $wout, $sel, $timer, $now, $newtime );
    $shutting_down = 0;
    $timer         = 5000000;    # wait a long time for the first connection
         # Work around BSD/OS select() updating bitmasks on full words
    $rin = "\0\0\0\0";
    $win = "\0\0\0\0";
    while (1) {
        my $numclients = scalar( keys( %{ $self->{'clients'} } ) );
        if ($shutting_down) {
            if ( $numclients == 0 ) {

    			$logger->info("Shutting down");

                # All our clients are gone
                return;
            }
        }
        elsif ( $numclients <= $self->{'max_sockets'} ) {
            foreach (@$server) {
                vec( $rin, $_->[0]->fileno, 1 ) = 1;
            }
        }
        $rout = $rin;
        $wout = $win;
        ( $sel, $timer ) = select( $rout, $wout, undef, $timer );
        if ( $sel < 0 ) {

            # what happened?
            if ( $! ne 'Interrupted system call' ) {

                $logger->warn("Select failed: $!; sleeping");

                warn("Select failed: $!; sleeping");
                sleep(30);
            }
            else {
                next;
            }
        }

        # During the loop, $timer holds the absolute time of the next
        # timeout
        $now   = time;
        $timer = 5000000 + $now;
        $rin   = '';
        $win   = '';
        foreach ( keys %{ $self->{'clients'} } ) {
            my $cli = $self->{'clients'}{$_};
            next if !( $cli->{_sock} );
            my $func = $cli->{_func};
            $newtime = $cli->$func( \$rout, \$wout, \$rin, \$win, $now );
            if ( defined($newtime) ) {
                if ( $newtime < $timer ) {
                    $timer = $newtime;
                }
            }
            else {

                # the client went away
                delete $self->{'clients'}{$_};

                # Make sure we get all the dangling references...
                $self->{__current_client} = $global_client;
            }
        }

        # For the select, we want $timer to be relative to now
        $timer -= $now;
        if ( !$shutting_down ) {
            foreach ( @{$server} ) {
                if ( vec( $rout, $_->[0]->fileno, 1 ) ) {
                    ( my $client_sock, undef ) = $_->[0]->accept;
                    if ( !defined($client_sock) ) {
                        next;
                    }

                    #
                    # Note: The ugly use of the 'client_sock' key for the
                    # client hash instead of just using $client is
                    # necessary because you cannot use a hash as a
                    # key.  The hash is turned into a string which
                    # cannot be dereferenced again... See
                    # page 256 of the camel book for details.
                    #
                    $self->{'clients'}{$client_sock} =
                      CORBA::BOA::_Client->new( $client_sock, $now, $_->[1] );
                    vec( $rin, $client_sock->fileno, 1 ) = 1;

                    # wait up to 20 seconds for input from the new client
                    if ( $timer > 20 ) {
                        $timer = 20;
                    }
                }
            }
        }
    }
}

=pod

=begin testing

ok( CORBA::BOA->new->deactivate_impl, "Testing object adaptor's deactivate_impl method" );

=end testing

=cut

sub deactivate_impl {
    my ( $self, $impl ) = @_;

    my $logger = get_logger('CORBA.BOA');
    $logger->info("Deactivating implementation");

    $shutting_down = 1;
    $self->_close_all_listeners;
    $self->{'socket'}->[0]->[0]->close;
}

=pod

=begin testing

ok( CORBA::BOA->new->_add_listener, "Testing object adaptor's _add_listener method" );

=end testing

=cut

# not in interface
#
# Add a new listener socket to the BOA
#
# Takes a socket and a hash of default values for clients on that
# socket
#
sub _add_listener {
    $logger->debug("Adding listener");
    my ( $self, $sock, $defaults ) = @_;
    push @{ $self->{'socket'} }, [ $sock, $defaults ];
}

=pod

=begin testing

ok( CORBA::BOA->new->_remove_client, "Testing object adaptor's _remove_client method" );

=end testing

=cut

# Remove a client from the BOA's list
sub _remove_client {
    $logger->debug("Removing client");
    my ( $self, $client ) = @_;
    delete $self->{'clients'}{ $client->{_sock} };
    if ( $self->{'__current_client'} == $client ) {
        $self->{'__current_client'} = $global_client;
    }
}

=pod

=begin testing

ok( CORBA::BOA->new->_close_all_listeners, "Testing object adaptor's _close_all_listeners method" );

=end testing

=cut

# Close all BOA listening sockets, EXCEPT for
# the first, which is managed internally by the BOA
# (localhost).
sub _close_all_listeners {
    $logger->debug("Closing all listeners");
    my $self = shift;
    while ( @{ $self->{'socket'} } > 1 ) {
        $self->{'socket'}->[1]->[0]->close;
        splice( @{ $self->{'socket'} }, 1, 1 );
    }
}

=pod

=begin testing

ok( CORBA::BOA->new->_pre_callback, "Testing object adaptor's _pre_callback method" );

=end testing

=cut

# Register a function to be called before every method invocation
sub _pre_callback {
    $logger->debug("Registering callback for pre-method invocation");
    my ( $self, $funcref ) = @_;
    my $previous = $self->{'pre_callback'};
    $self->{'pre_callback'} = $funcref;
    return $previous;
}

=pod

=begin testing

ok( CORBA::BOA->new->_post_callback, "Testing object adaptor's _post_callback method" );

=end testing

=cut

# Same, but after every invocation
sub _post_callback {
    $logger->debug("Registering callback for post-method invocation");
    my ( $self, $funcref ) = @_;
    my $previous = $self->{post_callback};
    $self->{post_callback} = $funcref;
    return $previous;
}

=pod

=begin testing

ok( CORBA::BOA::_handle_request, "Testing object adaptor's _handle_request class method" );

=end testing

=cut

sub CORBA::BOA::_handle_request {
    $logger->debug("Handling request");
    my $client = shift;
    my ( $data, $index, $byte_order, $client_ind );
    $index      = 12;                       # skip the message header
    $data       = $client->{'_readBuf'};
    $byte_order = $client->{'_byte_order'};
    my $rh = GIOP::RequestHeader::_unmarshal( \$data, \$index, $byte_order );
    my $target        = CORBA::BOA::_find_target( $client, $rh->{'object_key'} );
    my $operation     = $rh->{'operation'};
    my $serverrequest =
      CORBA::ServerRequest->new( $operation, $byte_order, $data, $index );
    $operation =~ s/^_(get|set)_//o;
    my $exception;
    my $exctype = GIOP::NO_EXCEPTION;

    if ($target) {
        try {

            # First, call the method callback if there is one
            # The callback can either raise a SystemException or
            # modify the request through the references
            if ( defined( $CORBA::BOA::_The_Boa->{pre_callback} ) ) {
                &{ $CORBA::BOA::_The_Boa->{pre_callback} }( $client, \$target,
                    \$operation, \$serverrequest );
            }
            $CORBA::BOA::_The_Boa->{__current_client} = $client;
            $target->$operation($serverrequest);
          }
          catch 'CORBA::SystemException' => sub {
            $exception = $_[0];
            $exctype   = GIOP::SYSTEM_EXCEPTION;
            $logger->warn("GIOP::SystemException");
          },
          'CORBA::UserException' => sub {
            $exception = $_[0];
            $exctype   = GIOP::USER_EXCEPTION;
            $logger->warn("GIOP::UserException");
          },
          'CORBA::ForwardRequest' => sub {
            $exception = $_[0];
            $exctype   = GIOP::LOCATION_FORWARD;
            $logger->warn("GIOP::ForwardRequest");
          },
          'Default' => sub {

            # An evil implementation threw something else.
            $exception =
              CORBA::OBJ_ADAPTER->new(
                'completed' => CORBA::CompletionStatus::COMPLETED_MAYBE
              );
            $exctype = GIOP::SYSTEM_EXCEPTION;
            $logger->warn("GIOP::SYSTEM_EXCEPTION");
          };

        # Call the post-method callback.
        if ( defined( $CORBA::BOA::_The_Boa->{'post_callback'} ) ) {
            $logger->info("Calling post-method callback");
            &{ $CORBA::BOA::_The_Boa->{'post_callback'} }( $client, \$target,
                \$operation, \$serverrequest, \$exception );
        }
    }
    else {

        # No such object, and no default handler
        # Handle the special-case non_existent() method here.
        if ( $operation =~ /^_no(n|t)_existent$/ ) {

            # prepare the $serverrequests result
            $serverrequest->{'result'} = {
                '_type'  => $CORBA::_tc_boolean,
                '_value' => 1
            };
        }
        else {
            $exception = new CORBA::OBJECT_NOT_EXIST;
            $exctype   = GIOP::SYSTEM_EXCEPTION;
            $logger->warn("GIOP::SYSTEM_EXCEPTION");
        }
    }
    return '' if !$rh->{response_expected};    # Check for oneway operation
    my $reply_header = GIOP::ReplyHeader->new(
        service_context => [],
        request_id      => $rh->{request_id},
        reply_status    => $exctype
    );
    $byte_order = $CORBA::BOA::_The_Boa->{byte_order};

    # Marshal the GIOP header in-line with crude efficiency.
    my $reply = "GIOP\1\0";                    # Identify GIOP version 1.0
    $reply .= ( $byte_order ? "\1" : "\0" ) . chr(GIOP::Reply);
    $reply .= '1234';    # Place holder for message length.
    $index = 12;
    GIOP::ReplyHeader::_marshal( \$reply, \$index, $byte_order, $reply_header );
    if ($exception) {
        my $tc = ref $exception;
        no strict 'refs';
        $tc = ${"${tc}::_tc"}; # hacky quote for eclipse syntax coloration: "
        CORBA::ORB::_marshal_using_tc( \$reply, \$index, $byte_order,
            $exception, $tc );
    }
    else {
        my $result = $serverrequest->get_result();
        if ($result) {
            CORBA::ORB::_marshal_using_tc( \$reply, \$index, $byte_order,
                $result->{_value}, $result->{_type} );
        }
        my $arg_list = $serverrequest->get_arglist();
        my $argnum   = 1;
        foreach my $arg ( @{$arg_list} ) {
            $argnum++;
            if ( ( $arg->{arg_modes} == 1 ) || ( $arg->{arg_modes} == 2 ) ) {
                CORBA::ORB::_marshal_using_tc(
                    \$reply, \$index, $byte_order,
                    $arg->{argument}{_value},
                    $arg->{argument}{_type}
                );
            }
        }
    }

    # Plug in the message length.
    my ( $t_index, $t_buf ) = ( 0, '' );
    CORBA::ORB::_marshal_ulong( \$t_buf, \$t_index, $byte_order, $index - 12 );
    substr( $reply, 8, 4, $t_buf );

    $logger->info("Returning reply");
    return $reply;
}

=pod

=begin testing

ok( CORBA::BOA->new->_find_target, "Testing object adaptor's _find_target method" );

=end testing

=cut

sub CORBA::BOA::_find_target {
    $logger->debug("Finding target");
    my ( $client, $object_key ) = @_;
    my $target = $client->{'objects'}{$object_key};

    # If we didn't find an object for this request:
    #
    # Look in several places to find it...
    #
    # 1) Look in other clients' lists of objects
    # 2) Look for a default handler
    if ( !$target ) {
        $logger->debug("Finding obj by id:\"$object_key\"");
        my $skel;
        ( undef, $skel ) = _find_obj_by_id($object_key);
        if ($skel) {

            # Found it in another client's list.
            # Add it to ours
            $client->{'objects'}{$object_key}       = $skel;
            $client->{'skeletons'}{ $skel->{impl} } = $skel;
            $target                                 = $skel;
        }
    }
    if ( !$target ) {
        $logger->debug("Creating interface from obj key:\"$object_key\"");
        # See if we have a default object installed for object types
        # this request wants.
        #
        my $interface = $object_key;
        $interface =~ s/(.*?)[ ].*/$1/o;
        $target = $CORBA::BOA::_The_Boa->{'default'}{$interface};

        # Set the current default object id so other
        # methods such as 'servant_to_id' work when called
        # from the default servant.
        # Note that this will have to change if we ever
        # get involved with async requests or multi-threading
        #
        $CORBA::BOA::_The_Boa->{'default'}{'currentoid'} = $object_key;
        if ($target) {

            #
            # Add the default object to this client's object list
            # (so other ops like servant_to_id() will find it)
            #
            $client->{'objects'}{ $target->{id} }     = $target;
            $client->{'skeletons'}{ $target->{impl} } = $target;
        }
    }
    return $target;
}
##############################################################################
##############################################################################
#
# The following functions should closely resemble the ones specified
# in the POA spec.
#
##############################################################################
##############################################################################

=pod

=begin testing

ok( CORBA::BOA->new->get_servant, "Testing object adaptor's get_servant method" );

=end testing

=cut

#############################################################################
#
# get_servant:  Return default servant associated with the POA
#               given an IDL type.
#
#############################################################################
sub get_servant {
    $logger->info("Getting servant");
    my ( $self, $type ) = @_;
    my $skel = $self->{'default'}{$type};
    throw new CORBA::OBJECT_NOT_EXIST if !$skel;
    return $skel->{impl};
}

=pod

=begin testing

ok( CORBA::BOA->new->set_servant, "Testing object adaptor's set_servant method" );

=end testing

=cut

#############################################################################
#
# set_servant:  Set the default servant given IDL type
#
# Note: servant must be active before making this call
#
#############################################################################
sub set_servant {
    $logger->info("Setting servant");
    my ( $self, $type, $servant ) = @_;
    my $skel;
    if ( !$servant || !$type ) {
    	$logger->fatal("CORBA::BAD_PARAM");
    	throw new CORBA::BAD_PARAM;
    }
    foreach ( $global_client, values %{ $self->{'clients'} } ) {
        if ( $skel = $_->{'skeletons'}{$servant} ) {

            # Mark this skeleton so we know that it is a default
            # elsewhere
            $skel->{'default'} = 1;
            $self->{'default'}{$type} = $skel;
            return;
        }
    }

    $logger->fatal("CORBA::OBJECT_NOT_EXIST");
    throw new CORBA::OBJECT_NOT_EXIST;
}

=pod

=begin testing

ok( CORBA::BOA->new->activate_object, "Testing object adaptor's activate_object method" );

=end testing

=cut

#############################################################################
#
# activate_object: Activate (instantiate) a given servant generating a
#                  unique object_id in the process.
#
# Returns the object_id of activated object
#
#############################################################################
sub activate_object {
    $logger->info("Activating object");
    my ( $self, $servant ) = @_;
    my $client = $OMG_policy ? $global_client : $self->{__current_client};
    if ( !$servant ) {
    	$logger->fatal("CORBA::BAD_PARAM");
    	throw CORBA::BAD_PARAM->new;
    }

    # Create a new skeleton and associate the
    # servant (implementation object) with it.
    my $class = $servant->_skelname;
    my CORBA::_Skel $skel = $class->new;
    $skel->{id} = $skel->_interface . " " . $skel->{id};
    $skel->{'impl'} = $servant;
    $client->{'objects'}{ $skel->{'id'} } = $skel;
    $client->{'skeletons'}{$servant} = $skel;
    return $skel->{'id'};
}

=pod

=begin testing

ok( CORBA::BOA->new->activate_object_with_id, "Testing object adaptor's activate_object_with_id method" );

=end testing

=cut

#############################################################################
#
# activate_object_with_id: Activate (instantiate) a given servant using a
#                          given object id.
#
#############################################################################
sub activate_object_with_id {
    $logger->info("Activating object with id");
    my ( $self, $oid, $servant, $no_type ) = @_;
    my $client = $OMG_policy ? $global_client : $self->{__current_client};
    if ( !$servant ) {
	    $logger->fatal("CORBA::INV_OBJREF");
	    throw new CORBA::INV_OBJREF;
    }

    # Create a new skeleton and associate the
    # servant (implementation object) with it.
    my $class = $servant->_skelname;
    my $skel  = $class->new;
    $oid = $skel->_interface . " " . $oid unless $no_type;
    if ( _find_obj_by_id($oid) ) {

        # Object is already active
        #
        # TODO Should be SERVANT_ALREADY_ACTIVE
        $logger->fatal("CORBA::INV_OBJREF");
        throw CORBA::INV_OBJREF->new( 'minor' => 1 );
    }
    $skel->{'impl'}                  = $servant;
    $skel->{'id'}                    = $oid;
    $client->{'objects'}{$oid}       = $skel;
    $client->{'skeletons'}{$servant} = $skel;
}

=pod

=begin testing

ok( CORBA::BOA->new->deactivate_object, "Testing object adaptor's deactivate_object method" );

=end testing

=cut

#############################################################################
#
# deactivate_object: Deactivate (destroy) a given servant and remove
#                    its entry from the active object map.
#
#############################################################################
sub deactivate_object {
    my ( $self, $oid ) = @_;

    my $logger = get_logger('CORBA.BOA');
    $logger->info("Deactivating object");

    my ( $client, $skel );
    my $found = 0;
    foreach $client ( $global_client,
        values %{ $CORBA::BOA::_The_Boa->{'clients'} } )
    {
        if ( $skel = delete( $client->{'objects'}{$oid} ) ) {
            delete $client->{'skeletons'}{ $skel->{impl} };
            $found = 1;
        }
    }
    if ( !$found ) {
	    $logger->fatal("CORBA::OBJECT_NOT_EXIST");
	    throw new CORBA::OBJECT_NOT_EXIST;
    }
}

=pod

=begin testing

ok( CORBA::BOA->new->create_reference, "Testing object adaptor's create_reference method" );

=end testing

=cut

#############################################################################
#
# create_reference: Create an object reference given an interface spec
#
#############################################################################
sub create_reference {
    $logger->info("Creating reference");
    my ( $self, $interface ) = @_;

    # Generate a unique id...
    my $oid               = $interface . " " . $self::_id++;
    my $class             = CORBA::TypeCode::_id2package($interface) . '_skel';
    my CORBA::_Skel $skel = $class->new($oid);
    $skel->{impl} = 1;
    return $skel;
}

=pod

=begin testing

ok( CORBA::BOA->new->create_reference_with_id, "Testing object adaptor's create_reference_with_id method" );

=end testing

=cut

#############################################################################
#
# create_reference_with_id: Return an object reference given an object
#                           interface type in IDL form and object id (key).
#
#############################################################################
sub create_reference_with_id {
    $logger->info("Creating reference with id");
    my ( $self, $oid, $interface, $no_type ) = @_;
    my CORBA::_Skel $skel;
    my $client = $self->{__current_client};
    $oid = $interface . " " . $oid unless $no_type;

    # See if we have an object that exists with these
    # properties already.
    if ( $skel = $client->{'objects'}{$oid} ) {
        return $skel->{'impl'};
    }
    else {
        ( undef, $skel ) = _find_obj_by_id($oid);
        if ($skel) {

            # Found it in another client's list.
            # Add it to ours
            $client->{'objects'}{$oid} = $skel;
            $client->{'skeletons'}{ $skel->{impl} } = $skel;
            return $skel->{'impl'};
        }
    }

    # None already exist, generate a fake reference.
    # identify this as a fake/virtual object
    my $class = CORBA::TypeCode::_id2package($interface) . '_skel';
    $skel = $class->new($oid);
    $skel->{impl} = 1;
    return $skel;
}

=pod

=begin testing

ok( CORBA::BOA->new->_object_id, "Testing object adaptor's _object_id method" );

=end testing

=cut

#############################################################################
#
# servant_to_id: Return object id associated with a servant object
#
#############################################################################
sub _object_id {
    $logger->debug("Calling _object_id");
    my ( $self, $servant ) = @_;
    my $skel;
    if ( !$servant ) {
	    $logger->fatal("CORBA::BAD_PARAM");
	    throw new CORBA::BAD_PARAM;
    }
    foreach my $client ( $global_client, values %{ $self->{'clients'} } ) {
        if ( $skel = $client->{'skeletons'}{$servant} ) {
            my $oid = "";
            if ( $skel->{'default'} ) {
                $oid = $self->{'default'}{'currentoid'};
            }
            else {
                $oid = $skel->{id};
            }
            return $oid;
        }
    }

    # TODO Should really be OBJECT_NOT_ACTIVE
    $logger->fatal("CORBA::OBJECT_NOT_EXIST");
    throw new CORBA::OBJECT_NOT_EXIST;
}

=pod

=begin testing

ok( CORBA::BOA->new->servant_to_id, "Testing object adaptor's servant_to_id method" );

=end testing

=cut

sub servant_to_id {
    $logger->info("Retrieving ID from servant");
    my ( $self, $servant ) = @_;
    my $oid = _object_id( $self, $servant );
    $oid =~ s/(.*?)[ ](.*)/$2/o;
    return ($oid);
}

=pod

=begin testing

ok( CORBA::BOA->new->servant_to_reference, "Testing object adaptor's servant_to_reference method" );

=end testing

=cut

#############################################################################
#
# servant_to_reference: returns an object reference for a given
#                       servant (implementation object).
#
#############################################################################
sub servant_to_reference {
    $logger->info("Returning object reference for servant");
    my ( $self, $servant ) = @_;
    my $client;
    my $skel;
    if ( !$servant ) {
		$logger->fatal("CORBA::BAD_PARAM");
	    throw new CORBA::BAD_PARAM;
    }
    foreach $client ( $global_client, values %{ $self->{'clients'} } ) {
        if ( $skel = $client->{'skeletons'}{$servant} ) {
            return $skel;
        }
    }

    # TODO Should really be OBJECT_NOT_ACTIVE
    $logger->fatal("CORBA::OBJECT_NOT_EXIST");
    throw new CORBA::OBJECT_NOT_EXIST;
}

=pod

=begin testing

ok( CORBA::BOA->new->reference_to_servant, "Testing object adaptor's reference_to_servant method" );

=end testing

=cut

#############################################################################
#
# reference_to_servant: returns a servant for a given object reference
#
#############################################################################
sub reference_to_servant {
    $logger->info("Returning servant for object reference");
    my ( $self, $skel ) = @_;
    if ( !$skel ) {
	    $logger->fatal("CORBA::BAD_PARAM");
	    throw new CORBA::BAD_PARAM;
    }
    return $skel->{'impl'};
}

=pod

=begin testing

ok( CORBA::BOA->new->reference_to_id, "Testing object adaptor's reference_to_id method" );

=end testing

=cut

#############################################################################
#
# reference_to_id: Return the object_id associated with an object reference
#
#############################################################################
sub reference_to_id {
    $logger->info("Returning object_id for object reference");
    my ( $self, $skel ) = @_;
    my $oid = "";
    if ( !$skel ) {
	    $logger->fatal("CORBA::INV_OBJREF");
	    throw new CORBA::INV_OBJREF;
    }
    if ( $skel->{'default'} ) {

        # this is a default handler
        $oid = $self->{'default'}{'currentoid'};
    }
    elsif ( defined( $skel->{id} ) ) {
        $oid = $skel->{id};
    }
    elsif ( $skel->{'object_key'} ) {

        # this is an object ref
        if (   ( $skel->{host} ne $self->{__current_client}{_localname} )
            || ( $skel->{port} != $self->{__current_client}{_localport} ) )
        {

            # TODO In a real POA, this would be POA::WrongAdapter
            $logger->fatal("CORBA::INV_OBJREF");
            throw new CORBA::INV_OBJREF;
        }
        $oid = $skel->{object_key};
    }
    else {
        $logger->fatal("CORBA::INV_OBJREF");
        throw new CORBA::INV_OBJREF;
    }
    $oid = ( split( ' ', $oid, 2 ) )[1];
    return $oid;
}

=pod

=begin testing

ok( CORBA::BOA->new->id_to_servant, "Testing object adaptor's id_to_servant method" );

=end testing

=cut

#############################################################################
#
# id_to_servant: Return the active servant associated with an object_id
#
#############################################################################
sub id_to_servant {
    $logger->info("Returning active servant for object_id");
    my ( $self, $oid ) = @_;
    my $skel;
    if ( !$oid ) {
	    $logger->fatal("CORBA::BAD_PARAM");
	    throw new CORBA::BAD_PARAM;
    }
    ( undef, $skel ) = _find_obj_by_id($oid);

    # TODO This should be OBJECT_NOT_ACTIVE
    if ( !$skel ) {
	    $logger->fatal("CORBA::OBJECT_NOT_EXIST");
	    throw new CORBA::OBJECT_NOT_EXIST;
    }
    return $skel->{'impl'};
}

=pod

=begin testing

ok( CORBA::BOA->new->id_to_reference, "Testing object adaptor's id_to_reference method" );

=end testing

=cut

#############################################################################
#
# id_to_reference: Return a reference for an active object_id
#
#############################################################################
sub id_to_reference {
    $logger->info("Returning active servant for object_id");
    my ( $self, $oid ) = @_;
    my $skel;
    if ( !$oid ) {
	    $logger->fatal("CORBA::BAD_PARAM");
	    throw new CORBA::BAD_PARAM;
    }
    ( undef, $skel ) = _find_obj_by_id($oid);

    # TODO This should be OBJECT_NOT_ACTIVE
    if ( !$skel ) {
		$logger->fatal("CORBA::OBJECT_NOT_EXIST");
	    throw new CORBA::OBJECT_NOT_EXIST;
    }
    return $skel;
}

=pod

=begin testing

ok( CORBA::BOA->new->set_object_id, "Testing object adaptor's set_object_id method" );

=end testing

=cut

#############################################################################
#
# set_object_id: Change an object's id.
#                Currently there is no way in the POA spec to change the
#                ID of an object once it has been activated, thus the
#                existence of this function.
#
#############################################################################
sub set_object_id {
    $logger->info("Changing object's id");
    my ( $self, $impl, $id, $no_type ) = @_;
    my $count = 0;
    $impl or throw CORBA::BAD_PARAM->new( 'minor' => 1 );
    $id   or throw CORBA::BAD_PARAM->new( 'minor' => 2 );
    $id = $skel->_interface . " " . $id unless $no_type;
    if ( _find_obj_by_id($id) ) {

        # Object is already active
        #
        # TODO Should be SERVANT_ALREADY_ACTIVE
        $logger->fatal("CORBA::INV_OBJREF");
        throw CORBA::INV_OBJREF->new( 'minor' => 1 );
    }
    foreach my $client ( $global_client, values %{ $self->{'clients'} } ) {
        if ( $skel = $client->{'skeletons'}{$impl} ) {

            # Remove the old ID and insert the new one
            delete $client->{'objects'}{ $skel->{id} };
            $skel->{'id'}               = $id;
            $client->{'objects'}{$id}   = $skel;
            $skel->{'ior'}              = undef;
            $count++;
        }
    }
    if ( !$count ) {
		$logger->fatal("CORBA::OBJECT_NOT_EXIST");
	    throw new CORBA::OBJECT_NOT_EXIST;
    }
}

=pod

=begin testing

ok( CORBA::BOA->new->_find_obj_by_id, "Testing object adaptor's _find_obj_by_id method" );

=end testing

=cut

#############################################################################
#
# _find_obj_by_id: Internal routine to locate first client with an
#                  instance of an object with a given key.
#
# Looks for the key in the specified subpart of the client; the 'objects'
# hash by default.
#############################################################################
sub _find_obj_by_id {
    $logger->debug("Finding object by id");
    my ( $key, $part ) = @_;
    if ( !$part ) {
        $part = 'objects';
    }
    my $boa = $CORBA::BOA::_The_Boa;
    my $client;
    my $skel;
    foreach $client ( $global_client, values %{ $boa->{'clients'} } ) {
        if ( $skel = $client->{$part}{$key} ) {
            return ( $client, $skel );
        }
    }
    return ( undef, undef );
}

=pod

=begin testing

ok( CORBA::BOA->new->_oid_to_interface, "Testing object adaptor's _oid_to_interface method" );

=end testing

=cut

# Extract IDL interface spec from an object_id
sub _oid_to_interface {
    $logger->debug("Extracting IDL interface from object ID");
    my ( $self, $oid ) = @_;
    $oid =~ s/(.*?)[ ].*/$1/o;
    return $oid;
}

=pod

=begin testing

ok( CORBA::BOA->new->_oid_to_id, "Testing object adaptor's _oid_to_id method" );

=end testing

=cut

# Extract id from an object_id
sub _oid_to_id {
    $logger->debug("Extracting id from object ID");
    my ( $self, $oid ) = @_;
    $oid =~ s/.*?[ ](.*)/$1/o;
    return $oid;
}

=pod

=begin testing

ok( CORBA::BOA->new->cleanupObjectOnExit, "Testing object adaptor's cleanupObjectOnExit method" );

=end testing

=cut

#############################################################################
#
# COPE versions 0.04_x, 0.05_50 and 0.05_51 put objects that were
# created as a side effect of a CORBA object method invocation
# into a per-client object map.  Such objects were deleted when the
# client disconnected.  This function re-enables that behaviour.
#
#############################################################################
sub cleanupObjectOnExit {
    $logger->info("Re-enabling old COPE cleanup policy");
    $OMG_policy = !$_[1];
}

=pod

=begin testing

ok( CORBA::BOA::_handle_locate_request, "Testing object adaptor's CORBA::BOA::_handle_locate_request class method" );

=end testing

=cut

#############################################################################
#
# Little used GIOP message handlers.  These take a client reference.
# and return the response message (if any).
#
#############################################################################
sub CORBA::BOA::_handle_locate_request {
    $logger->debug("Handling locate request");
    my $client = shift;
    my ( $data, $index, $byte_order, $client_ind );
    $index      = 12;                       # skip the message header
    $data       = $client->{_readBuf};
    $byte_order = $client->{_byte_order};
    my $rh =
      GIOP::LocateRequestHeader::_unmarshal( \$data, \$index, $byte_order );
    my $target = CORBA::BOA::_find_target( $client, $rh->{object_key} );

    # TODO it should be possible to trap an exception and send
    # the reply with LOCATION_FORWARD status and an IOR.
    $byte_order = $CORBA::BOA::_The_Boa->{byte_order};

    # Marshal the GIOP header and reply in-line with crude efficiency.
    my $reply = "GIOP\1\0";                 # Identify GIOP version 1.0
    $reply .= ( $byte_order ? "\1" : "\0" ) . chr(GIOP::LocateReply);
    $reply .= '1234';                       # Place holder for message length.
    $index = 12;

    # Marshal request id and status
    CORBA::ORB::_marshal_ulong( \$reply, \$index, $byte_order,
        $rh->{request_id} );
    CORBA::ORB::_marshal_ulong( \$reply, \$index, $byte_order,
        $target
        ? GIOP::OBJECT_HERE
        : GIOP::UNKNOWN_OBJECT );

    # Plug in the message length.
    my ( $t_index, $t_buf ) = ( 0, '' );
    CORBA::ORB::_marshal_ulong( \$t_buf, \$t_index, $byte_order, $index - 12 );
    substr( $reply, 8, 4, $t_buf );
    return $reply;
}

=pod

=begin testing

ok( CORBA::BOA::_bad_GIOP, "Testing object adaptor's CORBA::BOA::_bad_GIOP class method" );

=end testing

=cut

sub CORBA::BOA::_bad_GIOP {
    my $client = shift;
    $logger->warn("Bad GIOP message type: $client->{_msgHdr}{message_type}");
    print STDERR "Bad GIOP message type: $client->{_msgHdr}{message_type}\n";
    return undef;
}

=pod

=begin testing

ok( CORBA::BOA::_ignore_GIOP, "Testing object adaptor's CORBA::BOA::_ignore_GIOP class method" );

=end testing

=cut

sub CORBA::BOA::_ignore_GIOP {
    $logger->debug("Ignoring GIOP");
    return undef;
}

# Initialise array of GIOP message handlers
@CORBA::BOA::GIOP_handlers = (
    \&CORBA::BOA::_handle_request,          # Request
    \&CORBA::BOA::_bad_GIOP,                # Reply
    \&CORBA::BOA::_ignore_GIOP,             # Cancel request
    \&CORBA::BOA::_handle_locate_request    # Location request
          # TODO Need to handle Close connection, Message error and Fragment
);
1;

__END__

=head1 NAME

CORBA::BOA

A class to ...

=head1 SYNOPSIS

use CORBA::BOA;

=head1 DESCRIPTION

The CORBA::BOA class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 new (constructor)

Parameters:
    class
    orb
    argv
    boa_identifier

Insert description of constructor here...

=head2 create (method)

Parameters:
    id
    intf
    impl

Insert description of method here...

=head2 _create (constructor)

Parameters:
    id

Insert description of constructor here...

=head2 dispose (method)

Parameters:
    obj

Insert description of method here...

=head2 get_id (method)

Parameters:
    obj

Insert description of method here...

=head2 change_implementation (method)

Parameters:
    obj
    impl

Insert description of method here...

=head2 impl_is_ready (method)

Parameters:
    impl

Insert description of method here...

=head2 deactivate_impl (method)

Parameters:
    impl

Insert description of method here...

=head2 _add_listener (method)

Parameters:
    sock
    defaults

Insert description of method here...

=head2 _remove_client (method)

Parameters:
    client

Insert description of method here...

=head2 _close_all_listeners (method)

Parameters:
    none

Insert description of method here...

=head2 _pre_callback (method)

Parameters:
    funcref

Insert description of method here...

=head2 _post_callback (method)

Parameters:
    funcref
    client
    client
    object_key

Arguments:
    $_[0]

Insert description of method here...

=head2 get_servant (method)

Parameters:
    type

Insert description of method here...

=head2 set_servant (method)

Parameters:
    type
    servant

Insert description of method here...

=head2 activate_object (method)

Parameters:
    servant

Insert description of method here...

=head2 activate_object_with_id (method)

Parameters:
    oid
    servant
    no_type

Insert description of method here...

=head2 deactivate_object (method)

Parameters:
    oid

Insert description of method here...

=head2 create_reference (method)

Parameters:
    interface

Insert description of method here...

=head2 create_reference_with_id (method)

Parameters:
    oid
    interface
    no_type

Insert description of method here...

=head2 _object_id (method)

Parameters:
    servant

Insert description of method here...

=head2 servant_to_id (method)

Parameters:
    servant

Insert description of method here...

=head2 servant_to_reference (method)

Parameters:
    servant

Insert description of method here...

=head2 reference_to_servant (method)

Parameters:
    skel

Insert description of method here...

=head2 reference_to_id (method)

Parameters:
    skel

Insert description of method here...

=head2 id_to_servant (method)

Parameters:
    oid

Insert description of method here...

=head2 id_to_reference (method)

Parameters:
    oid

Insert description of method here...

=head2 set_object_id (method)

Parameters:
    impl
    id
    no_type

Insert description of method here...

=head2 _find_obj_by_id

Parameters:
    key
    part

Insert description of subroutine here...

=head2 _oid_to_interface (method)

Parameters:
    oid

Insert description of method here...

=head2 _oid_to_id (method)

Parameters:
    oid

Insert description of method here...

=head2 cleanupObjectOnExit (method)

Parameters:
    client
    client

Arguments:
    $_[0]
    $_[1]

Insert description of method here...

=head1 FILES

Files used by the CORBA::BOA class ...

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut