File Coverage

blib/lib/COPE/CORBA/ORB.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# $Id: ORB.pm,v 1.7 1997/07/25 10:12:42 schuller Exp $
# Copyright (c) 1997 Lunatech Research / Bart Schuller
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.

use Carp;
# interface ORB
package CORBA::ORB;
$CORBA::ORB::_The_Orb = 0;
use strict;
use COPE::CORBA::TypeCode;
use COPE::CORBA::TCKind;
use COPE::CORBA::BOA;
use COPE::CORBA::Exception;

my $_byte_order;

BEGIN {
    if (pack('N', 1) eq pack('L', 1)) {
        $_byte_order = 0;
    } else {
        $_byte_order = 1;
    }
}

sub new {
    my($class,$argv,$orb_identifier) = @_;
    my $self = {
	    byte_order  =>  $_byte_order,
    };

    #
    # Check for -ORBport argument and remove it from
    # the list of arguments.
    #
    if (defined($argv)) {
        my $x;
        for ($x=0; $x < $#$argv; $x++) {
            if ($argv->[$x] eq '-ORBport') {
                my $orbport = $argv->[$x+1];
                $orbport =~ s/\D//g;
                splice(@$argv, $x, 2);
                if ($orbport){
                    $self->{port} = $orbport;
                }
            }
        }
    }

    return $CORBA::ORB::_The_Orb = bless $self, $class;
}

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

sub _marshal_octet {
    my($out, $index, $byte_order, $data) = @_;
    $$out .= pack('C', $data);
    $$index++;
}

sub _marshal_char {
    my($out, $index, $byte_order, $data) = @_;
    $$out .= pack('a', $data);
    $$index++;
}

sub _marshal_ushort {
    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;
}

sub _marshal_short { _marshal_ushort(@_) }

sub _marshal_ulong {
    my($out, $index, $byte_order, $data) = @_;
    my $previndex = $$index;
    $$index = (3+$$index)& ~3;
    $$out .= "\0" x ($$index-$previndex) . pack($byte_order ? 'V' : 'N', $data);
    $$index += 4;
}

sub _marshal_long { _marshal_ulong(@_) }

sub _marshal_enum { _marshal_ulong(@_) }

sub _marshal_octet_array {
    my($out, $index, $byte_order, $data, $length) = @_;
    $$out .= pack("a$length", $data);
    $$index += $length;
}

sub _marshal_char_array { _marshal_octet_array(@_) }

sub _marshal_string {
    my($out, $index, $byte_order, $data, $length) = @_;
    $data .= "\0";
    _marshal_ulong($out, $index, $byte_order, length($data));
    $$out .= $data;
    $$index += length($data);
}

sub _marshal_octet_sequence {
    my($out, $index, $byte_order, $data, $length) = @_;
    _marshal_ulong($out, $index, $byte_order, length($data));
    $$out .= $data;
    $$index += length($data);
}

sub _marshal_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);
    }
}

sub _unmarshal_string {
    my($in, $index, $byte_order) = @_;
    $$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;
}

sub _unmarshal_octet_sequence {
    my($in, $index, $byte_order) = @_;
    $$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;
}

sub _unmarshal_char {
    my($in, $index, $byte_order) = @_;
    return substr($$in,$$index++,1);
}

sub _unmarshal_octet {
    my($in, $index, $byte_order) = @_;
    return unpack('C', substr($$in,$$index++,1));
}

sub _unmarshal_boolean { _unmarshal_octet(@_) }

sub _unmarshal_octet_array {
    my($in, $index, $byte_order, $length) = @_;
    my $oldindex = $$index;
    $$index += $length;
    return substr($$in,$oldindex,$length);
}

sub _unmarshal_char_array { _unmarshal_octet_array(@_) }

sub _unmarshal_ushort {
    my($in, $index, $byte_order) = @_;
    $$index = (1+$$index)& ~1;
    my $short = unpack($byte_order ? 'v' : 'n', substr($$in,$$index,2));
    $$index += 2;
    return $short;
}

sub _unmarshal_short {
    my($in, $index, $byte_order) = @_;
    $$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;
}

sub _unmarshal_ulong {
    my($in, $index, $byte_order) = @_;
    $$index = (3+$$index)& ~3;
    my $long = unpack($byte_order ? 'V' : 'N', substr($$in,$$index,4));
    $$index += 4;
    return $long;
}

sub _unmarshal_long {
    my($in, $index, $byte_order) = @_;
    $$index = (3+$$index)& ~3;
    my $tmp = substr($$in,$$index,4);
    if ($byte_order xor $_byte_order) {
        $tmp = pack('V', unpack('N', $tmp));
    }
    my $long = unpack('l', $tmp);
    $$index += 4;
    return $long;
}

sub _unmarshal_enum { _unmarshal_ulong(@_) }

sub _unmarshal_sequence {
    my($in, $index, $byte_order, $_unmarshal, @extra) = @_;
    $$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;
}

sub _id2package {
    my($id) = @_;
    if ($id =~ m!^IDL:([^/]+/)?(.+):.+$!) {
        my $package = $2;
        $package =~ s!/!::!g;
        return $package;
    } else {
        die "_id2package: $id is not a proper RepositoryId";
    }
}

BEGIN { $::marshal_depth=0 }

sub _marshal_using_tc {
    my $tc = pop; # sic
    my $kind = $tc->kind;
    if ($kind == tk_short) {
        _marshal_short(@_);
        return;
    }
    if ($kind == tk_boolean) {
        _marshal_boolean(@_);
        return;
    }
    if ($kind == tk_long) {
        _marshal_long(@_);
        return;
    }
    if ($kind == tk_ulong) {
        _marshal_ulong(@_);
        return;
    }
    if ($kind == tk_enum) {
        _marshal_enum(@_);
        return;
    }
    if ($kind == tk_string) {
        _marshal_string(@_, $tc->length());
        return;
    }
    if ($kind == tk_sequence) {
        my $ct = $tc->content_type();
        if ($ct->kind() == tk_octet) {
            _marshal_octet_sequence(@_, $tc->length());
            return;
        }
        my $seq = pop;
        _marshal_ulong(@_, scalar(@$seq));
        foreach my $item (@$seq) {
            _marshal_using_tc(@_, $item, $ct);
        }
        return;
    }
    if ($kind == tk_objref) {
        my $obj = pop;
        IOP::IOR::_marshal(@_, $CORBA::ORB::_The_Orb->_object_to_IOR($obj));
        return;
    }
    if ($kind == tk_struct) {
        my $struct = pop;
        my $count = $tc->member_count;
        for (my $counter = 0; $counter < $count; $counter++) {
	    my $element = $struct->{$tc->member_name($counter)};
	    if (!defined($element)) {
		throw new CORBA::MARSHAL minor => $counter, completion_status => CORBA::CompletionStatus::COMPLETED_MAYBE;
	    }
            _marshal_using_tc(@_, $element, $tc->member_type($counter));
        }
        return;
    }
    if ($kind == tk_array) {
        my $ct = $tc->content_type();
        if ($ct->kind() == tk_octet) {
            _marshal_octet_array(@_, $tc->length());
            return;
        }
        my $array = pop;
        for(my $i=0;$i < $tc->length();$i++) {
            _marshal_using_tc(@_, $array->[$i], $ct);
        }
        return;
    }
    if ($kind == tk_except) {
        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));
        }
        return;
    }
    die "Kind $kind not implemented";
}

sub _unmarshal_using_tc {
    my($inref, $indexref, $byte_order, $tc) = @_;
    my $kind = $tc->kind;

    if ($kind == tk_void) { return }
    if ($kind == tk_short) {
        return _unmarshal_short($inref, $indexref, $byte_order);
    }
    if ($kind == tk_long) {
        return _unmarshal_long($inref, $indexref, $byte_order);
    }
    if ($kind == tk_ulong) {
        return _unmarshal_ulong($inref, $indexref, $byte_order);
    }
    if ($kind == tk_boolean) {
        return _unmarshal_boolean($inref, $indexref, $byte_order);
    }
    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::ORB::_id2package($tc->id);
    }
    if ($kind == tk_sequence) {
        my $ct = $tc->content_type();
        if ($ct->kind() == tk_octet) {
            return _unmarshal_octet_sequence($inref, $indexref, $byte_order);
        }
        my $result = [];
        my $count = _unmarshal_ulong($inref, $indexref, $byte_order);
        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();
        if ($ct->kind() == tk_octet) {
            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_string) {
        return _unmarshal_string($inref, $indexref, $byte_order);
    }
    if ($kind == tk_TypeCode) {
        return CORBA::TypeCode::_unmarshal($inref, $indexref, $byte_order);
    }
    if ($kind == tk_enum) {
        return _unmarshal_enum($inref, $indexref, $byte_order);
    }
    if ($kind == tk_objref) {
        my $ior = IOP::IOR::_unmarshal($inref, $indexref, $byte_order);
        my $object = CORBA::Object->_new_from_ior($ior);
        return bless $object, CORBA::ORB::_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::ORB::_id2package($tc->id);
    }
    if ($kind == tk_any) {
        my $result = {_type  => CORBA::TypeCode::_unmarshal($inref, $indexref, $byte_order) };
        $result->{_value} = _unmarshal_using_tc($inref, $indexref, $byte_order, $result->{_type});
        return $result;
    }
    die "Kind $kind not implemented";
}

sub BOA_init (;$$) {
    return new CORBA::BOA @_;
}

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

sub _object_to_IOR {
    my($self,$impl) = @_;
    my $ior;
    if ($impl) {
        if ("$impl" =~ /=HASH/ && $impl->{_ior}) {
            return $impl->{_ior}; # impl is really a client-side stub Object
                                  # TODO use UNIVERSAL?
        }
        my $boa = $CORBA::BOA::_The_Boa;
        my $obj = $boa->{skeletons}{$impl};
        if ($obj->{_ior}) {
            return $obj->{_ior};
        }
        my $profilebody = new IIOP::ProfileBody (
            iiop_version    =>  new IIOP::Version (major=>chr(1),minor=>chr(0)),
            host            =>  $boa->{host},
            port            =>  $boa->{port},
            object_key      =>  $obj->{id}      );
        my $profile_data = chr($boa->{byte_order});
        my $index = 1;
        IIOP::ProfileBody::_marshal(\$profile_data, \$index, $boa->{byte_order}, $profilebody);
        my $taggedprofile = new IOP::TaggedProfile (
            tag             =>  IOP::TAG_INTERNET_IOP,
            profile_data    =>  $profile_data );
        $ior = new IOP::IOR (
            type_id         =>  $obj->{interface},
            profiles        =>  [ $taggedprofile ] );
        $obj->{_ior} = $ior;
    } else {
        $ior = new IOP::IOR (
            type_id         => '',
            profiles        => [] );
    }
    return $ior;
}

sub object_to_string {
    my($self,$impl) = @_;
    my $boa = $CORBA::BOA::_The_Boa;
    my $m_ior = chr($boa->{byte_order});
    my $ior = $self->_object_to_IOR($impl);
    my $index = 1;
    IOP::IOR::_marshal(\$m_ior, \$index, $boa->{byte_order}, $ior);
    my $hex = 'IOR:';
    for (my $i = 0; $i < length($m_ior); $i++) {
        $hex .= sprintf("%02X", unpack('C', substr($m_ior, $i, 1)));
    }
    return $hex;
}

sub string_to_object {
    my($self,$str) = @_;
    my $hex = substr($str,4);
    my $m_ior = '';
    for (my $i = 0; $i < length($hex); $i += 2) {
        $m_ior .= pack('C', hex(join('',unpack('aa', substr($hex, $i, 2)))));
    }
    my $byte_order = unpack('C', substr($m_ior, 0, 1));
    # skip first byte
    my $index = 1;
    my $ior = IOP::IOR::_unmarshal(\$m_ior, \$index, $byte_order);
    return CORBA::Object->_new_from_ior($ior, $self);
}

sub list_initial_services {
    return [ qw/
        NameService
        InterfaceRepository
    /];
}

require COPE::Announcer;

sub resolve_initial_references {
    my($self, $objectid) = @_;
    return $self->string_to_object(COPE::Announcer::resolve($objectid));
}

package CORBA::_Struct;

sub new ($%) {
    my($class, %self) = @_;
    bless \%self, $class;
}

package CORBA;

sub ORB_init (;$$) {
    return new CORBA::ORB @_;
}

1;