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

# Copyright (c) 1999 Seamus Twomey.  Modified (1999) by Giles Atkinson.
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
# This module is an extension to TypeCode.pm.  It contains the code for
# marshalling type codes and will normally be loaded by CORBA::ORB::AUTOLOAD.
# TODO more Test::Inline tests
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package CORBA::TypeCode;
use strict;

my $logger = Log::Log4perl::get_logger('COPE.TypeCode');

# This function does the real work of marshalling type codes.
# It is called by CORBA::ORB::_marshal_typecode.
sub _int_marshal {
    $logger->info("Marshalling type codes");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $tc                   = pop;
    my $kind                 = $tc->kind;
    CORBA::ORB::_marshal_ulong( @_, $kind );
    if ( $kind == &tk_indirect ) {
        my ( $out, $index, $byte_order ) = @_;
        my $offset;

        # Find the offset to this type code in %$tc_hash using
        # as key either the type id (if defined) or the text value
        # of the typecode reference (not as reliable).
        my $id = $tc->[&TCI_INDIRECT]->[&TCI_ID];
        $id = "$tc->[&TCI_INDIRECT]" unless defined($id);
        if ( !defined( $offset = $tc_hash->{$id} ) ) {
            $logger->fatal("Couldn't find indirected type ($id) for marshalling.");
            die "Couldn't find indirected type ($id) for marshalling.";
        }
        my $diff = $offset - ( $encapsulation_offset + $$index );
        CORBA::ORB::_marshal_long( @_, $diff );
        return;
    }
    if ( $kind <= &tk_Principal
        || ( $kind >= &tk_longlong && $kind <= &tk_ulonglong ) )
    {
        return;
    }
    if ( $kind == &tk_string ) {
        CORBA::ORB::_marshal_ulong( @_, $tc->length );
        return;
    }
    else {
        my ( $out, $index, $byte_order ) = @_;
        my $offset;

        # If we get here, we have parameters in "complex" encoding.
        # We need to store the marshalled typecode offset into $tc_hash
        # to fixup possible indirects found later....
        # Find the offset to this type code in %$tc_hash, key as above.
        my $id = $tc->[&TCI_ID];
        $id = "$tc" unless defined($id);
        if ( defined( $offset = $tc_hash->{$id} ) ) {

            # Although not an indirect reference in the original type code,
            # this item is one that has already been marshalled.
            # Use an indirect reference, replacing the marshalled type kind.
            $$out = substr( $$out, 0, -4 );
            $$index -= 4;
            CORBA::ORB::_marshal_ulong( $out, $index, $byte_order, 0xFFFFFFFF );
            my $diff = $offset - ( $encapsulation_offset + $$index );
            CORBA::ORB::_marshal_long( @_, $diff );
            return;
        }

        # The type code has not been marshalled already within
        # the outermost enclosing call, store offset for back references.
        # Subtract 4 for $kind which has been marshalled already
        $tc_hash->{$id} = $$index + $encapsulation_offset - 4;
        my ( $tmpout, $tmpindex ) = ( '', 0 );

        # Add extra 4 for octet stream header
        my $tmp_encap_offset = $encapsulation_offset + $$index + 4;
        @_ = ( \$tmpout, \$tmpindex, $byte_order );
        CORBA::ORB::_marshal_boolean( @_, $byte_order );
        if ( $kind == &tk_struct ) {
            _marshal_struct_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_objref ) {
            _marshal_interface_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_union ) {
            _marshal_union_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_sequence ) {
            _marshal_sequence_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_array ) {
            _marshal_array_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_alias ) {
            _marshal_alias_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_except ) {
            _marshal_except_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        elsif ( $kind == &tk_enum ) {
            _marshal_enum_tc( @_, $tc, $tc_hash, $tmp_encap_offset );
        }
        else {
            $logger->fatal("TypeCode marshalling for kind $kind not implemented yet.");
            die "TypeCode marshalling for kind $kind not implemented yet.";
        }

        # Marshal the above as an encapsulated octet sequence...
        CORBA::ORB::_marshal_octet_sequence( $out, $index, $byte_order, $tmpout,
            $tmpindex );
        return;
    }
}

sub _marshal_struct_tc {
    $logger->info("Marshalling struct type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $structtc             = pop;
    CORBA::ORB::_marshal_string( @_, $structtc->id );
    CORBA::ORB::_marshal_string( @_, $structtc->name );
    my $membercount = $structtc->member_count;
    CORBA::ORB::_marshal_ulong( @_, $membercount );
    my $memberarray = $structtc->[&TCI_MEMLIST];
    my $member_name;
    my $member_type;

    for ( my $i = 0 ; $i < $membercount ; $i++ ) {
        $member_name = $$memberarray[ $i * 2 ];
        $member_type = $$memberarray[ $i * 2 + 1 ];

        # Marshal the name
        CORBA::ORB::_marshal_string( @_, $member_name );

        # Marshal the typecode
        _int_marshal( @_, $member_type, $tc_hash, $encapsulation_offset );
    }
}

sub _marshal_interface_tc {
    $logger->info("Marshalling interface type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $iftc                 = pop;
    CORBA::ORB::_marshal_string( @_, $iftc->id );
    CORBA::ORB::_marshal_string( @_, $iftc->name );
}

sub _marshal_union_tc {
    $logger->info("Marshalling union type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $uniontc              = pop;
    CORBA::ORB::_marshal_string( @_, $uniontc->id );
    CORBA::ORB::_marshal_string( @_, $uniontc->name );

    # Discriminant type
    my $discriminant_type = $uniontc->discriminator_type;
    _int_marshal( @_, $discriminant_type, $tc_hash, $encapsulation_offset );

    # default used (long)
    CORBA::ORB::_marshal_ulong( @_, $uniontc->default_index );

    # number of types
    my $membercount = $uniontc->member_count;
    CORBA::ORB::_marshal_ulong( @_, $membercount );
    my $memberarray = $uniontc->[&TCI_MEMLIST];

    # get correct marshal routine for label marshalling
    my $index_marshal;
    if ( $discriminant_type->kind == &tk_ushort ) {
        $index_marshal = \&CORBA::ORB::_marshal_ushort;
    }
    elsif ( $discriminant_type->kind == &tk_short ) {
        $index_marshal = \&CORBA::ORB::_marshal_short;
    }
    elsif ( $discriminant_type->kind == &tk_long ) {
        $index_marshal = \&CORBA::ORB::_marshal_long;
    }
    elsif ( $discriminant_type->kind == &tk_ulong ) {
        $index_marshal = \&CORBA::ORB::_marshal_ulong;
    }
    elsif ( $discriminant_type->kind == &tk_boolean ) {
        $index_marshal = \&CORBA::ORB::_marshal_boolean;
    }
    elsif ( $discriminant_type->kind == &tk_char ) {
        $index_marshal = \&CORBA::ORB::_marshal_char;
    }
    elsif ( $discriminant_type->kind == &tk_enum ) {
        $index_marshal = \&CORBA::ORB::_marshal_enum;
    }
    my $member_name;
    my $member_type;
    my $label;
    for ( my $i = 0 ; $i < $membercount ; $i++ ) {
        $member_name = $$memberarray[ $i * 3 ];
        $member_type = $$memberarray[ $i * 3 + 1 ];
        $label       = $$memberarray[ $i * 3 + 2 ];

        # Marshal the label
        &$index_marshal( @_, $label );

        # Marshal the name
        CORBA::ORB::_marshal_string( @_, $member_name );

        # Marshal the typecode
        _int_marshal( @_, $member_type, $tc_hash, $encapsulation_offset );
    }
}

sub _marshal_sequence_tc {
    $logger->info("Marshalling sequence type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $seqtc                = pop;

    # marshal element type
    CORBA::TypeCode::_int_marshal( @_, $seqtc->content_type, $tc_hash,
        $encapsulation_offset );

    # marshal length
    CORBA::ORB::_marshal_ulong( @_, $seqtc->length );
}

sub _marshal_array_tc {
    $logger->info("Marshalling array type code");
    return _marshal_sequence_tc(@_);
}

sub _marshal_alias_tc {
    $logger->info("Marshalling alias type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $alias_tc             = pop;
    CORBA::ORB::_marshal_string( @_, $alias_tc->id );
    CORBA::ORB::_marshal_string( @_, $alias_tc->name );
    CORBA::TypeCode::_int_marshal( @_, $alias_tc->content_type, $tc_hash,
        $encapsulation_offset );
}

sub _marshal_exception_tc {
    $logger->info("Marshalling exception type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $except_tc            = pop;
    CORBA::ORB::_marshal_string( @_, $except_tc->id );
    CORBA::ORB::_marshal_string( @_, $except_tc->name );
    my $membercount = $except_tc->member_count;
    CORBA::ORB::_marshal_ulong( @_, $membercount );
    my $memberarray = $except_tc->[&TCI_MEMLIST];
    my $member_name;
    my $member_type;

    for ( my $i = 0 ; $i < $membercount ; $i++ ) {
        $member_name = $$memberarray[ $i * 2 ];
        $member_type = $$memberarray[ $i * 2 + 1 ];

        # Marshal the name
        CORBA::ORB::_marshal_string( @_, $member_name );

        # Marshal the typecode
        _int_marshal( @_, $member_type, $tc_hash, $encapsulation_offset );
    }
}

sub _marshal_enum_tc {
    $logger->info("Marshalling enum type code");
    my $encapsulation_offset = pop;
    my $tc_hash              = pop;
    my $enum_tc              = pop;
    CORBA::ORB::_marshal_string( @_, $enum_tc->id );
    CORBA::ORB::_marshal_string( @_, $enum_tc->name );
    my $membercount = $enum_tc->member_count;
    CORBA::ORB::_marshal_ulong( @_, $membercount );
    my $memberarray = $enum_tc->[&TCI_MEMLIST];

    for ( my $i = 0 ; $i < $membercount ; $i++ ) {

        # Marshal the name
        CORBA::ORB::_marshal_string( @_, $$memberarray[$i] );
    }
}

# The top-level marshalling function is in CORBA::ORB so that
# the same AUTOLOAD function can be used for all (un)marshalling code.
package CORBA::ORB;

sub _marshal_typecode {
	$logger->info("Marshalling type code");
    # Create hashtable array for storing offsets of types for resolving
    # indirect type references
    my %tc_hash;
    pop;    # TypeCode TypeCode.
    return CORBA::TypeCode::_int_marshal( @_, \%tc_hash, 0 );
}
1;

__END__

=head1 NAME

CORBA::ORB

A class to ...

=head1 SYNOPSIS

use CORBA::ORB;

=head1 DESCRIPTION

The CORBA::ORB class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 _int_marshal

Parameters:
    out
    index
    byte_order
    out
    index
    byte_order

Insert description of subroutine here...

=head2 _marshal_struct_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_interface_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_union_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_sequence_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_array_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_alias_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_exception_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_enum_tc

Parameters:
    none

Insert description of subroutine here...

=head2 _marshal_typecode

Parameters:
    none

Insert description of subroutine here...

=head1 FILES

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

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut