#! /usr/bin/perl -w
#
# Sample CORBA server -- Perl version
#
# Roland Mas <99.roland.mas@gna.org>

use strict ;
use diagnostics ;

use vars qw/ $orb $poa $ior $f $p $id / ;

use Error qw(:try) ;
use CORBA::ORBit ;

$orb = CORBA::ORB_init("orbit-local-orb");
$orb->load_idl_file("sample.idl");
$poa = $orb->resolve_initial_references("RootPOA");


###
package Sample_interface ;
@Sample_interface::ISA = qw/ POA_Module_1::Sample_interface / ;

# This class is implemented as a hash
sub new {
    my $class = shift ;
    
    my %hash = () ;
    $hash{int} = 0 ;
    $hash{str} = "" ;
    
    return bless \%hash, $class ;
} ;

# The "int" attribute is read/write
sub _get_int {
    my $self = shift ;
    $self->{int} ;
} ;
sub _set_int {
    my ($self,$e) = @_;
    print "Setting attribute to $e\n" ;
    $self->{int} = $e;
} ;

# The "str" attribute is readonly...
sub _get_str {
    my $self = shift ;
    $self->{str} ;
} ;

# ...but we provide a method to change its value
sub change_str {
    my ($self,$c) = @_;
    
    if (length $c > 20) {
	throw Module_1::Sample_exception ;
    } else {
	$self->{str} = $c;
    }
} ;

# Two other methods
sub incr_int {
    my $self = shift ;
    $self->{int} ++ ;
} ;
sub str_length {
    my $self = shift ;
    length $self->{str} ;
} ;


###
package Factory ;
@Factory::ISA = qw/ POA_Module_1::Factory / ;

# This class is implemented as a nothing (no attributes needed)
sub new {
    my $class = shift ;
    
    my $null = 0 ;
    
    return bless \$null, $class ;
} ;

# This is what makes this class a factory: it creates objects on demand
sub new_sample {
    my ($self, $e, $c) = @_ ;
    my $sample = new Sample_interface ;
    $sample->{int} = $e ;
    $sample->{str} = $c ;
    my $id = $main::poa->activate_object ($sample) ;
    return $main::poa->id_to_reference ($id) ;
} ;


###
package Stack ;
@Stack::ISA = qw/ POA_Module_2::Stack / ;

# This class is implemented as a list
sub new {
    my $class = shift ;
    
    my @list = () ;
    
    return bless \@list, $class ;
} ;

# Simple method
sub push {
    my ($self, $n) = shift ;

    my @list = @$self ;
    push @list, $n ;
} ;

# Simple method (with exception)
sub pop {
    my $self = shift ;

    my @list = @$self ;
    if ($#list >= 0) {		# $#$self = $#list
	return pop @list ;
    } else {
	throw Module_1::Sample_exception ;
    } ;
} ;

# This *looks* like an attribute (cf. IDL), but is in fact a real method
sub _get_depth {
    my $self = shift ;
    my @list = @$self ;
    return scalar @list ;
} ;



###
package main ;

# Create factory object, save reference to it in a file
$f = new Factory ;
$id = $poa->activate_object ($f);
$ior = $orb->object_to_string ($poa->id_to_reference ($id));
open (OUT, "> factory.ior");
print OUT $ior;
close OUT;

# Create stack object, save reference to it in a file
$p = new Stack ;
$id = $poa->activate_object ($p);
$ior = $orb->object_to_string ($poa->id_to_reference ($id));
open (OUT, "> stack.ior");
print OUT $ior;
close OUT;

# Now get the CORBA server rolling
$poa->_get_the_POAManager->activate;
print "Entering mainloop.\n" ;
$orb->run ();