# $Id: Request.pm 1360 2006-06-14 06:33:50Z 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.
# Modified by Irving Reid and others 1997-1998 to support SSL.
# Modified Giles Atkinson 31/6/98 to deal with system exception and location
# forward replies.
# interface Request
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package CORBA::Request;
use COPE::GIOP;
use IO::Socket;
use Errno qw(ECONNRESET ECONNREFUSED);
use Exception::Class::TCF;
use COPE::CORBA::TCKind;
use COPE::CORBA::Exception;

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

$CORBA::Request::request_id  = 0;
%CORBA::Request::connections = ();

=pod

=begin testing

ok( CORBA::Request::add_arg, "Testing CORBA::Request add_arg method" );
ok( CORBA::Request::invoke, "Testing CORBA::Request invoke method" );
ok( CORBA::Request::delete, "Testing CORBA::Request delete method" );
ok( CORBA::Request::send, "Testing CORBA::Request send method" );
ok( CORBA::Request::get_response, "Testing CORBA::Request get_response method" );
ok( CORBA::Request::get_connection, "Testing CORBA::Request get_connection method" );

=end testing

=cut

# This package has no constructor: Request objects are created by
# CORBA::Object::create_request().
sub add_arg {
    $logger->info("Adding arguments");
    my ( $self, $name, $arg_type, $value, $len, $arg_flags ) = @_;
}

sub invoke {
    $logger->info("Negotiation communication");
    my ( $self, $invoke_flags ) = @_;

    # Check for runaway recursion caused by location forwarding
    # or orderly disconnections (GIOP CloseConnection message)
    if ( ++$self->{'tries'} > 6 ) {
    	$logger->fatal("CORBA::TRANSIENT");
    	throw new CORBA::TRANSIENT;
    }
    my $oneway         = exists $self->{'result_mode'};
    my $request_header = GIOP::RequestHeader->new(
        'service_context'      => [],
        'request_id'           => $CORBA::Request::request_id++,
        'response_expected'    => !$oneway,
        'object_key'           => $self->{'object_key'},
        'operation'            => $self->{'operation'},
        'requesting_principal' => '',                              # FIXME
    );
    my $byte_order = $self->{'orb'}{'byte_order'};

    # Marshal the GIOP header in-line with crude efficiency.
    my $request = "GIOP\1\0";    # Identify GIOP version 1.0
    $request .= ( $byte_order ? "\1" : "\0" ) . chr(GIOP::Request);
    $request .= '1234';          # Place holder for message length.
    my $index = 12;
    GIOP::RequestHeader::_marshal( \$request, \$index, $byte_order,
        $request_header );
    foreach my $arg ( @{ $self->{'arg_list'} } ) {
        if ( $arg->{'arg_modes'} != 1 ) {
            CORBA::ORB::_marshal_using_tc(
                \$request,
                \$index,
                $byte_order,
                $arg->{'argument'}{'_type'}->_needs_ref( $arg->{'arg_modes'} )
                ? ${ $arg->{'argument'}{'_value'} }
                : $arg->{'argument'}{'_value'},
                $arg->{'argument'}{'_type'}
            );
        }
    }

    # Plug in the message length.
    my ( $t_index, $t_buf ) = ( 0, '' );
    CORBA::ORB::_marshal_ulong( \$t_buf, \$t_index, $byte_order, $index - 12 );
    substr( $request, 8, 4, $t_buf );

    # Send the message
    $t_index = 0;
    my $r = 0;
    my ( $connection, $conn_tries );
    do {
        $connection = $self->get_connection();
        if ( !$connection ) {

            # This is a retryable error, pause a little to increase
            # the chance of success.
            if ( ++$conn_tries > 3 ) {
            	$logger->fatal("CORBA::COMM_FAILURE");
            	throw new CORBA::COMM_FAILURE;
            }
            select( undef, undef, undef, 0.1 * $conn_tries );
        }
    } while ( !$connection );
    while ( $t_index < $index ) {
        $r = $connection->syswrite( $request, $index - $t_index, $t_index );
        if ( $r <= 0 ) {
            delete $CORBA::Request::connections{
                "$self->{host}:$self->{port}:$self->{ssl}"};
            if ( $r == 0 || $! == ECONNRESET ) {
                $self->invoke($invoke_flags);    # Recursive retry
                return;
            }
            $logger->fatal("CORBA::COMM_FAILURE");
            throw new CORBA::COMM_FAILURE;
        }
        $t_index += $r;
    }
    return if $oneway;

    # Read in the reply.
    my $reply;
    $index = 0;
    while ( $index < 12 ) {
        $r = $connection->sysread( $reply, 12 - $index, $index );
        if ( $r <= 0 ) {
            delete $CORBA::Request::connections{
                "$self->{host}:$self->{port}:$self->{ssl}"};
            $logger->fatal("CORBA::COMM_FAILURE");
            throw new CORBA::COMM_FAILURE completed =>
              CORBA::CompletionStatus::COMPLETED_MAYBE;
        }
        $index += $r;
    }
    $index = 0;
    my $reply_mh =
      GIOP::MessageHeader::_unmarshal( \$reply, \$index, \$byte_order );
    my $msgtyp = $reply_mh->{message_type};
    if ( $msgtyp != GIOP::Reply ) {
        if ( $msgtyp == GIOP::CloseConnection ) {
            delete $CORBA::Request::connections{
                "$self->{host}:$self->{port}:$self->{ssl}"};
            $self->invoke($invoke_flags);
            return;
        }
        warn "Can not handle GIOP response type $msgtyp";
        $logger->warn("Can not handle GIOP response type $msgtyp");
        $logger->fatal("CORBA::COMM_FAILURE");
        throw new CORBA::COMM_FAILURE completed =>
          CORBA::CompletionStatus::COMPLETED_MAYBE;
    }
    $byte_order = $reply_mh->{byte_order};
    my $expected = $reply_mh->{message_size} + 12;
    while ( $index < $expected ) {
        $r = $connection->sysread( $reply, $expected - $index, $index );
        if ( $r <= 0 ) {
          $logger->fatal("CORBA::COMM_FAILURE");
          throw CORBA::COMM_FAILURE->new(
            'completed' => CORBA::CompletionStatus::COMPLETED_MAYBE,
          );
        }
        $index += $r;
    }
    $index = 12;    # Skip GIOP header.
    my $reply_header =
      GIOP::ReplyHeader::_unmarshal( \$reply, \$index, $byte_order );
    my $reply_status = $reply_header->{'reply_status'};
    $logger->info("Reply status: \"$reply_status\"");
    if ( $reply_status == GIOP::NO_EXCEPTION ) { # TODO GIOP::NO_EXCEPTION uninitialized

        # The operation has been called, this is the response.
        $self->{'result'}{'_value'} =
          CORBA::ORB::_unmarshal_using_tc( \$reply, \$index, $byte_order, $self->{'result'}{'_type'} );
        foreach my $arg ( @{ $self->{'arg_list'} } ) {
            if ( ( $arg->{'arg_modes'} == 1 ) || ( $arg->{'arg_modes'} == 2 ) ) {

                # This is an 'out' or 'inout' argument, so a value is returned.
                my $val =
                  CORBA::ORB::_unmarshal_using_tc( \$reply, \$index,
                    $byte_order, $arg->{argument}{_type} );
                my $arg_info = $arg->{argument};
                my $arg_kind = $arg_info->{_type}->_noalias_kind();
                my $cnt_kind;
                if (
                    (
                           ( $arg_kind == tk_sequence )
                        || ( $arg_kind == tk_array )
                    )
                    && ( $cnt_kind =
                        $arg_info->{_type}->_noalias_content_type()
                        ->_noalias_kind(), $cnt_kind != tk_octet
                        && $cnt_kind != tk_char )
                    || $arg_kind == tk_any
                    || $arg_kind == tk_TypeCode
                  )
                {

                    # This is represented as a Perl array.
                    @{ $arg_info->{_value} } = @$val;
                }
                elsif ( $arg_kind == tk_struct ) {
                    %{ $arg->{argument}{_value} } = %$val;
                }
                else {
                    ${ $arg->{argument}{_value} } = $val;
                }
            }
        }
    }
    elsif ($reply_status == GIOP::USER_EXCEPTION
        || $reply_status == GIOP::SYSTEM_EXCEPTION )
    {
		$logger->warn("\"GIOP::USER_EXCEPTION\" or \"GIOP::SYSTEM_EXCEPTION\"");
        # The body of the reply message contains the IR identifier of
        # the exception, followed by its components.
        my $tc =
          CORBA::TypeCode::_id2package(
            CORBA::ORB::_unmarshal_string( \$reply, \$index, $byte_order ) );
        no strict 'refs';
        $tc = ${"${tc}::_tc"}; # quote to fix eclipse syntax coloration: "
        use strict;
        my $exception =
          CORBA::ORB::_unmarshal_using_tc( \$reply, \$index, $byte_order, $tc );
        if ( $reply_status == GIOP->SYSTEM_EXCEPTION ) {
            $exception->{'remote'} = 1;    # Rude, but useful
        }
        throw $exception;
    }
    elsif ( $reply_status == GIOP::LOCATION_FORWARD ) {
		$logger->info("GIOP::LOCATION_FORWARD");
        # The body of the reply message contains a new object reference that
        # should be used instead.  The request is repeated with parameters
        # from that object. It should really be cached for
        # future calls, but that will require re-organisation of this
        # function.
        my $ior = IOP::IOR::_unmarshal( \$reply, \$index, $byte_order );
        my $object = CORBA::Object->_new_from_ior($ior);
        @$self{qw(host port object_key)} = @$object{qw(host port object_key)};
        $self->invoke($invoke_flags);
        return;
    }
    else {
        $logger->fatal("CORBA::MARSHAL");
        throw new CORBA::MARSHAL completed =>
          CORBA::CompletionStatus::COMPLETED_MAYBE;
    }
}

sub delete {
    $logger->info("Deleting request object");
    my $self = shift;
}

sub send {
    $logger->info("Sending request");
    my ( $self, $invoke_flags ) = @_;
}

sub get_response {
    $logger->info("Getting response");
    my ( $self, $response_flags ) = @_;
}

# private methods
sub get_connection {
    $logger->info("Building connection");
    my ($self)     = @_;
    my $peer       = "$self->{host}:$self->{port}";
    my $peerssl    = $peer . ":$self->{ssl}";
    my $connection = $CORBA::Request::connections{$peerssl};
    return $connection if $connection;
    my $error;

    # Running with taint checks requires us to untaint $peer before use.
    unless ( $error = !( $peer =~ /^([\w\d.-]+:\d+)$/ ) ) {

        # IO::Socket has a noisy way of reporting errors
        local $SIG{__WARN__} = sub { $error = $_[0] };
        $connection = IO::Socket::INET->new(
            PeerAddr => $1,
            Proto    => 'tcp'
        );
    }
    if ( $error || !$connection ) {
        delete $CORBA::Request::connections{$peerssl};
        return undef if ( $! == ECONNREFUSED );                # Retryable error
        return undef if ( $error =~ /connection refused/i );   # Older Perls
        $logger->fatal("CORBA::COMM_FAILURE");
        throw new CORBA::COMM_FAILURE;
    }
    if ( $self->{ssl} ) {
        require IO::SSL;
        $connection = IO::SSL->connect($connection);
    }
    return $CORBA::Request::connections{$peerssl} = $connection;
}

# private functions

1;

__END__

=head1 NAME

CORBA::Request

A class to ...

=head1 SYNOPSIS

use CORBA::Request;

=head1 DESCRIPTION

The CORBA::Request class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 add_arg (method)

Parameters:
    name
    arg_type
    value
    len
    arg_flags

Insert description of method here...

=head2 invoke (method)

Parameters:
    invoke_flags

Insert description of method here...

=head2 delete (method)

Parameters:
    none

Insert description of method here...

=head2 send (method)

Parameters:
    invoke_flags

Insert description of method here...

=head2 get_response (method)

Parameters:
    response_flags

Insert description of method here...

=head2 get_connection (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head1 FILES

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

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut