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

# Copyright (c) 1997 Lunatech Research / Bart Schuller <schuller@lunatech.com>
# Modifications 1997-2000 Copyright by contributors listed in the file Changes.
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );

package CORBA::ORB;

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

=pod

=begin testing

ok( CORBA::ORB->_ior_to_object, "Testing \"CORBA::ORB\" _ior_to_object method" );

=end testing

=cut

sub _ior_to_object {
    $logger->debug("Creating object from IOR");
    my ( $self, $str ) = @_;
    my $m_ior      = pack( "H*", $str );
    my $byte_order = ord($m_ior);

    # skip first byte
    my $index = 1;
    my $ior = IOP::IOR::_unmarshal( \$m_ior, \$index, $byte_order );
    return CORBA::Object->_new_from_ior( $ior, $self );
}

=pod

=begin testing

ok( CORBA::ORB->string_to_object, "Testing \"CORBA::ORB\" string_to_object method" );

=end testing

=cut

sub string_to_object {
    $logger->info("Creating object from IOR");
    my ( $self, $str ) = @_;
    if ( $str =~ s@^IOR:@@i ) {
        return $self->_ior_to_object($str);
    }
    elsif ( $str =~ s@^corbaloc:@@i ) {
        return _corbaloc_to_object($str);
    }
    elsif ( $str =~ s@^corbaname:@@i ) {
        return _corbaname_to_object($str);
    }
    elsif ( $str =~ s@^iioploc://@@i ) {
        return $self->_iioploc_to_object($str);
    }
    elsif ( $str =~ s@^iiopname://@@i ) {
        return $self->_iiopname_to_object($str);
    }
    else {
        __bad_param();
    }
}

=pod

=begin testing

ok( CORBA::ORB->_corbaloc_to_object, "Testing \"CORBA::ORB\" _corbaloc_to_object method" );

=end testing

=cut

# Given a corbaloc: URL with the fixed prefix stripped, return an object.
sub _corbaloc_to_object {
    $logger->debug("Retrieving object from corbaloc");
    my ($str) = @_;
    my ($obj);
    $obj = _ions2_to_object($str);
    return _primary_object( $obj, $str );
}

=pod

=begin testing

ok( CORBA::ORB->_corbaname_to_object, "Testing \"CORBA::ORB\" _corbaname_to_object method" );

=end testing

=cut

# Given an corbaname: URL with the fixed prefix stripped, return an object.
sub _corbaname_to_object {
    $logger->debug("Retrieving object from corbaname");
    require COPE::CosNaming;
    my ($str) = @_;
    my ( $obj, $name );
    $obj = _ions2_to_object($str);
    ( $str, $name ) = ( $str =~ /^([^#]*)#?(.*)$/ );
    $obj = _primary_object( $obj, $str );
    $obj = CosNaming::NamingContext->_narrow($obj);
    return $obj->resolve( _str_to_name( _unspin($name) ) );
}

=pod

=begin testing

ok( CORBA::ORB->_primary_object, "Testing \"CORBA::ORB\" _primary_object method" );

=end testing

=cut

# Shared subroutine for primary object in corba(loc | name) URL.
sub _primary_object {
    $logger->debug("Retrieving primary object from corbal(loc|name)");
    my ( $obj, $str ) = @_;
    $str = _unspin($str);
    if ( $obj eq 'rir' ) {
        $str = 'NameService' unless $str;
        $obj = CORBA::ORB->resolve_initial_references($str);
    }
    else {
        $obj->{'object_key'} = $str;
    }
    return $obj;
}

=pod

=begin testing

ok( CORBA::ORB->_ions2_to_object, "Testing \"CORBA::ORB\" _ions2_to_object method" );

=end testing

=cut

# Process the server/protocol list from a corba(loc | name) URL.
sub _ions2_to_object {
    $logger->debug("Processing server/protocol list from corba(loc|name)");
    my ( $proto, $slist );
    $slist = _ions_server_list( $_[0], 1 );

    # Check for proto 'rir' or 'iiop' and provide default for port.
    map {
        $proto = $_->[3];
        if ( $proto eq 'rir' ) {
            __bad_param() unless ( @$slist == 1 ) || $_[0];
            $_[0] = $_->[1];    # Host part is actually service name
            return 'rir';
        }
        __bad_param() unless ( ( $proto eq 'iiop' ) && $_->[1] );
        $_->[2] = 2089 unless $_->[2];
    } @$slist;

    # Use only the first entry if there is more than one.
    return CORBA::Object->new(
        host       => $slist->[0]->[1],
        port       => $slist->[0]->[2],
        object_key => ''
    );
}

=pod

=begin testing

ok( CORBA::ORB->_ions_server_list, "Testing \"CORBA::ORB\" _ions_server_list method" );

=end testing

=cut

# Transform an IONS server/port list into a Perl array reference
# The string is stripped from the argument.
sub _ions_server_list {
    $logger->debug("Transforming IONS server/port list");
    my $standard = $_[1];    # Final IONS standard.
    my ( $proto, @slist );
    $_[0] =~ s@^([^/#]*)/?@@;    # Strip server list from argument.
    @slist = split( /,/, $1, -1 );
    @slist = ('') unless @slist;    # Ensure non-empty list
    map {
        if ($standard)
        {
            __bad_param() unless ( $_ =~ s@([a-z]*)?:@@ );    # Strip proto
            $proto = 'iiop' unless $proto = $1;
        }
        $_ = [ $_ =~ /^(?:([0-9]+\.[0-9]+)@)?([^:]*)(?::([0-9]*))?$/ ];
        __bad_param() unless @$_;
        $_->[0] = '1.0' unless $_->[0];    # Provide default for GIOP version.
        $_->[3] = $proto;
    } @slist;
    return \@slist;
}

=pod

=begin testing

ok( CORBA::ORB->_unspin, "Testing \"CORBA::ORB\" _unspin method" );

=end testing

=cut

# Remove RFC 2xxx quoting form a string.
sub _unspin {
    $logger->debug("Removing RFC 2xxx quoting");
    my $str = $_[0];
    $str =~ s/%([0-9a-fA-F]{2})/pack('H2', $1)/eg;
    return $str;
}

=pod

=begin testing

ok( CORBA::ORB->_str_to_name, "Testing \"CORBA::ORB\" _str_to_name method" );

=end testing

=cut

# Convert the suffix of an iiopname URL into a value of CosNaming::Name.
sub _str_to_name {
    $logger->debug("Converting iiopname suffix into CosNaming::Name value");
    my $str = $_[0];
    my ( $sep, @name, @parts );

    # Dot and both types of slash may be escaped by backslash.
    @parts = ( $str =~ m@((?:\\\\|\\\.|\\/|[^./])*)(\.|/|$)@g );
    map {    # Remove backslash quoting.
        if ( defined($_) && length($_) > 1 ) {
            $_ =~ s@\\\\@\\@g;
            $_ =~ s@\\\.@.@g;
            $_ =~ s@\\/@/@g;
        }
    } @parts;

    # Build the CosNaming::Name array
    do {
        push @name, { id => shift @parts, kind => '' };
        $sep = shift @parts;
        if ( $sep eq '.' ) {
            $name[-1]->{kind} = shift @parts;
            $sep = shift @parts;
        }
        __bad_param() if ( $sep && $sep ne '/' );
    } while $sep;
    return \@name;
}

=pod

=begin testing

ok( CORBA::ORB->_iioploc_to_object, "Testing \"CORBA::ORB\" _iioploc_to_object method" );

=end testing

=cut

# The rest of this file is for the obsolescent iioploc and iiopname forms.
# Given an iioloc: URL with the fixed prefix stripped, return an object.
sub _iioploc_to_object {
    $logger->debug("Return object from stripped iioloc: URL");
    my ( $self, $str ) = @_;
    my $obj = $self->_ions_to_object($str);
    $obj->{object_key} = _unspin($str);
    return $obj;
}

=pod

=begin testing

ok( CORBA::ORB->_ions_to_object, "Testing \"CORBA::ORB\" _ions_to_object method" );

=end testing

=cut

# Read the common prefix of an iioploc or iiopname URL and initialise a proxy.
# The string is stripped from the argument.
sub _ions_to_object {
	$logger->debug("Initialize proxy from iiop(loc|name): URL");
    my $slist;
    $slist = _ions_server_list( $_[1] );

    # Provide defaults for host and port.
    map {
        $_->[1] = 'localhost' unless $_->[1];
        $_->[2] = '9999'      unless $_->[2];
    } @$slist;

    # Use only the first entry if there is more than one.
    return CORBA::Object->new(
        host       => $slist->[0]->[1],
        port       => $slist->[0]->[2],
        object_key => ''
    );
}

=pod

=begin testing

ok( CORBA::ORB->_iiopname_to_object, "Testing \"CORBA::ORB\" _iiopname_to_object method" );

=end testing

=cut

# Given an iiopname: URL with the fixed prefix stripped, return an object.
sub _iiopname_to_object {
	$logger->debug("Return object from stripped iiopname: URL");
    my ( $self, $str ) = @_;
    require COPE::CosNaming;
    my $obj = $self->_ions_to_object($str);
    $obj->{object_key} = 'NameService';
    $obj = CosNaming::NamingContext->_narrow($obj);
    return $obj->resolve( _str_to_name( _unspin($str) ) );
}

=pod

=begin testing

ok( CORBA::ORB->__bad_param, "Testing \"CORBA::ORB\" __bad_param method" );

=end testing

=cut

# Any parsing error throws a BAD_PARAM system exception.
sub __bad_param {
	$logger->fatal("CORBA::BAD_PARAM");
    CORBA::BAD_PARAM->new->throw();
}
1;

__END__

=head1 NAME

CORBA::ORB

A class to ...

=head1 SYNOPSIS

use CORBA::ORB;

=head1 DESCRIPTION

The CORBA::ORB class implements ...

=head1 OPTIONS

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

=head1 SUBROUTINES

=head2 _ior_to_object (method)

Parameters:
    str

Insert description of method here...

=head2 string_to_object (method)

Parameters:
    str

Insert description of method here...

=head2 _corbaloc_to_object

Parameters:
    str

Insert description of subroutine here...

=head2 _corbaname_to_object

Parameters:
    str

Insert description of subroutine here...

=head2 _primary_object

Parameters:
    obj
    str

Insert description of subroutine here...

=head2 _ions2_to_object

Parameters:
    none

Arguments:
    $_[0] (modified)

Insert description of subroutine here...

=head2 _ions_server_list

Parameters:
    none

Arguments:
    $_[0] (modified)
    $_[1]

Insert description of subroutine here...

=head2 _unspin (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head2 _str_to_name (method)

Parameters:
    none

Arguments:
    $_[0]

Insert description of method here...

=head2 _iioploc_to_object (method)

Parameters:
    str

Insert description of method here...

=head2 _ions_to_object (method)

Parameters:
    none

Arguments:
    $_[0]
    $_[1]

Insert description of method here...

=head2 _iiopname_to_object (method)

Parameters:
    str

Insert description of method here...

=head2 __bad_param

Parameters:
    none

Insert description of subroutine here...

=head1 FILES

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

=head1 SEE ALSO

Related information ...

=head1 WARNINGS

...

=head1 NOTES

...

=head1 BUGS

What?

=cut