# $Id: Testem_impl.pm 1206 2006-05-31 07:11:53Z rvosa $

# Generated on Wed Feb 24 08:17:33 1999 by idl2perl 1.15 with command:
# bin/idl2perl -impl Data.idl

use COPE::Data::Testem_types;
use COPE::Data::Testem_skel;
use COPE::Outside::Swapper_impl;
use COPE::Data::Anything_impl;

# interface Testem (IDL:cope/Data/Testem:1.0)

package Data::Testem_impl;
use strict;
use Exception::Class::TCF;
use COPE::CORBA::Servant
@Data::Testem_impl::ISA=qw(CORBA::BOA::_Servant);
sub _skelname($) { 'Data::Testem_skel' }

# The testem object retains data for all the members of a TestUnion,
# starting with the D_OBJ member.
# It also has a hash of RecStructs and something to throw.

sub new {
    my($class,@args) = @_;
    my $self = {'current' => Data::D_OBJ};

    $self->{Data::D_OBJ} = new Outside::Swapper_impl('it' => $self);
    $self->{creatures} = {'worm' => new Data::RecStruct('name' => 'worm',
							'children' => [])};
    $self->{ball} = new Data::Testem::NameUsed(
				       'all' => $self->{creatures}{worm},
				       'why' => 'testing');
    bless $self, $class;
    $CORBA::BOA::_The_Boa->activate_object($self);
    return $self;
}

# Set one of the TestUnion members and return the active discriminator value.

# operation setit (IDL:cope/Data/Testem/setit:1.0)

sub setit ($$) {
    my($self,$val) = @_;

    my $old = $self->{current};
    $self->{$self->{current} = $val->discriminator} = $val->[1]; # Rude!
    return $old;
}

# Return a TestUnion value built from the discriminator value passed,
# also return the previous active discriminator value.

# operation getit (IDL:cope/Data/Testem/getit:1.0)

sub getit ($$) {
    my($self,$what) = @_;

    my $old = $self->{current};
    my $tu = new Data::TestUnion;
    @$tu = ($$what, $self->{$$what});	# Rude
    $self->{current} = $$what;
    $$what = $old;
    return $tu;
}

# Add a RecStruct to my object data.  Accessed through the
# 'creatures' key on the object hash directly by name of through
# the 'children' RecStruct memeber.

# operation birth (IDL:cope/Data/Testem/birth:1.0)

sub birth ($$$) {
    my($self,$parent,$child) = @_;

    my $mp = $self->{creatures}{$parent};
    
    throw Data::Testem::NotFamily if (!defined $mp);
    throw($self->{ball}) if exists($self->{creatures}{$child});
    my $sprog = new Data::RecStruct('name' => $child,
				    'children' => []);
    $self->{creatures}{$child} = $sprog;
    return push @{$mp->{children}}, $sprog
}

# Add several RecStruct items at once.

# operation multiple_birth (IDL:cope/Data/Testem/multiple_birth:1.0)

sub multiple_birth ($$) {
    my($self,$family) = @_;

    my $mp = $self->{creatures}{$family->{name}};
    
    throw Data::Testem::NotFamily if (!defined $mp);
    map {
	throw($self->{ball}) if exists($self->{creatures}{$_->{name}});
    } @{$family->{children}};
    map {
	$self->{creatures}{$_->{name}} = $_;
    } @{$family->{children}};
    return push @{$mp->{children}}, @{$family->{children}};
}

# operation family (IDL:cope/Data/Testem/family:1.0)

sub family ($$) {
    my($self,$whose) = @_;

    my $mp = $self->{creatures}{$whose};

    throw Data::Testem::NotFamily if (!defined $mp);
    return $mp;
}

# operation concat (IDL:cope/Data/Testem/concat:1.0)

sub concat ($$) {
    my($self,$nest) = @_;
    my $ret = '';

    map {$ret .= $_->{val1}} @{$nest->{n1}{n2}{n3}{list}};
    return $ret;
}

# operation andem (IDL:cope/Data/Testem/andem:1.0)

sub andem ($$) {
    my($self,$un) = @_;

    return 0 if $un->discriminator ne 'b';
    my $s = $un->struct_case('b');
    my $ret = !$s->{flag};
    foreach my $i (@{$s->{list}}) {
	my $d = $i->discriminator;
	if ($d eq 'a') {
	    $ret &&= $i->short_case('a');
	} elsif ($d eq 'b') {
	    $ret &&= $i->struct_case('b')->{flag};
        } else {
	    $ret = 0;
	}
    }
    return $ret;
}

# operation addem (IDL:cope/Data/Testem/addem:1.0)

sub addem ($$) {
    my($self,$mr) = @_;
    my $sum;

    $sum = $mr->{value1};
    $sum += subtotal($mr->{primer1});
    map {$sum += subtotal($_);} @{$mr->{seq1}};
    return $sum;
}

# Total the value1 fields in an MR2

sub subtotal ($) {
    my ($mr2, $sum) = ($_[0], 0);
    map {$sum += $_->{value1};} @{$mr2->{seq2}};
    return $sum;
}

# Return a reference to an object for tests on type 'any'.

sub test_any ($) {
    return Data::Anything_impl->new();
}

1;