# $Id: ORB.pm 1801 2006-07-29 09:20:22Z rvosa $
# Subversion: $Rev: 117 $

# Copyright (c) 1997 Lunatech Research / Bart Schuller <schuller@lunatech.com>
# Modifications 1997-2000 Copyright by contributors listed in the file Changes.
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
# interface ORB
use Log::Log4perl;
use Log::Log4perl::JavaMap::ConsoleAppender;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package COPE::CORBA::ORB;

BEGIN {
    our $LOGPERLCONF = {
        'log4j.rootLogger' => 'WARN, A1',
        'log4j.appender.A1' => 'org.apache.log4j.ConsoleAppender',
        'log4j.appender.A1.layout' => 'org.apache.log4j.PatternLayout',
        'log4j.appender.A1.layout.ConversionPattern' => '%-4r %-5p %c %x - %m%n',
    };
}

sub LOGPERLCONF {
    $ENV{'LOGPERLCONF'} && -T $ENV{'LOGPERLCONF'} ?
	return $ENV{'LOGPERLCONF'} :
	return $LOGPERLCONF;
}

package CORBA::ORB;
$CORBA::ORB::_The_Orb = 0;
use strict;

#use Carp;
use COPE::CORBA::TypeCode;
use COPE::CORBA::TCKind;
use COPE::CORBA::Exception;

my $logger = Log::Log4perl::get_logger('CORBA.ORB');
my ( $_byte_order,  $_ieee_float );
my ( %initial_refs, $default_ref_pfx );   # For list/resolve_initial_services().

# Determine the byte order and make a simple test for
# the IEEE floating point format.
BEGIN {
    $logger = Log::Log4perl::get_logger('CORBA.ORB');
    if ( pack( 'N', 1 ) eq pack( 'L', 1 ) ) {

        # Big-endian
        $_byte_order = 0;
        if (   unpack( 'f', pack( "H*", 'c2c94000' ) ) == -100.625
            && unpack( 'd', pack( "H*", '4130000080000000' ) ) == 1048576.5 )
        {
            $_ieee_float = 1;
        }
    }
    else {
        $_byte_order = 1;
        if (   unpack( 'f', pack( "H*", '0040c9c2' ) ) == -100.625
            && unpack( 'd', pack( "H*", '0000008000003041' ) ) == 1048576.5 )
        {
            $_ieee_float = 1;
        }
    }
}
$COPE::_byte_order = $_byte_order;    # For autoloaded modules

# This loads the less commonly-used (un)marshalling functions on demand.
sub AUTOLOAD {
    my $sub = $CORBA::ORB::AUTOLOAD;
    if ( $sub =~ /::DESTROY$/ ) {
        return;
    }
    unless ( $sub =~ s/^CORBA::ORB::// ) {
        $logger->fatal("Nonexistent function $sub");
        die "Nonexistent function $sub";
    }
    if ( $sub =~ /_(?:un)?marshal_u?longlong/ ) {
        require COPE::CORBA::LongLong;
    }
    elsif ( $sub =~ /_(?:un)?marshal_any/ ) {
        require COPE::CORBA::Any;
    }
    elsif ( $sub =~ /_marshal_typecode/ ) {
        require COPE::CORBA::TCMarshal;
    }
    elsif ( $sub =~ /string_to_object/ ) {
        require COPE::CORBA::StrToObj;
    }
    #$logger->debug("AUTOLOAD'ing \"$sub\"");
    goto &{$CORBA::ORB::AUTOLOAD};
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_nothing, "Testing CORBA::ORB _marshal_nothing method" );
#
#=end testing

sub _marshal_nothing {
	$logger->debug("Marshalling nothing");
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_boolean, "Testing CORBA::ORB _marshal_boolean method" );
#
#=end testing

sub _marshal_boolean {
    $logger->debug("Marshalling boolean");
    my ( $out, $index, $byte_order, $data ) = @_;
    $$out .= $data ? "\1" : "\0";
    $$index++;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_octet, "Testing CORBA::ORB _marshal_octet method" );
#
#=end testing

sub _marshal_octet {
    $logger->debug("Marshalling octet");
    my ( $out, $index, $byte_order, $data ) = @_;
    $$out .= pack( 'C', $data );
    $$index++;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_char, "Testing CORBA::ORB _marshal_char method" );
#
#=end testing

sub _marshal_char {
    $logger->debug("Marshalling char");
    my ( $out, $index, $byte_order, $data ) = @_;
    $$out .= pack( 'a', $data );
    $$index++;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_ushort, "Testing CORBA::ORB _marshal_ushort method" );
#
#=end testing

sub _marshal_ushort {
    $logger->debug("Marshalling unsigned short");
    my ( $out, $index, $byte_order, $data ) = @_;
    my $previndex = $$index;
    $$index = ( 1 + $$index ) & ~1;
    $$out .=
      "\0" x ( $$index - $previndex ) . pack( $byte_order ? 'v' : 'n', $data );
    $$index += 2;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_short, "Testing CORBA::ORB _marshal_short method" );
#
#=end testing

sub _marshal_short {
	$logger->debug("Marshalling short");
	_marshal_ushort(@_)
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_ulong, "Testing CORBA::ORB _marshal_ulong method" );
#
#=end testing

sub _marshal_ulong {
    $logger->debug("Marshalling unsigned long");
    my ( $out, $index, $byte_order, $data ) = @_;
    if ( !defined($data) ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_ulong,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    my $previndex = $$index;
    $$index = ( 3 + $$index ) & ~3;
    $$out .=
      "\0" x ( $$index - $previndex ) . pack( $byte_order ? 'V' : 'N', $data );
    $$index += 4;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_long, "Testing CORBA::ORB _marshal_long method" );
#
#=end testing

sub _marshal_long {
	$logger->debug("Marshalling long");
	_marshal_ulong(@_)
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_enum, "Testing CORBA::ORB _marshal_enum method" );
#
#=end testing

sub _marshal_enum {
	$logger->debug("Marshalling enum");
	_marshal_ulong(@_)
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_float, "Testing CORBA::ORB _marshal_float method" );
#
#=end testing

sub _marshal_float {
    $logger->debug("Marshalling float");
    my ( $out, $index, $byte_order, $data ) = @_;
    if ( !$_ieee_float ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::NO_IMPLEMENT->new(
            minor     => tk_float,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    if ( !defined($data) ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_float,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    my $previndex = $$index;
    $$index = ( 3 + $$index ) & ~3;
    $$out .= "\0" x ( $$index - $previndex );
    my $rep = pack( 'f', $data );
    $rep = reverse($rep) if $byte_order xor $_byte_order;    # Redundant?
    $$out .= $rep;
    $$index += 4;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_double, "Testing CORBA::ORB _marshal_double method" );
#
#=end testing

sub _marshal_double {
    $logger->debug("Marshalling double");
    my ( $out, $index, $byte_order, $data ) = @_;
    if ( !$_ieee_float ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::NO_IMPLEMENT->new(
            minor     => tk_double,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    if ( !defined($data) ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_double,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    my $previndex = $$index;
    $$index = ( 7 + $$index ) & ~7;
    $$out .= "\0" x ( $$index - $previndex );
    my $rep = pack( 'd', $data );
    $rep = reverse($rep) if $byte_order xor $_byte_order;    # Redundant?
    $$out .= $rep;
    $$index += 8;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_octet_array, "Testing CORBA::ORB _marshal_octet_array method" );
#
#=end testing

sub _marshal_octet_array {
    $logger->debug("Marshalling octet array");
    my ( $out, $index, $byte_order, $data, $length ) = @_;
    $$out .= pack( "a$length", $data );
    $$index += $length;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_char_array, "Testing CORBA::ORB _marshal_char_array method" );
#
#=end testing

sub _marshal_char_array {
	$logger->debug("Marshalling char array");
	_marshal_octet_array(@_)
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_string, "Testing CORBA::ORB _marshal_string method" );
#
#=end testing

sub _marshal_string {
    $logger->debug("Marshalling string");
    my ( $out, $index, $byte_order, $data, $tc ) = @_;
    my $len;
    if ($tc) {
        $len = $tc->length;
        $data = substr( $data, 0, $len ) if $len;
    }
    $data .= "\0";
    $len = length($data);
    _marshal_ulong( $out, $index, $byte_order, $len );
    $$out .= $data;
    $$index += $len;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_octet_sequence, "Testing CORBA::ORB _marshal_octet_sequence method" );
#
#=end testing

sub _marshal_octet_sequence {
    $logger->debug("Marshalling octet sequence");
    my ( $out, $index, $byte_order, $data, $length ) = @_;
    $length = length($data) unless $length && length($data) > $length;
    _marshal_ulong( $out, $index, $byte_order, $length );
    $$out .= substr( $data, 0, $length );
    $$index += $length;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_char_sequence, "Testing CORBA::ORB _marshal_char_sequence method" );
#
#=end testing

sub _marshal_char_sequence {
    $logger->debug("Marshalling char sequence");
    _marshal_octet_sequence(@_);
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_sequence_using_tc, "Testing CORBA::ORB _marshal_sequence_using_tc method" );
#
#=end testing

sub _marshal_sequence_using_tc {
    $logger->debug("Marshalling sequence using type code");
    my $tc     = pop;
    my $ct     = $tc->content_type();
    my $length = $tc->length();

    # Throw error if someone messed up their object types
    if ( !defined($ct) ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_NO");
        CORBA::BAD_PARAM->new(
            minor     => tk_sequence,
            completed => 'CORBA::CompletionStatus::COMPLETED_NO'
        )->throw();
    }
    my $ckind = $ct->kind();
    if ( $ckind == tk_octet || $ckind == tk_char ) {
        _marshal_octet_sequence( @_, $length );
        return;
    }
    my $seq = pop;
    $length = scalar(@$seq) if !$length || $length > scalar(@$seq);
    _marshal_ulong( @_, $length );
    for ( my $ix = 0 ; $ix < $length ; ++$ix ) {
        _marshal_using_tc( @_, $seq->[$ix], $ct );
    }
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_object, "Testing CORBA::ORB _marshal_object method" );
#
#=end testing

sub _marshal_object {
    $logger->debug("Marshalling object");
    pop;    # Pop TC.
    my $obj = pop;
    IOP::IOR::_marshal( @_, $CORBA::ORB::_The_Orb->_object_to_IOR($obj) );
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_struct, "Testing CORBA::ORB _marshal_struct method" );
#
#=end testing

sub _marshal_struct {
    $logger->debug("Marshalling struct");
    my $tc     = pop;
    my $struct = pop;
    my $count  = $tc->member_count;
    for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
        my $fname = $tc->member_name($counter);
        if ( !exists( $struct->{$fname} ) ) {
            $logger->warn("Structure missing field $fname");
            $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
            CORBA::MARSHAL->new(
                minor     => $counter,
                completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
            )->throw();
        }
        _marshal_using_tc( @_, $struct->{$fname}, $tc->member_type($counter) );
    }
}

#=begin testing
#
#ok( CORBA::ORB::_union_type, "Testing CORBA::ORB _union_type method" );
#
#=end testing

# Helper function for (un)marshalling union values.
sub _union_type {
    $logger->debug("Looking up union type");
    my ( $tc, $discrim ) = @_;
    my $discriminator_kind = $tc->discriminator_type->kind;
    my $count              = $tc->member_count;
    for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
        my $member_label = $tc->member_label($counter);
        if (
            ( $discriminator_kind == tk_char )
            ? $member_label eq $discrim
            : $member_label == $discrim
          )
        {
            return $tc->member_type($counter);
        }
    }
    my $default = $tc->default_index;
    if ( $default >= 0 ) {
        return $tc->member_type($default);
    }
    $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
    CORBA::MARSHAL->new(
        completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE' )->throw();
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_union, "Testing CORBA::ORB _marshal_union method" );
#
#=end testing

sub _marshal_union {
    $logger->debug("Marshalling union");
    my $tc                 = pop;
    my $union              = pop;
    my $discriminator_type = $tc->discriminator_type;
    my $discrim            = $union->[0];
    _marshal_using_tc( @_, $discrim, $discriminator_type );
    _marshal_using_tc( @_, $union->[1], _union_type( $tc, $discrim ) );
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_array, "Testing CORBA::ORB _marshal_array method" );
#
#=end testing

sub _marshal_array {
    $logger->debug("Marshalling array");
    my $tc     = pop;
    my $ct     = $tc->content_type();
    my $ckind  = $ct->kind();
    my $length = $tc->length();
    if ( $ckind == tk_octet || $ckind == tk_char ) {
        _marshal_octet_array( @_, $length );
        return;
    }
    my $array = pop;
    for ( my $i = 0 ; $i < $length ; $i++ ) {
        _marshal_using_tc( @_, $array->[$i], $ct );
    }
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_exception, "Testing CORBA::ORB _marshal_exception method" );
#
#=end testing

sub _marshal_exception {
    $logger->debug("Marshalling exception");
    my $tc     = pop;
    my $except = pop;
    my $count  = $tc->member_count;
    _marshal_string( @_, $tc->id(), 0 );
    for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
        _marshal_using_tc(
            @_,
            $except->{ $tc->member_name($counter) },
            $tc->member_type($counter)
        );
    }
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_indirect, "Testing CORBA::ORB _marshal_indirect method" );
#
#=end testing

sub _marshal_indirect {
    $logger->debug("Marshalling indirect");
    my $tc = pop;
    _marshal_using_tc( @_, $tc->[CORBA::TypeCode::TCI_INDIRECT] );
    return;
}

#=begin testing
#
#ok( CORBA::ORB::_marshal_alias, "Testing CORBA::ORB _marshal_alias method" );
#
#=end testing

sub _marshal_alias {
    $logger->debug("Marshalling alias");
    my $tc = pop;
    _marshal_using_tc( @_, $tc->[CORBA::TypeCode::TCI_CONTENT] );
    return;
}

# Now all the marshalling routines are defined, create an array of references
# for fast access by type code kind.  This starts with the non-OMG value
# tk_indirect, which is -1
@COPE::marshalers = (
    \&_marshal_indirect,
    \&_marshal_nothing,    # null
    \&_marshal_nothing,    # void
    \&_marshal_ushort,     # short (really!)
    \&_marshal_ulong,      # long (really!)
    \&_marshal_ushort,
    \&_marshal_ulong,
    \&_marshal_float,
    \&_marshal_double,
    \&_marshal_boolean,
    \&_marshal_char,
    \&_marshal_octet,
    \&_marshal_any,
    \&_marshal_typecode,
    \13,                             # principal
    \&_marshal_object,               # objref
    \&_marshal_struct,
    \&_marshal_union,
    \&_marshal_ulong,                # enum
    \&_marshal_string,
    \&_marshal_sequence_using_tc,    # sequence
    \&_marshal_array,
    \&_marshal_alias,
    \&_marshal_exception,            # except
    \&_marshal_longlong,
    \&_marshal_ulonglong,
    \25,                             # long double
    \26,                             # wchar
    \27,                             # wstring
    \28                              # fixed
);

#=begin testing
#
#ok( CORBA::ORB::_marshal_sequence, "Testing CORBA::ORB _marshal_sequence method" );
#
#=end testing

# Special function for marshalling sequences of known type.
sub _marshal_sequence {
    $logger->debug("Marshalling sequence");
    my ( $out, $index, $byte_order, $data, $_marshal, @extra ) = @_;
    _marshal_ulong( $out, $index, $byte_order, scalar(@$data) );
    foreach my $item (@$data) {
        &$_marshal( $out, $index, $byte_order, $item, @extra );
    }
}

#=begin testing
#
#ok( CORBA::ORB::_unmarshal_string, "Testing CORBA::ORB _unmarshal_string method" );
#
#=end testing

sub _unmarshal_string {
    $logger->debug("Unmarshalling string");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL(
            minor     => tk_string,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $length = unpack( $byte_order ? 'V' : 'N', substr( $$in, $$index, 4 ) );
    $$index += 4;
    my $string = substr( $$in, $$index, $length - 1 );
    $$index += $length;
    return $string;
}

#=begin testing
#
#ok( CORBA::ORB::_unmarshal_octet_sequence, "Testing CORBA::ORB _unmarshal_octet_sequence method" );
#
#=end testing

sub _unmarshal_octet_sequence {
    $logger->debug("Unmarshalling octet sequence");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_sequence,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $length = unpack( $byte_order ? 'V' : 'N', substr( $$in, $$index, 4 ) );
    $$index += 4;
    my $string = substr( $$in, $$index, $length );
    $$index += $length;
    return $string;
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_char, "Testing CORBA::ORB _unmarshal_char method" );

=end testing

=cut

sub _unmarshal_char {
    $logger->debug("Unmarshalling char");
    my ( $in, $index, $byte_order ) = @_;
    return substr( $$in, $$index++, 1 ) if ($$in);
    $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
    CORBA::MARSHAL->new(
        minor     => tk_char,
        completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
    )->throw();
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_octet, "Testing CORBA::ORB _unmarshal_octet method" );

=end testing

=cut

sub _unmarshal_octet {
    $logger->debug("Unmarshalling octet");
    my ( $in, $index, $byte_order ) = @_;
    return unpack( 'C', substr( $$in, $$index++, 1 ) ) if ($$in);
    $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
    CORBA::MARSHAL->new(
        minor     => tk_octet,
        completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
    )->throw();
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_boolean, "Testing CORBA::ORB _unmarshal_boolean method" );

=end testing

=cut

sub _unmarshal_boolean {
	$logger->debug("Unmarshalling boolean");
	_unmarshal_octet(@_)
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_octet_array, "Testing CORBA::ORB _unmarshal_octet_array method" );

=end testing

=cut

sub _unmarshal_octet_array {
    $logger->debug("Unmarshalling octet array");
    my ( $in, $index, $byte_order, $length ) = @_;
    my $oldindex = $$index;
    $$index += $length;
    return substr( $$in, $oldindex, $length ) if ($$in);
    $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
    CORBA::MARSHAL->new(
        minor     => tk_array,
        completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
    )->throw();
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_char_array, "Testing CORBA::ORB _unmarshal_char_array method" );

=end testing

=cut

sub _unmarshal_char_array {
	$logger->debug("Unmarshalling char array");
	_unmarshal_octet_array(@_)
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_ushort, "Testing CORBA::ORB _unmarshal_ushort method" );

=end testing

=cut

sub _unmarshal_ushort {
    $logger->debug("Unmarshalling unsigned short");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_ushort,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 1 + $$index ) & ~1;
    my $short = unpack( $byte_order ? 'v' : 'n', substr( $$in, $$index, 2 ) );
    $$index += 2;
    return $short;
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_short, "Testing CORBA::ORB _unmarshal_short method" );

=end testing

=cut

sub _unmarshal_short {
    $logger->debug("Unmarshalling short");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_short,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 1 + $$index ) & ~1;
    my $tmp = substr( $$in, $$index, 2 );
    if ( $byte_order xor $_byte_order ) {
        $tmp = pack( 'v', unpack( 'n', $tmp ) );
    }
    my $short = unpack( 's', $tmp );
    $$index += 2;
    return $short;
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_ulong, "Testing CORBA::ORB _unmarshal_ulong method" );

=end testing

=cut

sub _unmarshal_ulong {
    $logger->debug("Unmarshalling unsigned long");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_ulong,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $long = unpack( $byte_order ? 'V' : 'N', substr( $$in, $$index, 4 ) );
    $$index += 4;
    return $long;
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_long, "Testing CORBA::ORB _unmarshal_long method" );

=end testing

=cut

sub _unmarshal_long {
    $logger->debug("Unmarshalling long");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_long,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $tmp = substr( $$in, $$index, 4 );
    if ( $byte_order xor $_byte_order ) {
        $tmp = pack( 'V', unpack( 'N', $tmp ) );
    }
    $$index += 4;
    return unpack( 'l', $tmp );
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_enum, "Testing CORBA::ORB _unmarshal_enum method" );

=end testing

=cut

sub _unmarshal_enum {
	$logger->debug("Unmarshalling enum");
	_unmarshal_ulong(@_)
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_float, "Testing CORBA::ORB _unmarshal_float method" );

=end testing

=cut

sub _unmarshal_float {
    $logger->debug("Unmarshalling float");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$_ieee_float ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::NO_IMPLEMENT->new(
            minor     => tk_float,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_float,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $tmp = substr( $$in, $$index, 4 );
    if ( $byte_order xor $_byte_order ) {
        $tmp = reverse($tmp);
    }
    $$index += 4;
    return unpack( 'f', $tmp );
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_double, "Testing CORBA::ORB _unmarshal_double method" );

=end testing

=cut

sub _unmarshal_double {
    $logger->debug("Unmarshalling double");
    my ( $in, $index, $byte_order ) = @_;
    if ( !$_ieee_float ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::NO_IMPLEMENT->new(
            minor     => tk_double,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_double,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 7 + $$index ) & ~7;
    my $tmp = substr( $$in, $$index, 8 );
    if ( $byte_order xor $_byte_order ) {
        $tmp = reverse($tmp);
    }
    $$index += 8;
    return unpack( 'd', $tmp );
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_sequence, "Testing CORBA::ORB _unmarshal_sequence method" );

=end testing

=cut

sub _unmarshal_sequence {
    $logger->debug("Unmarshalling sequence");
    my ( $in, $index, $byte_order, $_unmarshal, @extra ) = @_;
    if ( !$$in ) {
        $logger->fatal("CORBA::CompletionStatus::COMPLETED_MAYBE");
        CORBA::MARSHAL->new(
            minor     => tk_sequence,
            completed => 'CORBA::CompletionStatus::COMPLETED_MAYBE'
        )->throw();
    }
    $$index = ( 3 + $$index ) & ~3;
    my $num = unpack( $byte_order ? 'V' : 'N', substr( $$in, $$index, 4 ) );
    $$index += 4;
    my @self = ();
    for ( my $c = 0 ; $c < $num ; $c++ ) {
        push @self, &$_unmarshal( $in, $index, $byte_order, @extra );
    }
    return \@self;
}

=pod

=begin testing

ok( CORBA::ORB::_marshal_using_tc, "Testing CORBA::ORB _marshal_using_tc method" );

=end testing

=cut

sub _marshal_using_tc {
	$logger->debug("Marshalling using type code");
    &{ $COPE::marshalers[ $_[-1]->[CORBA::TypeCode::TCI_KIND] + 1 ] };
}

=pod

=begin testing

ok( CORBA::ORB::_unmarshal_using_tc, "Testing CORBA::ORB _unmarshal_using_tc method" );

=end testing

=cut

sub _unmarshal_using_tc {
    $logger->debug("Unmarshalling using type code");
    # is undefined if no type code has been created
    # using _new_type_impl and _create_<something>_tc
    my $tc = pop;
    my ( $inref, $indexref, $byte_order ) = @_;

    #confess if !defined($tc);
    my $kind = $tc->kind;
    if ( $kind == tk_void || $kind == tk_null ) { return }
    if ( $kind == tk_short ) {
        return _unmarshal_short(@_);
    }
    if ( $kind == tk_long ) {
        return _unmarshal_long(@_);
    }
    if ( $kind == tk_ushort ) {
        return _unmarshal_ushort(@_);
    }
    if ( $kind == tk_ulong ) {
        return _unmarshal_ulong(@_);
    }
    if ( $kind == tk_boolean ) {
        return _unmarshal_boolean(@_);
    }
    if ( $kind == tk_char ) {
        return _unmarshal_char(@_);
    }
    if ( $kind == tk_float ) {
        return _unmarshal_float(@_);
    }
    if ( $kind == tk_double ) {
        return _unmarshal_double(@_);
    }
    if ( $kind == tk_octet ) {
        return _unmarshal_octet(@_);
    }
    if ( $kind == tk_struct ) {
        my $result = {};
        my $count  = $tc->member_count;
        for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
            $result->{ $tc->member_name($counter) } =
              _unmarshal_using_tc( $inref, $indexref, $byte_order,
                $tc->member_type($counter) );
        }
        return bless $result, CORBA::TypeCode::_id2package( $tc->id );
    }
    if ( $kind == tk_union ) {
        my $result             = [];
        my $discriminator_type = $tc->discriminator_type;
        my $discrim            =
          _unmarshal_using_tc( $inref, $indexref, $byte_order,
            $discriminator_type );
        $result->[0] = $discrim;
        $result->[1] =
          _unmarshal_using_tc( $inref, $indexref, $byte_order,
            _union_type( $tc, $discrim ) );
        return bless $result, CORBA::TypeCode::_id2package( $tc->id );
    }
    if ( $kind == tk_sequence ) {
        my $ct = $tc->content_type();

        # FIX Jul-25-1997
        # Throw error if someone messed up their object types
        if ( !defined($ct) ) {
            $logger->fatal("CORBA::CompletionStatus::COMPLETED_NO");
            CORBA::BAD_PARAM->new(
                minor     => tk_sequence,
                completed => 'CORBA::CompletionStatus::COMPLETED_NO'
            )->throw();
        }
        my $ckind = $ct->kind();
        if ( $ckind == tk_octet || $ckind == tk_char ) {
            return _unmarshal_octet_sequence(@_);
        }
        my $result = [];
        my $count  = _unmarshal_ulong(@_);
        for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
            $result->[$counter] =
              _unmarshal_using_tc( $inref, $indexref, $byte_order, $ct );
        }
        return $result;
    }
    if ( $kind == tk_array ) {
        my $ct    = $tc->content_type();
        my $count = $tc->length();
        my $ckind = $ct->kind();
        if ( $ckind == tk_octet || $ckind == tk_char ) {
            return _unmarshal_octet_array( $inref, $indexref, $byte_order,
                $count );
        }
        my $result = [];
        for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
            $result->[$counter] =
              _unmarshal_using_tc( $inref, $indexref, $byte_order, $ct );
        }
        return $result;
    }
    if ( $kind == tk_alias ) {
        return _unmarshal_using_tc( $inref, $indexref, $byte_order,
            $tc->[CORBA::TypeCode::TCI_CONTENT] );
    }
    if ( $kind == tk_string ) {
        return _unmarshal_string(@_);
    }
    if ( $kind == tk_TypeCode ) {
        return CORBA::TypeCode::_unmarshal(@_);
    }
    if ( $kind == tk_enum ) {
        return _unmarshal_enum(@_);
    }
    if ( $kind == tk_objref ) {
        my $ior    = IOP::IOR::_unmarshal(@_);
        my $object = CORBA::Object->_new_from_ior($ior);
        return bless $object, CORBA::TypeCode::_id2package( $tc->id );
    }
    if ( $kind == tk_except ) {
        my $result = {};
        my $count  = $tc->member_count;
        for ( my $counter = 0 ; $counter < $count ; $counter++ ) {
            $result->{ $tc->member_name($counter) } =
              _unmarshal_using_tc( $inref, $indexref, $byte_order,
                $tc->member_type($counter) );
        }
        return bless $result, CORBA::TypeCode::_id2package( $tc->id );
    }
    if ( $kind == tk_any ) {
        return _unmarshal_any( @_, $CORBA::_tc_any );    # New style
    }
    if ( $kind == tk_indirect ) {
        return _unmarshal_using_tc( $inref, $indexref, $byte_order,
            $tc->[CORBA::TypeCode::TCI_INDIRECT] );
    }
    if ( $kind == tk_longlong ) {
        return _unmarshal_longlong(@_);
    }
    if ( $kind == tk_ulonglong ) {
        return _unmarshal_ulonglong(@_);
    }
    $logger->fatal("Kind $kind not implemented");
    die "Kind $kind not implemented";
}

=pod

=begin testing

ok( CORBA::ORB::BOA_init, "Testing CORBA::ORB BOA_init method" );

=end testing

=cut

sub BOA_init {
	$logger->info("Initializing object adaptor");
    # Load the module, if it's not in already...
    require COPE::CORBA::BOA;
    return CORBA::BOA->new(@_);
}

use COPE::IOP;
use COPE::CORBA::Object;

=pod

=begin testing

ok( CORBA::ORB::_object_to_IOR, "Testing CORBA::ORB _object_to_IOR method" );

=end testing

=cut

sub _object_to_IOR {
    $logger->debug("Generating IOR from object");
    my ( $self, $impl ) = @_;
    my $ior;
    my $obj = undef;
    if ( !$impl ) {
        return new IOP::IOR(
            type_id  => '',
            profiles => []
        );
    }
    return $impl->_ior;
}

=pod

=begin testing

ok( CORBA::ORB::object_to_string, "Testing CORBA::ORB object_to_string method" );

=end testing

=cut

sub object_to_string {
    $logger->info("Stringifying object");
    my ( $self, $impl ) = @_;
    my $m_ior = chr( $self->{byte_order} );
    my $ior   = $self->_object_to_IOR($impl);
    my $index = 1;
    IOP::IOR::_marshal( \$m_ior, \$index, $self->{byte_order}, $ior );
    my $hex = 'IOR:' . unpack( "H*", $m_ior );
    return $hex;
}

=pod

=begin testing

ok( CORBA::ORB::list_initial_services, "Testing CORBA::ORB list_initial_services method" );

=end testing

=cut

sub list_initial_services {
    $logger->info("Listing initial services");
    return [ keys(%initial_refs) ];
}

=pod

=begin testing

ok( CORBA::ORB::resolve_initial_references, "Testing CORBA::ORB resolve_initial_references method" );

=end testing

=cut

sub resolve_initial_references {
    $logger->info("Resolving initial references");
    my ( $self, $name ) = @_;
    my ( $ref, $str );
    if ( !defined( $str = $initial_refs{$name} ) ) {
        return undef unless $default_ref_pfx;
        $str = $default_ref_pfx . '/' . $name;
    }
    return $self->string_to_object($str);
}

package CORBA;

=pod

=begin testing

ok( CORBA::ORB_init, "Testing CORBA ORB_init method" );

=end testing

=cut

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

sub ORB_init {
    $logger->info("Initializing orb");
    my ( $argv, $orb_identifier ) = @_;
    my $orb = $CORBA::ORB::_The_Orb;
    return $orb if $orb;
    my ( $port, $max_sock, $env_args ) = ( 0, 65536, $ENV{COPE_DEFAULTS} );

    #
    # Check for ORB arguments and remove them from the argument list.
    #
    read_args( [ split( ' ', $env_args ) ], \$port, \$max_sock ) if $env_args;
    read_args( $argv, \$port, \$max_sock );
    $orb = {
        byte_order  => $_byte_order,
        port        => $port,
        max_sockets => $max_sock,
        name        => $orb_identifier
    };
    return $CORBA::ORB::_The_Orb = bless( $orb, 'CORBA::ORB' );
}

=pod

=begin testing

ok( CORBA::read_args, "Testing CORBA read_args method" );

=end testing

=cut

# Helper function to process command-line options.
sub read_args {
    $logger->info("Reading command line options");
    my ( $argv, $r_port, $r_max_sock ) = @_;
    if ( defined($argv) ) {
        my ( $x, $arg );
        for ( $x = 0 ; $x < $#$argv ; $x++ ) {
            $arg = $argv->[$x];
            if ( $arg eq '-ORBport' ) {
                $$r_port = $argv->[ $x + 1 ] + 0;
                $logger->debug( "-ORBport " . $argv->[ $x + 1 ] );
            }
            elsif ( $arg eq '-BOAclients' ) {
                $$r_max_sock = $argv->[ $x + 1 ] + 0;
                $logger->debug( "-BOAclients " . $argv->[ $x + 1 ] );
            }
            elsif ( $arg eq '-ORBInitRef' ) {
                my ( $name, $ref ) = ( $argv->[ $x + 1 ] =~ /^([^=]*)=(.*)/ );
                $initial_refs{$name} = $ref if ( $name && $ref );
                $logger->debug( "-ORBInitRef " . $argv->[ $x + 1 ] );
            }
            elsif ( $arg eq '-ORBDefaultInitRef' ) {
                $default_ref_pfx = $argv->[ $x + 1 ];
                $logger->debug( "-ORBDefaultInitRef " . $argv->[ $x + 1 ] );
            }
            else {
                next;
            }

            # The options above each use two arguments.
            splice( @$argv, $x--, 2 );
        }
    }
}
1;

__END__

=head1 NAME

CORBA

A class to ...

=head1 SYNOPSIS

use CORBA;

=head1 DESCRIPTION

The CORBA class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 LOGPERLCONF

Parameters:
    none

Insert description of subroutine here...

=head2 AUTOLOAD

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_nothing

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_boolean

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_octet

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_char

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_ushort

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_short

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_ulong

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_long

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_enum

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_float

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_double

Parameters:
    out
    index
    byte_order
    data

Insert description of subroutine here...

=head2 _marshal_octet_array

Parameters:
    out
    index
    byte_order
    data
    length

Insert description of subroutine here...

=head2 _marshal_char_array

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_string

Parameters:
    out
    index
    byte_order
    data
    tc

Insert description of subroutine here...

=head2 _marshal_octet_sequence

Parameters:
    out
    index
    byte_order
    data
    length

Insert description of subroutine here...

=head2 _marshal_char_sequence

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_sequence_using_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_object

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_struct

Parameters:
    none

Insert description of subroutine here...

=head2 _union_type

Parameters:
    tc
    discrim

Insert description of subroutine here...

=head2 _marshal_union

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_array

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_exception

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_indirect

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_alias

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_sequence

Parameters:
    none

Insert description of subroutine here...

=head2 _unmarshal_string

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_octet_sequence

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_char

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_octet

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_boolean

Parameters:
    none

Insert description of subroutine here...

=head2 _unmarshal_octet_array

Parameters:
    in
    index
    byte_order
    length

Insert description of subroutine here...

=head2 _unmarshal_char_array

Parameters:
    none

Insert description of subroutine here...

=head2 _unmarshal_ushort

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_short

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_ulong

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_long

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_enum

Parameters:
    none

Insert description of subroutine here...

=head2 _unmarshal_float

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_double

Parameters:
    in
    index
    byte_order

Insert description of subroutine here...

=head2 _unmarshal_sequence

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_using_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _unmarshal_using_tc (constructor)

Parameters:
    inref
    indexref
    byte_order

Insert description of constructor here...

=head2 BOA_init

Parameters:
    none

Insert description of subroutine here...

=head2 _object_to_IOR (method)

Parameters:
    impl

Insert description of method here...

=head2 object_to_string (method)

Parameters:
    impl

Insert description of method here...

=head2 list_initial_services

Parameters:
    none

Insert description of subroutine here...

=head2 resolve_initial_references (method)

Parameters:
    name

Insert description of method here...

=head2 ORB_init (constructor)

Parameters:
    argv
    orb_identifier

Insert description of constructor here...

=head2 read_args

Parameters:
    argv
    r_port
    r_max_sock

Insert description of subroutine here...

=head1 FILES

Files used by the CORBA class ...

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut