# $Id: Object.pm 1390 2006-06-15 04:43:57Z rvosa $
# Subversion: $Rev: 117 $

# Copyright (c) 1997 Lunatech Research / Bart Schuller <schuller@lunatech.com>
# 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::Object;

# use fields qw(ior host port object_key orb ssl);
use COPE::GIOP;
use COPE::IOP;
use IO::Socket;
use Exception::Class::TCF;
require COPE::CORBA::Request;
use COPE::IOPSSL;
use Carp;

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

#sub _check_is_a ($$);    # Pre-declaration required by Perl 5.6.
$CORBA::Object::_tc =
  CORBA::TypeCode::_create_interface_tc( 'IDL:omg.org/CORBA/Object:1.0',
    'Object' );
CORBA::TypeCode::_type_impl( 'IDL:omg.org/CORBA/Object:1.0', 'CORBA::Object' );

=pod

=begin testing

ok( CORBA::Object->new->isa('CORBA::Object'), "Testing CORBA::Object constructor" );

=end testing

=cut

sub new {
    $logger->info("Creating \"CORBA::Object\" object");
    my $class  = shift;
    my %values = @_;
    $values{'ssl'} = 0 unless defined $values{'ssl'};
    return bless \%values, 'CORBA::Object';
}

=pod

=begin testing

ok( CORBA::Object::_nil == 0, "Testing CORBA::Object _nil method" );

=end testing

=cut

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

=pod

=begin testing

ok( CORBA::Object->new->_check_is_a, "Testing CORBA::Object _check_is_a method" );

=end testing

=cut

no strict 'refs';
# Internal helper function for is_a
sub _check_is_a {
    $logger->debug("Recursing through object's inheritance tree");
    my $class = shift;
    my $iface = @_;
    if ( ${ $class . "::_interface" } eq $iface ) {
        return 1;
    }

    # recurse up the ISA array
    foreach ( @{ $class . "::ISA" } ) {
        if ( _check_is_a( $_, $iface ) ) {
            return 1;
        }
    }
    return 0;
}
use strict 'refs';

=pod

=begin testing

ok( CORBA::Object->new->is_a, "Testing CORBA::Object is_a method" );

=end testing

=cut

# Search the inheritance tree to see if the object actually implements
# the requested interface
sub is_a {
    $logger->info("Searching for implementation in object's inheritance tree");
    my $self  = shift;
    my $iface = shift;
    my $class;

    # First, get the iface name out of the object ref and figure out
    # what type of object it is (if possible)
    my $type = $self->{'ior'}{'type_id'};
    if ( defined($type) && ( $iface eq $type ) ) {
        return 1;
    }
    try {
        $class = CORBA::TypeCode::_id2package($type);
      }
      catch 'Default' => sub { };
    if ( defined($class) ) {
        if ( _check_is_a( $class, $iface ) ) {
            return 1;
        }
    }

    # No luck, we have to call the backend
    my $result_ = { "_type" => $CORBA::_tc_boolean };
    my $arg_list = [
        {
            'argument' => {
                "_type"  => $CORBA::_tc_string0,
                "_value" => $iface
            },
            'arg_modes' => 0
        }
    ];
    my $request_ = $self->create_request(
        'operation' => '_is_a',
        'arg_list'  => $arg_list,
        'result'    => $result_,
    );
    $request_->invoke(0);
    return $result_->{'_value'};
}

=pod

=begin testing

ok( CORBA::Object->new->non_existent, "Testing CORBA::Object non_existent method" );

=end testing

=cut

# Make a special call to ask the server if an object exists
sub non_existent {
    $logger->info("Asking server if object exists");
    my ($self) = @_;
    my $result_ = { _type => $CORBA::_tc_boolean };
    my $request_ = $self->create_request(
        'operation' => '_non_existent',
        'arg_list'  => [],
        'result'    => $result_
    );
    $request_->invoke(0);
    return $result_->{'_value'};
}

=pod

=begin testing

ok( CORBA::Object->new->_new_from_ior, "Testing CORBA::Object _new_from_ior method" );

=end testing

=cut

sub _new_from_ior {
    $logger->debug("Creating new object from IOR");
    my ( $class, $ior, $orb ) = @_;
    if ( !defined $orb ) {
        $orb = $CORBA::ORB::_The_Orb;
    }
    my $object = $class->new( 'ior' => $ior, 'orb' => $orb, 'ssl' => 0 );
    my IOP::TaggedProfile $tprof;
    foreach $tprof ( @{ $ior->{'profiles'} } ) {
        if ( $tprof->{'tag'} == 0 ) {
            my $profile    = $tprof->{'profile_data'};
            my $byte_order = unpack( 'C', substr( $profile, 0, 1 ) );
            my $index      = 1;
            my IIOP::ProfileBody $profilebody =
              IIOP::ProfileBody::_unmarshal( \$profile, \$index, $byte_order );
            $object->{'host'}       = $profilebody->{'host'};
            $object->{'object_key'} = $profilebody->{'object_key'};
            if ( $object->{'ssl'} == 0 ) {
                $object->{'port'} = $profilebody->{'port'};
            }
        }
        if ( $tprof->{'tag'} == IOP::ComponentId::TAG_SSL_SEC_TRANS ) {
            my $profile         = $tprof->{'profile_data'};
            my $byte_order      = unpack( 'C', substr( $profile, 0, 1 ) );
            my $index           = 1;
            my IOPSSL::SSL $ssl =
              IOPSSL::SSL::_unmarshal( \$profile, \$index, $byte_order );
            $object->{'ssl'}  = 1;
            $object->{'port'} = $ssl->{'port'};

            # TODO for now, we ignore the supported/required parameters and just default to ADH-DES-CBC
            #
        }
    }
    return bless $object, $class;
}

=pod

=begin testing

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

=end testing

=cut

sub _ior {
    $logger->debug("Returning IOR");
    my $self = shift;
    return $self->{'ior'};
}

=pod

=begin testing

ok( CORBA::Object->new->_narrow, "Testing CORBA::Object _narrow method" );

=end testing

=cut

sub _narrow {
    $logger->debug("Narrowing service");
    my $class = shift;
    my $self  = shift;
    use Data::Dumper;
    $logger->debug( Dumper( $class ) );
    if ( $self->is_nil() ) {
        return $self;
    }
    if ( $self->is_a( $class->_interface() ) ) {
        bless $self, $class;
        return $self;
    }
    $logger->warn("Narrow of $self failed");
    warn "Narrow of $self failed";
    return 0;
}

=pod

=begin testing

ok( CORBA::Object->new->_interface, "Testing CORBA::Object _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::Object->new->is_nil, "Testing CORBA::Object is_nil method" );

=end testing

=cut

sub is_nil {
    $logger->info("Checking \"is_nil\"");
    my $self = shift;
    return !( $self && ref($self) && exists( $self->{'host'} ) );
}

=pod

=begin testing

ok( CORBA::Object->new->create_request, "Testing CORBA::Object create_request method" );

=end testing

=cut

sub create_request {
    $logger->info("Creating \"CORBA::Request\" object");
    my $self    = shift;
    my $request = {@_};
    $request->{'orb'}        = $self->{'orb'};
    $request->{'host'}       = $self->{'host'};
    $request->{'port'}       = $self->{'port'};
    $request->{'object_key'} = $self->{'object_key'};
    $request->{'ssl'}        = $self->{'ssl'};
    return bless $request, 'CORBA::Request';
}

=pod

=begin testing

ok( CORBA::Object->new->_attribute, "Testing CORBA::Object _attribute method" );

=end testing

=cut

sub _attribute {
    $logger->debug("Returning attributes");
    my ( $self, $name, $type, $arg ) = @_;
    my $result_ = { "_type" => defined $arg ? $CORBA::_tc_void : $type };
    my $arg_list = [];
    if ( defined $arg ) {
        push @$arg_list,
          {
            'argument'  => { "_type" => $type, "_value" => $arg },
            'arg_modes' => 0,
          };
    }
    my $opname = defined $arg ? '_set_' : '_get_';
    $opname .= $name;
    my $request_ = $self->create_request(
        'operation' => $opname,
        'arg_list'  => $arg_list,
        'result'    => $result_,
    );
    $request_->invoke(0);
    if ( !defined $arg ) {
        return $result_->{'_value'};
    }
}
1;

__END__

=head1 NAME

CORBA::Object

A class to ...

=head1 SYNOPSIS

use CORBA::Object;

=head1 DESCRIPTION

The CORBA::Object class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 new (constructor)

Parameters:
    class

Insert description of constructor here...

=head2 _nil

Parameters:
    none

Insert description of subroutine here...

=head2 _check_is_a

Parameters:
    class

Insert description of subroutine here...

=head2 is_a (method)

Parameters:
    iface

Insert description of method here...

=head2 non_existent (method)

Parameters:
    none

Insert description of method here...

=head2 _new_from_ior (constructor)

Parameters:
    class
    ior
    orb

Insert description of constructor here...

=head2 _ior (method)

Parameters:
    none

Insert description of method here...

=head2 _narrow (constructor)

Parameters:
    class
    self

Insert description of constructor 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 create_request (constructor)

Parameters:
    none

Insert description of constructor here...

=head2 _attribute (method)

Parameters:
    name
    type
    arg

Insert description of method here...

=head1 FILES

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

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut