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

# Copyright (c) 1997 Secure Computing Corporation
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
use strict;
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package CORBA::_Skel;
use fields qw(id impl ior default);
use Exception::Class::TCF;
use COPE::CORBA::Exception;
use COPE::IOP;
use COPE::CORBA::Object;

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

# throw an appropriate exception if the implementation doesn't provide
# the desired method.
sub AUTOLOAD {
    return if ( $CORBA::_Skel::AUTOLOAD =~ /::DESTROY$/o );
    $logger->warn("Corba::_Skel called $CORBA::_Skel::AUTOLOAD");
    $logger->fatal("CORBA::NO_IMPLEMENT");
    throw CORBA::NO_IMPLEMENT->new(
        'minor'     => 0,
        'completed' => CORBA::CompletionStatus::COMPLETED_NO,
    );
}

=pod

=begin testing

ok( CORBA::_Skel->_nil, "Testing CORBA::_Skel _nil method" );

=end testing

=cut

sub _nil {
    $logger->debug("Returning 0");
    return 0;
}

=pod

=begin testing

ok( CORBA::_Skel->_non_existent, "Testing CORBA::_Skel _non_existent method" );

=end testing

=cut

# Implementation of the special non_existent() method.
# If the skeleton exists then should the object, but default
# servants may want to override this.
sub _non_existent {
    $logger->debug("Calling non_existent() implementation");
    my ( $self, $serverrequest ) = @_;
    my $result_ = { _type => $CORBA::_tc_boolean, _value => 0 };
    $serverrequest->result($result_);
}

=pod

=begin testing

ok( CORBA::_Skel->_not_existent, "Testing CORBA::_Skel _not_existent method" );

=end testing

=cut

# This is required for compatability with an error in older CORBA standards.
sub _not_existent {
    $logger->debug("Calling non_existent() implementation as \"not_existent\"");
    goto &_non_existent;
}

=pod

=begin testing

ok( CORBA::_Skel->_is_a, "Testing CORBA::_Skel _is_a method" );

=end testing

=cut

sub _is_a {
    $logger->debug("Checking inheritance");
    my ( $self, $serverrequest ) = @_;
    my $result_ = { _type => $CORBA::_tc_boolean };
    my $arg_list = [
        {
            'argument'  => { _type => $CORBA::_tc_string0 },
            'arg_modes' => 0,
        },
    ];
    $serverrequest->params($arg_list);
    $serverrequest->result($result_);
    my $class = ref($self);
    $class =~ s/_skel$//;
    $result_->{_value} =
      CORBA::Object::_check_is_a( $class, $arg_list->[0]{argument}{_value} );
}

=pod

=begin testing

ok( CORBA::_Skel->_interface, "Testing CORBA::_Skel _interface method" );

=end testing

=cut

no strict 'refs';
sub _interface {
    $logger->debug("Returning interface");
    my $class = ref( $_[0] ) || $_[0];
    return ${ $class . "::_interface" };
}
use strict 'refs';

=pod

=begin testing

ok( CORBA::_Skel->is_nil, "Testing CORBA::_Skel is_nil method" );

=end testing

=cut

sub is_nil {
    $logger->info("Calling \"is_nil\"");
    my ($self) = @_;
    return !( $self && ref($self) && exists( $self->{host} ) );
}

=pod

=begin testing

ok( CORBA::_Skel->_ior, "Testing CORBA::_Skel _ior method" );

=end testing

=cut

sub _ior {
    $logger->debug("Returning IOR");
    my CORBA::_Skel $self = shift;
    my $boa               = $CORBA::BOA::_The_Boa;
    my $client            = $boa->{__current_client};
    if ( exists( $self->{'ior'}{ $client->{_tag} } ) ) {

        # one in the cache
        return $self->{'ior'}{ $client->{_tag} };
    }
    my IIOP::Version $vers =
      IIOP::Version->new( major => chr(1), minor => chr(0) );
    my IIOP::ProfileBody $profilebody = new IIOP::ProfileBody(
        iiop_version => $vers,
        host         => $client->{_localname},
        port         => $client->{_localport},
        object_key   => $self->{id}
    );
    my $profile_data = chr( $boa->{byte_order} );
    my $index        = 1;
    IIOP::ProfileBody::_marshal( \$profile_data, \$index, $boa->{byte_order},
        $profilebody );
    my IOP::TaggedProfile $taggedprofile = new IOP::TaggedProfile(
        tag          => IOP::TAG_INTERNET_IOP,
        profile_data => $profile_data
    );
    my IOP::IOR $ior = new IOP::IOR(
        type_id  => $self->_interface,
        profiles => [ @{ $client->{_profiles} }, $taggedprofile ]
    );
    $self->{'ior'}{ $client->{_tag} } = $ior;
    return $ior;
}

1;

__END__

=head1 NAME

CORBA::_Skel

A class to ...

=head1 SYNOPSIS

use CORBA::_Skel;

=head1 DESCRIPTION

The CORBA::_Skel class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 AUTOLOAD

Parameters:
    none

Insert description of subroutine here...

=head2 _nil

Parameters:
    none

Insert description of subroutine here...

=head2 _non_existent (method)

Parameters:
    serverrequest

Insert description of method here...

=head2 _not_existent

Parameters:
    none

Insert description of subroutine here...

=head2 _is_a (method)

Parameters:
    serverrequest

Insert description of method here...

=head2 _interface (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head2 is_nil (method)

Parameters:
    none

Insert description of method here...

=head2 _ior

Parameters:
    none

Insert description of subroutine here...

=head1 FILES

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

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut