File Coverage

blib/lib/COPE/CORBA/TypeCode.pm

Criterion	Covered	Total	%
statement	11	128	8.5
branch	0	44	0.0
condition	0	15	0.0
subroutine	4	24	16.6
pod			n/a
total	15	211	7.1

# $Id: TypeCode.pm,v 1.1.1.1 1997/05/17 11:47:05 schuller Exp $
# Copyright (c) 1997 Lunatech Research / Bart Schuller
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.

package COPE::CORBA::TypeCode;
sub import {
    shift;
    my $callpkg = caller(0);
    CORBA::TypeCode->export($callpkg, @_);
}

# interface TypeCode // PIDL
package CORBA::TypeCode;
use strict;
require Exporter;
@CORBA::TypeCode::ISA = qw(Exporter);
@CORBA::TypeCode::EXPORT = qw(
                _create_struct_tc _create_union_tc _create_enum_tc
                _create_alias_tc _create_exception_tc _create_interface_tc
                _create_string_tc _create_sequence_tc
                _create_recursive_sequence_tc _create_array_tc
            );
use COPE::CORBA::TCKind;
@CORBA::_tc_basic = (
    $CORBA::_tc_null = CORBA::TypeCode->_new_basic(tk_null),
    $CORBA::_tc_void = CORBA::TypeCode->_new_basic(tk_void),
    $CORBA::_tc_short = CORBA::TypeCode->_new_basic(tk_short),
    $CORBA::_tc_long = CORBA::TypeCode->_new_basic(tk_long),
    $CORBA::_tc_ushort = CORBA::TypeCode->_new_basic(tk_ushort),
    $CORBA::_tc_ulong = CORBA::TypeCode->_new_basic(tk_ulong),
    $CORBA::_tc_float = CORBA::TypeCode->_new_basic(tk_float),
    $CORBA::_tc_double = CORBA::TypeCode->_new_basic(tk_double),
    $CORBA::_tc_boolean = CORBA::TypeCode->_new_basic(tk_boolean),
    $CORBA::_tc_char = CORBA::TypeCode->_new_basic(tk_char),
    $CORBA::_tc_octet = CORBA::TypeCode->_new_basic(tk_octet),
    $CORBA::_tc_any = CORBA::TypeCode->_new_basic(tk_any),
    $CORBA::_tc_TypeCode = CORBA::TypeCode->_new_basic(tk_TypeCode),
    $CORBA::_tc_Principal = CORBA::TypeCode->_new_basic(tk_Principal),
);

my(%has_id_and_name) = map { $_ => 1 } (tk_objref, tk_struct, tk_union, tk_enum, tk_alias, tk_except);
my(%has_members) = map { $_ => 1 } (tk_struct, tk_union, tk_enum, tk_except);
my(%has_type) = map { $_ => 1 } (tk_sequence, tk_array, tk_alias);
my(%has_length) = map { $_ => 1 } (tk_sequence, tk_array);

sub _new_basic {
    my($class, $tk) = @_;
    return bless {_kind => $tk}, $class;
}

sub _unmarshal {
    my $kind = CORBA::ORB::_unmarshal_ulong(@_);
    my $self = {};
    if ($kind <= 13) {
        return $CORBA::_tc_basic[$kind];
    } else {
        $self->{_kind} = $kind;
    }
    if ($self->{_kind} == 0xffffffff) {
        die "CORBA::TypeCode::_unmarshal got an indirection: " . CORBA::ORB::_unmarshal_ulong(@_);
    } elsif ($self->{_kind} == tk_string) {
        $self->{_length} = CORBA::ORB::_unmarshal_ulong(@_);
    } else {
#
# if we get here, we have parameters in "complex" encoding.
#
        my($byte_order) = $_[2];
        my($cdrin, $index) = ('', 0);
        $cdrin = CORBA::ORB::_unmarshal_octet_sequence(@_);
        @_ = (\$cdrin, \$index, $byte_order);
        $byte_order = $_[2] = CORBA::ORB::_unmarshal_boolean(@_);
        if ($has_id_and_name{$self->{_kind}}) {
            $self->{_id} = CORBA::ORB::_unmarshal_string(@_);
            $self->{_name} = CORBA::ORB::_unmarshal_string(@_);
        }
        if ($self->{_kind} == tk_union) {
            $self->{_discriminator_type} = CORBA::TypeCode::_unmarshal(@_);
            $self->{_default_index} = CORBA::ORB::_unmarshal_long(@_);
        }
        if ($has_members{$self->{_kind}}) {
            my($count) = CORBA::ORB::_unmarshal_ulong(@_);
            $self->{_members} = [];
            if ($self->{_kind} == tk_enum) {
                while ($count--) {
                    push @{$self->{_members}}, {_name => CORBA::ORB::_unmarshal_string(@_)};
                }
            } elsif (($self->{_kind} == tk_struct) || ($self->{_kind} == tk_except)) {
                while ($count--) {
                    my $member = {};
                    $member->{_name} = CORBA::ORB::_unmarshal_string(@_);
                    $member->{_type} = CORBA::TypeCode::_unmarshal(@_);
                    push @{$self->{_members}}, $member;
                }
            } elsif ($self->{_kind} == tk_union) {
                while ($count--) {
                    my $member = {};
                    if ($self->{_discriminator_type}->kind == tk_short) {
                        $member->{_label} = CORBA::ORB::_unmarshal_short(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_ushort) {
                        $member->{_label} = CORBA::ORB::_unmarshal_ushort(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_long) {
                        $member->{_label} = CORBA::ORB::_unmarshal_long(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_ulong) {
                        $member->{_label} = CORBA::ORB::_unmarshal_ulong(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_boolean) {
                        $member->{_label} = CORBA::ORB::_unmarshal_boolean(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_char) {
                        $member->{_label} = CORBA::ORB::_unmarshal_char(@_);
                    } elsif ($self->{_discriminator_type}->kind == tk_enum) {
                        $member->{_label} = CORBA::ORB::_unmarshal_enum(@_);
                    }
                    $member->{_name} = CORBA::ORB::_unmarshal_string(@_);
                    $member->{_type} = CORBA::TypeCode::_unmarshal(@_);
                    push @{$self->{_members}}, $member;
                }
            }
        } elsif ($has_type{$self->{_kind}}) {
            $self->{_type} = CORBA::TypeCode::_unmarshal(@_);
        }
        if ($has_length{$self->{_kind}}) {
            $self->{_length} = CORBA::ORB::_unmarshal_ulong(@_);
        }
    }
    return bless $self, 'CORBA::TypeCode';
}

sub kind {
    my($self) = @_;
    return $self->{_kind};
}

sub id {
    my($self) = @_;
    return $self->{_id};
}

sub name {
    my($self) = @_;
    return $self->{_name};
}

sub content_type {
    my($self) = @_;
    return $self->{_type};
}

sub member_count {
    my($self) = @_;
    return scalar @{$self->{_members}};
}

sub member_name {
    my($self, $index) = @_;
    return $self->{_members}[$index]{_name};
}

sub member_type {
    my($self, $index) = @_;
    return $self->{_members}[$index]{_type};
}

sub length {
    my($self) = @_;
    return $self->{_length};
}

sub _create_alias_tc ($$$) {
    my($id,$name,$original_type) = @_;
    my $tc = {  _kind   =>  tk_alias,
                _id     =>  $id,
                _name   =>  $name,
                _type   =>  $original_type,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_struct_tc ($$$) {
    my($id,$name,$members) = @_;
    my $tc = {  _kind       =>  tk_struct,
                _id         =>  $id,
                _name       =>  $name,
                _members    =>  [],
            };
    my @members = @$members;
    while (my($n,$t) = splice(@members, 0, 2)) {
        push @{$tc->{_members}}, {_name => $n, _type => $t};
    }
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_exception_tc ($$$) {
    my($id,$name,$members) = @_;
    my $tc = {  _kind       =>  tk_except,
                _id         =>  $id,
                _name       =>  $name,
                _members    =>  [],
            };
    my @members = @$members;
    while (my($n,$t) = splice(@members, 0, 2)) {
        push @{$tc->{_members}}, {_name => $n, _type => $t};
    }
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_enum_tc ($$$) {
    my($id,$name,$members) = @_;
    my $tc = {  _kind       =>  tk_enum,
                _id         =>  $id,
                _name       =>  $name,
                _members    =>  $members,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_sequence_tc ($$) {
    my($bound,$element_type) = @_;
    my $tc = {  _kind       =>  tk_sequence,
                _length     =>  $bound,
                _type       =>  $element_type,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_array_tc ($$) {
    my($bound,$element_type) = @_;
    my $tc = {  _kind       =>  tk_array,
                _length     =>  $bound,
                _type       =>  $element_type,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_string_tc ($) {
    my($bound) = @_;
    my $tc = {  _kind       =>  tk_string,
                _length     =>  $bound,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _create_interface_tc ($$) {
    my($id, $name) = @_;
    my $tc = {  _kind       =>  tk_objref,
                _id         =>  $id,
                _name       =>  $name,
            };
    return bless $tc, 'CORBA::TypeCode';
}

sub _noalias_kind {
    my($self) = @_;
    while ($self->kind() == tk_alias) {
        $self = $self->content_type();
    }
    return $self->kind();
}

sub _noalias_content_type {
    my($self) = @_;
    while ($self->kind() == tk_alias) {
        $self = $self->content_type();
    }
    return $self->content_type();
}

sub _needs_ref ($$) {
    my($self, $mode) = @_;

    return 0 if $mode == 0; # in parameters never need pass by reference
    my $kind = $self->kind();
    if (($kind <= tk_octet) || ($kind == tk_Principal) || ($kind == tk_enum) ||
        ($kind == tk_string)) {
        return 1;
    }
    if ($kind == tk_alias) {
        return $self->content_type->_needs_ref($mode);
    }
    if (($kind == tk_sequence) && ($self->content_type()->kind() == tk_octet)) {
        return 1; # octet-sequence implemented as a scalar
    }
    return 0;
}

1;

__END__