# $Id: idl2perl.PL 1760 2006-07-26 04:02:28Z rvosa $
# TODO: add namespace prefix
use Config;
use File::Basename qw(basename dirname);
use Log::Log4perl;
use COPE::CORBA::ORB;
Log::Log4perl::init( COPE::CORBA::ORB->LOGPERLCONF );
my $logger = Log::Log4perl::get_logger('id2perl');

chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$//
        if ($Config{'osname'} eq 'VMS' or
            $Config{'osname'} eq 'OS2');  # "case-forgiving"
open OUT,">$file" or die "Can't create $file: $!";
chmod(0755, $file);
print "Extracting $file (with variable substitutions)\n";

print OUT <<"!GROK!THIS!";
$Config{'startperl'} -w
    eval 'exec perl -S \$0 "\$@"'
        if 0;

!GROK!THIS!

print OUT <<'!NO!SUBS!';
# $Id: idl2perl.PL 1760 2006-07-26 04:02:28Z rvosa $
# Copyright (c) 1997 Lunatech Research / Bart Schuller <schuller@lunatech.com>
# See the file "Artistic" in the distribution for licensing and
# (lack of) warranties.
# Modifications copyright of contributors listed in file Changes, 1997-2000.

# use Carp;
# BEGIN { $SIG{__WARN__} = $SIG{__DIE__} = sub { confess @_ } }
use strict;
use Getopt::Long;
use IO::File 'SEEK_SET';
use File::Path;
use Experimental::Exception;
use Data::Dumper; # RAV
sub record_pkg($$);

my %options;

$options{'prefix'}       = '';      # added --prefix=Foo::Bar for namespaces
$options{'force'}        = 0;       # added --force flag to overwrite stubs
$options{'scoped-enums'} = 0;
$options{'impl'}         = 0;
$options{'prototypes'}   = 1;
$options{'combine'}      = 0;
$options{'outdir'}       = 'out';	# TODO ='.' is ok, but NOT =''  !!!
$options{'irref'}        = '';
$options{'include'}      = '';
@::SAVE_ARGV = @ARGV;
Getopt::Long::Configure(qw(pass_through));
GetOptions(\%options, 'force!', 'combine!', 'impl!', 'scoped-enums!',
	   'prototypes!', 'prefix:s', 'outdir:s', 'irref:s', 'include=s');

my $topfile = '_file_';				# Default output file
my $file_lvl_output;				# File handle for above.
my %writtento;					    # Track files opened
my %comb_handles;				    # File handles for -combine
my %tc_map;					        # Compiler's type code cache

my @uselists = (['']);				# Inter-module dependencies
my @pilists = ([]);				    # Required pre-initialisations
my %modules = ('COPE::CORBA::Object' => 1);	# Used with @uselists
my %compiled;					# For -combine flag
my $base_deps;					# Record base file dependencies
my $fullname;					# Current module/interface
my $version = '$Revision: 1.2 $';		# RCS version string
$version = substr(substr($version, 11), 0, -2);

# The next set of variables are black magic for indirect type codes.

my ($indirect_nest, $indirect_index);

use COPE::CORBA::ORB;
use COPE::IR;
use COPE::CORBA::TCKind;

# The various things we may be compiling
my $logger = Log::Log4perl::get_logger('id2perl');
sub STUB  ()	{ $logger->debug(1); 1 };
sub TYPES ()	{ $logger->debug(2); 2 };
sub IMPL  ()	{ $logger->debug(3); 3 };
sub SKEL  ()	{ $logger->debug(4); 4 };

$logger->debug("Going to initialize ORB");
my $orb = CORBA::ORB_init();
$logger->debug("Initialized ORB");

# Get an object reference for the Interface Repository either from
# the command line (-irref) or by running the IR program irserv.

my($irref,$irfh,$pid);
my $infile = pop @ARGV;

if ($irref = $options{irref}) {
    if ($irref !~ /^IOR:/i) {
	   open(REFFILE, '<' . $irref) or die "Can not open $irref";
	   ($irref) = (<REFFILE> =~ /(\S*)/);
	   close REFFILE;
	   $logger->debug("Read IOR");
    }
} else {
    $irfh = new IO::File;
    $pid = open($irfh,
		'irserv  --ior ' .
		($options{'include'} ? "-I $options{'include'} " : '') .
		"@ARGV $infile|");
    if (!$pid) {
        $logger->fatal("Failed to open pipe from irserv: $!\n");
        die "Failed to open pipe from irserv: $!\n";
    }
    $logger->debug("Opened pipe from irserv");
    $irref = <$irfh>;
}
$infile =~ s/.idl$//i;				# Strip .idl suffix

# Turn the IR reference into an object so that its methods can be invoked.

chomp $irref;
if (!($irref =~ /^IOR:/i)) {
    $logger->fatal("idl2perl read '$irref' when expecting an IOR.");
    fail("idl2perl read '$irref' when expecting an IOR.\n");
}

$logger->debug("Narrowing reference to repository");
my $obj = $orb->string_to_object($irref);
my $ir = CORBA::Repository->_narrow($obj);
$logger->debug("Narrowed reference to repository");

# Prime the compiler's type code cache

record_pkg('IDL:omg.org/CORBA/Object:1.0', 'CORBA::Object');

# Compile the contents of the IR into perl.

if ( $pid && !kill(0, $pid) ) {
    $logger->fatal("Child process died!");
    fail("Child process died!\n");
}
try {
    foreach (@{$ir->contents(CORBA::DefinitionKind::dk_all, 1)}) {
	compile( undef, $_, TYPES, split( /::/, $options{'prefix'} ) );
    }

        # Output dependencies ('use' commands) if file scope output was generated.
        list_uses($file_lvl_output) if defined($file_lvl_output);

} 'Default' => sub {
    kill 'TERM',$pid if $pid;
    $irfh->close if !$options{irref};		# Probable Perl bug
    throw;					# Rethrow to make visible
};

# If there were file-level definitions other than modules and interfaces
# then rename the resulting output file to be the same as the IDL file,
# but only if the name is available.

$topfile = $options{outdir} . '/' . $topfile . '.pm';
if (-f $topfile) {
    my $outfile = $options{outdir} . '/' . $infile . '.pm';
    if (-f $outfile) {
	warn "Unable to rename $topfile as $outfile.\n";
	if ($base_deps) {
	    warn "Fix 'use $infile' lines or rename IDL file and re-try.\n";
	}
    } else {
	rename($topfile, $outfile) unless (-f $outfile);
    }
}


# Murder the child IR process if it exists.

if (!$options{irref} && !kill('TERM', $pid)) {
    fail("irserv process died!\n");
}

# The rest of of this file contains the routines that compile the
# repository contents into Perl.

use COPE::CORBA::TCKind;
use COPE::CORBA::TypeCode 'TCI_INDIRECT';


# Utility function to make a directory

sub make_dir {
    $logger->debug("Making dir");
    my($dir) = @_;
    if (! -d $dir) {
#        mkdir $dir, 0777 or die "mkdir $dir failed: $!";
	File::Path::mkpath([$dir], 0, 0777) or fail("mkpath $dir failed: $!");
    }
}


# Create (or re-open) a component file

sub open_component($$$$@) {
    $logger->debug("Opening component");
    my($name, $header, $package_prefix, $ftype, @modpath) = @_;

    # The name of the subdirectory where the module file goes

    my $directory;
    if ($options{combine}) {
        if (defined $comb_handles{$name}) {
	    return $comb_handles{$name};	# Already open
	}
	$directory = $options{outdir};
    } else {
	$directory = join('/', ($options{outdir}, @modpath));
    }

    my $open_pm     = ">$directory/${name}";

    # 0=not reopening so print headers
    # 1=are reopening so don't print headers
    my $reopening   = 0;

    # check to see if we've already written out files at this level
    # note: DO NOT just check for directory or file existance! - remember,
    #   we could be re-compiling over old generated files/directories.
    # NOTE: right now, multiple "1;"s, and redundant "package" lines
    #   are generated.

    if (defined($writtento{$open_pm})) {
	# RE-open not just open
	$open_pm    = ">" . $open_pm;
	$reopening = 1;
    } else {
	$writtento{$open_pm} = 1;
    }

    make_dir($directory);
    my $fh = new IO::File "$open_pm.pm" or
	fail("open $open_pm.pm failed: $!");

    return $fh if $reopening;
    $comb_handles{$name} = $fh if $options{combine};

    my $date = scalar localtime;

    $fh->print('# $Id: idl2perl.PL,v 1.2 2005/07/23 12:10:18 rvosa Exp$' . "\n");
    $fh->print("# Automatically generated $ftype code.  DO NOT EDIT.\n");
    $fh->print("# Generated on $date by idl2perl $version with command:\n");
    $fh->print("# $0 ", join(' ', @::SAVE_ARGV), "\n\n");
    $fh->print($header);
    return $fh;
}

sub open_module($@) {
    $logger->debug("Opening module");
    my ($name, @modpath) = @_;

    my $ftype = "module";
    my $header = "use COPE::CORBA::TypeCode;\n\n";

    my $prefix = join('::', @modpath);
    if (scalar(@modpath) > 0) {
	   $header .= "use $prefix;\n\n";
    }

    if ($options{combine}) {
	   $name = $infile.'_types';
	   $ftype = 'types';
    }
    return open_component($name, $header, $prefix, $ftype, @modpath);
}

# helper function for building 'use $prefix...'

sub use_pre($$$) {
    $logger->debug("Building use prefix");
    my ($prefix, $name, $post) = @_;
    if ($prefix) {
        return "use " . $prefix . "::" . $name . $post;
    }
    else {
        return "use " . $name . $post;
    }
}

sub open_stub($@) {
    $logger->info("Opening stub");
    my ($name, @modpath) = @_;

    $name = $infile if $options{combine};
    my $prefix = join('::', @modpath);
    my $header = use_pre($prefix, $name, "_types;\n") .
		    "use COPE::CORBA::Object;\n\n";

    return open_component($name, $header, $prefix, "stub", @modpath);
}

sub open_skel($@) {
    $logger->debug("Opening skeleton");
    my($name, @modpath) = @_;

    $name = $infile if $options{combine};
    my $prefix = join('::', @modpath);
    my $header = "use COPE::CORBA::Skel;\n"
		 . use_pre($prefix, $name, "_types;\n\n");

    return open_component($name.'_skel', $header, $prefix, "skeleton", @modpath);
}

sub open_types($@) {
    $logger->debug("Opening types");
    my ($name, @modpath) = @_;

    my $header = "use COPE::CORBA::TypeCode;\n";
    my $prefix = join('::', @modpath);

    $name = $infile if $options{combine};
    my $fh = open_component($name.'_types', $header, $prefix,
			    "types", @modpath);
    $file_lvl_output = $fh if $options{combine};
    return $fh;
}

sub open_impl($@) {
    $logger->debug("Opening implementation");
    my($name, @modpath) = @_;

    # The name of the subdirectory where the module file goes

    my ($directory, $cached);
    if ($options{combine}) {
	$directory = $options{outdir};
	$name = $infile;
        if (defined($cached = $comb_handles{$name . '_impl'})) {
	    return $cached;	# Already open
	}
    } else {
	$directory = join('/', ($options{outdir}, @modpath));
    }

    # The perl package name

    my $package_prefix = join('::', @modpath);

    my $open_pm     = "$directory/${name}_impl";

    # 0=not reopening so print headers
    # 1=are reopening so don't print headers

    my $reopening   = 0;

    # check to see if we've already written out files at this level
    # note: DO NOT just check for directory or file existance! - remember,
    #   we could be re-compiling over old generated files/directories.
    # NOTE: right now, multiple "1;"s, and redundant "package" lines
    #   are generated.

    if (defined($writtento{$open_pm})) {
	$reopening = 1;
    } else {
	$writtento{$open_pm} = 1;
    }

    make_dir($directory);
    my $date = scalar localtime;

    # Do not overwrite existing file as it may have been edited.

    my $filename = $open_pm . '.pm';
    if (-e $filename and not $options{force} ) {
	my $newname = "$open_pm" . "-sample";
	if (! $reopening) {
	    print STDERR "idl2perl: WARNING: not writing over $filename\n";
	    print STDERR "        : putting $filename into $newname.pm\n";
	}
	$open_pm = $newname;
    }

    if ($reopening) {
	$open_pm = '>>' . $open_pm;
    }
    else {
	$open_pm = '>' . $open_pm;
    }
    my $fh = new IO::File "$open_pm.pm";
    if (!$fh) {
	print STDERR "open $open_pm.pm failed: $!\n";
	print STDERR "Skipping that file...\n";
	return undef;
    }

    return $fh if $reopening;
    $comb_handles{$name . '_impl'} = $fh if $options{combine};

    $fh->print('# $Id: idl2perl.PL 1760 2006-07-26 04:02:28Z rvosa $' . "\n");
    $fh->print("# Automatically generated sample implementation code\n");
    $fh->print("# PLEASE EDIT     PLEASE EDIT      PLEASE EDIT.\n");
    $fh->print("# Generated on $date by idl2perl $version with command:\n");
    $fh->print("# $0 ", join(' ', @::SAVE_ARGV), "\n\n");
    $fh->print(use_pre($package_prefix, $name, "_types;\n"));
    $fh->print(use_pre($package_prefix, $name, "_skel;\n\n"));

    return $fh;
}

# This package defines an auxiliary class used by the next
# function and Experimental::Exception.

{
    package COPE::Recompile;

    @COPE::Recompile::ISA = qw(Experimental::Exception);
    sub new {
	$logger->info("Creating \"COPE::Recompile\" object");
	my $dummy;
	bless \$dummy, __PACKAGE__;
    }
}

# This is the top-level subroutine of the compiler

sub compile ($$$@) {
    $logger->debug("Compiling");
    $indirect_nest = undef;			# Mark as new object
    $indirect_index = 0;			# Reset indirect TC index
    __compile(@_);

    # Flush temporary cached type code references, as they must
    # not be referenced outside their defining module.

    delete @tc_map{1..$indirect_index};
}

# Internal subroutine for compile that can call itself recursively
# without reseting things.  It does this to restart itself using a
# more complicated code generation scheme that can deal with indirect
# type codes.

sub __compile {
    my($out, $object, $pass, @modpath) = @_;
    
    my $dk = $object->def_kind;
    my $restart_off;

    try {
	if ($dk == CORBA::DefinitionKind::dk_Module) {
	    compile_Module($out, CORBA::ModuleDef->_narrow($object), $pass,
			   @modpath);
	    $fullname = join('::', @modpath);		# Restore old value.
	} elsif ($dk == CORBA::DefinitionKind::dk_Interface) {
	    compile_Interface($out, CORBA::InterfaceDef->_narrow($object),
			      $pass, @modpath);
	    $fullname = join('::', @modpath);		# Restore old value.
	} elsif ((defined($out) && ($restart_off = $out->tell)),
		 $dk == CORBA::DefinitionKind::dk_Attribute) {

	    # Most of the remaining definition kinds may involve
	    # a recursive type code.  If so, the compilation will be
	    # abandoned and restarted using the
	    # output file position stored just above.

	    compile_Attribute($out, CORBA::AttributeDef->_narrow($object),
			      $pass, @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Operation) {
	    compile_Operation($out, CORBA::OperationDef->_narrow($object),
			      $pass, @modpath);
	} elsif ((defined($out) ||
		  ($out = open_component($topfile,
					 "use COPE::CORBA::TypeCode;\n\n",
					 '', 'file-level types'),
		   $file_lvl_output = $out,
		   $restart_off = $out->tell)),
		 $dk == CORBA::DefinitionKind::dk_Enum) {

	    # This and the remaining definition kinds can occur at file level
	    # and do not cause a new output file to be opened.
	    # If this is the first such definition, an output file is
	    # opened now, in the expression just above.
	    # The restart offset needs to be stored again.

            compile_Enum($out, CORBA::EnumDef->_narrow($object),
			 $pass, @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Constant) {
	    compile_Constant($out, CORBA::ConstantDef->_narrow($object),
			     $pass, @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Struct) {
	    compile_Struct($out, CORBA::StructDef->_narrow($object), $pass,
			   @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Alias) {
	    compile_Alias($out, CORBA::AliasDef->_narrow($object),
			  $pass, @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Exception) {
	    compile_Exception($out, CORBA::ExceptionDef->_narrow($object),
			      $pass, @modpath);
	} elsif ($dk == CORBA::DefinitionKind::dk_Union) {
	    compile_Union($out, CORBA::UnionDef->_narrow($object),
			  $pass, @modpath);
	} else {
	    print "Skipping dk = $dk in " . join('::', @modpath) . "\n";
	}
    } catch 'COPE::Recompile' => sub {

	# This exception is thrown when tc_as_perl() encounters
	# an indirect type code reference and the machinery to deal
	# with it is turned off.  (Off is the default state.)
	# It is now on, so the correct code can be generated.
	# Discard the tail of the output file and try again.

	$out->seek($restart_off, SEEK_SET);
	__compile($out, $object, $pass, @modpath);
    }
}

# A module is a pure container.  It writes a Perl module that may be empty,
# creates a directory and adds a component to the active package name.

sub compile_Module ($$$@) {
    $logger->debug("Compiling module");
    my($out, $module, $pass, @modpath)= @_;

    my($name) = $module->name;
    my $mod_out = open_module($name, @modpath);

    # Tack our module name onto the end of the path for our components

    push @modpath, $name;
    $fullname = join('::', @modpath);
    $mod_out->print("# module $fullname (" . $module->id . ")\n\n");

    push @uselists, [$fullname];	# See list_uses().
    push @pilists, [];
    $modules{$fullname} = 1;		# Record that this is a module.
    $compiled{$fullname} = 1;		# ... and was compiled in this run.

    foreach (@{$module->contents(CORBA::DefinitionKind::dk_all, 1)}) {
        compile($mod_out, $_, TYPES, @modpath);
    }

    list_uses($mod_out);				# List required modules
}

# An alias in the IR corresponds to a typedef in IDL.
# It is compiled as a type code definition in its own perl module.
# This module has no '_interface' variable and the type code is
# for the definition, not the alias itself.

sub compile_Alias ($$$@) {
    $logger->debug("Compiling alias");
    my($out, $alias, $pass, @modpath)= @_;

    if ($pass != TYPES) {
	return 1;
    }

    my($name) = $alias->name;
    my($id) = $alias->id;

    $out->print("# Alias $name (" . $id . ")\n\n");
    $name = join('::', @modpath, $name);
    $out->print("package $name;\n");

    my $tc = $alias->type;
    $out->print("CORBA::TypeCode::_new_type_impl('", $name, "', ",
		tc_as_ref($tc), ");\n\n");
    record_pkg($id, $name);
}

# An enum is compiled as a set of subroutines returning the appropriate
# constants.  They are in their own package if the scoped-enums option
# is set (the default).

sub compile_Enum ($$$@) {
    $logger->debug("Compiling enum");
    my($out, $enum, $pass, @modpath) = @_;

    if ($pass != TYPES) {
	return 1;
    }

    my($name) = $enum->name;
    my($id) = $enum->id;
    my $pkgname = join('::', @modpath, $name);

    $out->print("# enum $name (", $id, ")\n\n");
    $out->print("CORBA::TypeCode::_new_type_impl('", $pkgname, "', ",
		enum_as_perl($enum->type, $pkgname), ");\n\n");
    record_pkg($id, $pkgname);

    if ($options{'scoped-enums'}) {	# enum elements  in their own package.
	$out->print("package $pkgname;\n");
    } else {
	my $parname = scalar(@modpath) ? join('::', @modpath) : 'main';
	$out->print("package $parname;\n");
    }

    my $counter = 0;
    foreach (@{$enum->members}) {
        $out->print("sub $_ () {$counter}\n");
        $counter++;
    }
    $out->print("\n");
}

# A struct definition is compiled as a perl package whose blessed
# members represent instances of that structure, implemented as a hash.

sub compile_Struct ($$$@) {
    $logger->debug("Compiling struct");
    my($out, $struct, $pass, @modpath) = @_;

    if ($pass != TYPES) {
	return 1;
    }

    my($name) = $struct->name;
    my($id) = $struct->id;

    $out->print("# struct $name (", $id, ")\n\n");

    $name = join('::', @modpath, $name);


    $out->print("package $name;\n\n");
    $out->print('@', $name, "::ISA=qw(CORBA::_Struct);\n");
    record_pkg($id, $name);
    $out->print("CORBA::TypeCode::_new_type_impl('", $name, "', ",
		tc_as_perl($struct->type, $name), ");\n\n");
}

# Add quotes to non-numeric constants.

sub litconst($) {
    $logger->debug("Quoting non-numeric constants");
    my ($val) = @_;

    return ($val =~ /^(-|\+)?[0-9]+$/) ? $val : "'$val'";
}

# A union definition is compiled as a perl package whose blessed
# members represent instances of that union.
# They are implemented as two-element arrays: [discriminator, value].
# The module has a separate accessor function for each member type.

sub compile_Union ($$$@) {
    $logger->debug("Compiling union");
    my($out, $union, $pass, @modpath) = @_;

    if ($pass != TYPES) {
	return 1;
    }

    my $u_tc = $union->type;
    my $d_tk = ($u_tc->discriminator_type())->kind;
    my($name) = $union->name;
    my($id) = $union->id;
    $out->print("# union $name (", $id, ")\n\n");

    $name = join('::', @modpath, $name);

    $out->print("package $name;\n");

    $out->print('@', $name, "::ISA=qw(CORBA::_Union);\n");
    record_pkg($id, $name);
    $out->print("CORBA::TypeCode::_new_type_impl('", $name, "', ",
		tc_as_perl($u_tc, $name), ");\n");

    $out->print("use Experimental::Exception;\n");
    $out->print("use COPE::CORBA::Exception;\n\n");

    $out->print("sub discriminator (\$) {\n");
    $out->print("	my (\$self) = \@_;\n");
    $out->print("	return \$self->[0];\n}\n\n");

    my $member_count = $u_tc->member_count;

    for(my $counter=0; $counter < $member_count;) {
	my $member_name = $u_tc->member_name($counter);
	my $default = 0;

	# See if this member has more than one label

	my $lcount = $counter;
	my @labels = ();
	for (; $lcount < $member_count; $lcount++) {
		last if $u_tc->member_name($lcount) ne $member_name;
		push @labels, $u_tc->member_label($lcount);

		# Is one of them the default?

		$default = 1 if ($lcount == $u_tc->default_index);
	}

	$counter += @labels;

	# If this is the default case, all we care about are the
	# *other* values

	if ($default) {
	    @labels = ();
	    for ($lcount = 0; $lcount < $member_count; $lcount++) {
		if ($u_tc->member_name($lcount) ne $member_name) {
		    push @labels, $u_tc->member_label($lcount);
		}
	    }
	    $out->print("# Default member\n\n");
	}

	$out->print("sub ",$member_name," (\$;\$\$) {\n");
	$out->print("    my (\$self,\$discriminator,\$value) = \@_;\n");
	$out->print("    if (defined(\$value)) {\n");
	$out->print("        if (");
	foreach (0..$#labels) {
		my $test = $default ? (($d_tk == tk_char) ? 'eq' : '==')
				    : (($d_tk == tk_char) ? 'ne' : '!=');
		my $logic= $default ? "||" : "&&";
		$out->print("(\$discriminator $test ",
			    litconst($labels[$_]), ")");
		if ($_ != $#labels) {
			$out->print(" $logic ");
		}
	}
	$out->print(") {\n");
	$out->print("            throw new CORBA::BAD_PARAM;\n");
	$out->print("        }\n");
	$out->print("        \$self->[0] = \$discriminator;\n");
	$out->print("        \$self->[1] = \$value;\n");
	$out->print("        return;\n");
	$out->print("    }\n");
	$out->print("    my \$x = \$self->[0];\n");
	$out->print("    if (");
	foreach (0..$#labels) {
		my $test = $default ? (($d_tk == tk_char) ? 'ne' : '!=')
				    : (($d_tk == tk_char) ? 'eq' : '==');
		my $logic= $default ? "&&" : "||";
		$out->print("(\$x $test ", litconst($labels[$_]), ")");
		if ($_ != $#labels) {
			$out->print(" $logic ");
		}
	}
	$out->print(") {\n");
	$out->print("        return \$self->[1];\n");
	$out->print("    }\n");
	$out->print("    throw new CORBA::BAD_OPERATION;\n");
	$out->print("}\n\n");
    }
}

# Constants are compiled into the current package

sub compile_Constant ($$$@) {
    $logger->debug("Compiling constant");
    my($out, $constant, $pass, @modpath) = @_;

    if ($pass != TYPES) {
	return 1;
    }

    my($name) = $constant->name;
    $out->print("# constant $name (", $constant->id, ")\n\n");

    my $any_val = $constant->value();
    my $kind = $any_val->type->_noalias_kind();
    my $value = $any_val->value;
    if (($kind == tk_char) || ($kind == tk_string)) {
	$value = "'". $value . "'";
    }
    $out->print('$', join('::', @modpath), "::$name = $value;\n\n");
}


# An exception is compiled much like a struct.

sub compile_Exception ($$$@) {
    $logger->debug("Compiling exception");
    my($out, $exception, $pass, @modpath) = @_;

    if ($pass != TYPES) {
	return 1;
    }

    my($name) = $exception->name;
    my($id) = $exception->id;
    $out->print("# exception $name (", $id, ")\n\n");

    $name = join('::', @modpath, $name);

    $out->print("package $name;\n");
    $out->print("use COPE::CORBA::Exception;\n");
    $out->print('@', $name, "::ISA=qw(CORBA::UserException);\n");

    $out->print("CORBA::TypeCode::_new_type_impl('", $name, "', ",
		tc_as_perl($exception->type, $name), ");\n\n");
    record_pkg($id, $name);
}

# An interface is compiled into a package and has
# a 'new' function for the skeleton package.

sub compile_Interface ($$$@) {
    $logger->debug("Compiling interface");
    my($out, $interface, $pass, @modpath) = @_;
    my $interface_id = $interface->id;
    my($name) = $interface->name;

    my @subpath = (@modpath, $name);
    $fullname = join('::', @subpath);
    my $s = "# interface $fullname ($interface_id)\n\n";

    $out->print($s) if @modpath;	# Comment processing of interface.
    record_pkg($interface_id, $fullname);
    $compiled{$fullname} = 1;	# Compiled in this run.
    push @uselists, [$fullname];	# See list_uses().
    push @pilists, [];

    # The interface and any types declared inside go into the _types file.

    my $types = open_types($name, @modpath);
    $types->print($s);
    $types->print("package $fullname;\n");

    # Deal with interface inheritance here.  The Visisgenic IR returns the
    # absolute interface names with a leading '::', so that is stripped.

    my $base_interfaces = $interface->base_interfaces;
    my $m;
    $types->print('@', $fullname, '::ISA=qw(');
    $types->print(join(' ', map({($m = $_->absolute_name) =~ s/^:://; $options{'prefix'}.'::'.$m}
				@{$interface->base_interfaces}),
		       "CORBA::Object);\n"));
    $types->print("CORBA::TypeCode::_new_type_impl('", $fullname, "', ",
		  interface_as_perl($interface->type), ");\n\n");
    foreach (@{$interface->contents(CORBA::DefinitionKind::dk_all, 1)}) {
        compile($types, $_, TYPES, @subpath);
    }

    # Print out skeleton file

    my $skelname = $fullname . "_skel";
    my $skel = open_skel($name, @modpath);
    $skel->print($s);
    $skel->print("package $skelname;\n");
    $skel->print("use base qw(CORBA::_Skel);\n");
    if (@$base_interfaces) {
	$skel->print('unshift(@' . $skelname . '::ISA, qw(',
		     join('_skel ',
			  map({($m = $_->absolute_name) =~ s/^:://; $options{'prefix'}.'::'.$m}
			      @$base_interfaces)),
		     "_skel));\n");
    }
    $skel->print('$', $skelname, "::_id = 0;\n\n");
    $skel->print('$', $skelname, "::_interface = '",
		 $interface_id, "';\n\n");
    $skel->print(<<EOT);
sub new {
    my \$class = shift;
    my \$id = shift || \$${skelname}::_id++;
    my \$self = bless [\\%$skelname\::FIELDS, \$id], \$class;
    return \$self;
}

EOT
    foreach (@{$interface->contents(CORBA::DefinitionKind::dk_all, 1)}) {
        compile($skel, $_, SKEL, @subpath);
    }
    $skel->print("1;\n");
    $skel->close if !$options{combine};

    # And the stub file

    my $stub = open_stub($name, @modpath);
    $stub->print($s);
    $stub->print("package $fullname;\n\n");
    foreach (@{$interface->contents(CORBA::DefinitionKind::dk_all, 1)}) {
        compile($stub, $_, STUB, @subpath);
    }
    $stub->print("1;\n");
    $stub->close if !$options{combine};

    # The implementation, if required

    if ($options{impl}) {
	my $impl = open_impl($name, @modpath);
	if (!$impl) {
	    return 1;
	}
	$impl->print($s);
	my $impl_name = $fullname . "_impl";
	$impl->print("package $impl_name;\n");
	$impl->print("use COPE::CORBA::Servant;\n");
	$impl->print('@', $impl_name, "::ISA=qw(");
	$impl->print(join(' ', (map({$options{'prefix'}.$_->absolute_name . '_impl'}
				    @$base_interfaces),
				'CORBA::BOA::_Servant')));
	$impl->print(");\n");
	$impl->print("sub _skelname(\$) { '$skelname' }\n\n");

	# Compile the contents of the interface.

	foreach (@{$interface->contents(CORBA::DefinitionKind::dk_all, 1)}) {
	    compile($impl, $_, IMPL, @subpath);
	}
	$impl->print("\n1;\n");
	$impl->close if !$options{combine};
    }

    # After everything has been written, we have seen the whole
    # interface and can write the 'use' list to the types file and close it.

    list_uses($types);
}

# Attribute compiles to something like an operation with no arguments.
# There is an extra single-argument operation if it is not readonly.
# These are effectively the _get_xxx and _set_xxx operations passed
# by GIOP.

sub compile_Attribute ($$$@) {
    $logger->debug("Compiling attribute");
    my($out, $attribute, $pass, @modpath) = @_;

    if ($pass == TYPES) {
	return 1;
    }

    my $name = $attribute->name;
    $out->print("# attribute $name (". $attribute->id. ")\n\n");
    $out->print("sub $name");
    my $mode = $attribute->mode;
    if ($options{prototypes}) {
	if ($pass == SKEL) {
	    $out->print(' ($$)');
	}
	else {
	    $out->print(' ($');
	    if ($mode != CORBA::AttributeMode::ATTR_READONLY) {
		$out->print(';$');
	    }
	    $out->print(')');
	}
    }
    $out->print(" {\n");

    if ($pass == STUB) {
	$out->print('    my($self,@rest) = @_;', "\n");
	$out->print("    return \$self->_attribute('$name', ");
	$out->print(tc_as_ref($attribute->type));
	$out->print(", \@rest);\n");
	$out->print("}\n\n");
	return 1;
    }

    if ($pass == IMPL) {
	$out->print('    my($self');
	if ($mode != CORBA::AttributeMode::ATTR_READONLY) {
	    $out->print(',$newval');
	}
	$out->print(') = @_;', "\n");
    }

    if ($pass == SKEL) {
	$out->print('    my($self,$serverrequest) = @_;', "\n");
    }

    if ($mode != CORBA::AttributeMode::ATTR_READONLY) {
	if ($pass == SKEL) {
	    $out->print("    if (\$serverrequest->op_name() eq '_set_$name') {\n");
	    $out->print('        my $arg_list = [', "\n");
	    $out->print("            { 'argument'  =>\n");
	    $out->print('              { _type  => ');
	    $out->print(tc_as_ref($attribute->type), " },\n");
	    $out->print("                'arg_modes' => 0,\n");
	    $out->print("            },\n");
	    $out->print("        ];\n");
	    $out->print("        \$serverrequest->params(\$arg_list);\n");
	    $out->print("        \$self->{impl}->$name(\n");
	    $out->print("            \$arg_list->[0]{argument}{_value}\n");
	    $out->print("        );\n");
	    $out->print("    } else {\n");
	    $out->print('        my $result_ = { _type => ');
	    $out->print(tc_as_ref($attribute->type));
	    $out->print(" };\n");
	    $out->print("        \$serverrequest->params([]);\n");
	    $out->print("        \$serverrequest->result(\$result_);\n");
	    $out->print("        \$result_->{_value} = \$self->{impl}->$name();\n");
	    $out->print("    }\n");
	}
	else {
	    $out->print("    if (defined \$newval) {\n");
	    $out->print("        \$self->{'$name'} = \$newval;\n");
	    $out->print("    } else {\n");
	    $out->print("        return \$self->{'$name'};\n");
	    $out->print("    }\n");
	}
    } else {
	if ($pass == SKEL) {
	    $out->print('    my $result_ = { _type => ');
	    $out->print(tc_as_ref($attribute->type));
	    $out->print(" };\n");
	    $out->print("    \$serverrequest->params([]);\n");
	    $out->print("    \$serverrequest->result(\$result_);\n");
	    $out->print("    \$result_->{_value} = \$self->{impl}->$name();\n");
	}
	else {
	    $out->print("    return \$self->{'$name'};\n");
	}
    }

    $out->print("}\n\n");
}

# An operation is compiled into stub, skeleton and implementation
# functions.  The stub and skeleton use a description of the
# operation to perform marshalling and unmarshalling.

sub compile_Operation ($$$@) {
    $logger->debug("Compiling operation");
    my($out, $operation, $pass, @modpath) = @_;

    if ($pass == TYPES) {
	return 1;
    }

    my $name = $operation->name;
    my $params = $operation->params;
    my $result = $operation->result;

    # Output the function header for stub, skeleton and implementation

    $out->print("# operation $name (". $operation->id. ")\n\n");
    $out->print("sub $name");

    if ($options{prototypes}) {
	if ($pass == SKEL) {

	    # The arguments of the skelton function are self and the request.

	    $out->print(' ($$)');
	} else {
	    $out->print(" (", '$' x (1+scalar @$params), ")");
	}
    }
    $out->print(" {\n");

    if ($pass == SKEL) {

	# Start the skeleton function.

	$out->print('    my($self,$serverrequest) = @_;', "\n");
	if ($result->kind() != tk_void) {

	    # Output supporting data for the return result to skeleton..

	    $out->print('    my $result_ = { _type => ');
	    $out->print(tc_as_ref($result));
	    $out->print(" };\n");
	}

	# Start the argument descriptions in the skeleton.

	$out->print('    my $arg_list = [', "\n");
    } else {

	# Output the 'my' call for naming the function arguments.

	$out->print('    my($self');
	foreach (@$params) {
	    $out->print(',$', $_->{'name'});
	}
	$out->print(') = @_;', "\n");
    }

    if ($pass == STUB) {

	# Output supporting data for the return result to stub.

	$out->print('    my $result_ = { _type => ');
	$out->print(tc_as_ref($result));
	$out->print(" };\n");
	$out->print('    my $request_ = $self->create_request(', "\n");
	$out->print("        'operation' => '$name',\n");

	# Start the argument descriptions in the stub.

	$out->print("        'arg_list'  => [\n");
    }

    if ($pass != IMPL) {

	# Output an NV list describing the arguments to stub and skeleton

	foreach (@$params) {
	    $out->print("          { 'argument'  =>\n");
	    $out->print('            { _type  => ');
	    $out->print(tc_as_ref($_->{type}));

	    if ($pass == SKEL) {
		if ($_->{'mode'} == CORBA::ParameterMode::PARAM_OUT()) {

		    # 'out' parameters that are mapped as arrays or hashes
        	    # must be initialised as empty here as they are skipped
		    # in unmarshalling.

		    if ((($_->{type}->_noalias_kind() == tk_sequence) ||
			 ($_->{type}->_noalias_kind() == tk_array)) &&
			($_->{type}->_noalias_content_type()->_noalias_kind()
				!= tk_octet)) {
			$out->print(', _value => []');
		    } elsif ($_->{type}->_noalias_kind() == tk_struct) {
			$out->print(', _value => {}');
		    }
		}
		$out->print(" },\n");
	    } else {
		$out->print(', _value => $', $_->{'name'}, " },\n");
	    }

	    $out->print("            'arg_modes' => $_->{'mode'},\n");
	    $out->print("          },\n");
	}
    }

    if ($pass == STUB) {

	# Complete the stub function

	$out->print("        ],\n");
	$out->print("        'result' => \$result_");
	# ran - added support for "oneway" operations
	if ($operation->mode == CORBA::OperationMode::OP_ONEWAY) {
	    $out->print(",\n        'result_mode' => 'oneway'");
	}
	$out->print("\n    );\n");
	$out->print("    \$request_->invoke(0);\n");
	if ($result->kind() != tk_void) {
	    $out->print("    return \$result_->{_value};\n");
	}
    }

    if ($pass == SKEL) {
	$out->print("    ];\n");
	$out->print('    $serverrequest->params($arg_list);', "\n");

	# Generate the call to the implementation in the skeleton

	if ($result->kind() != tk_void) {

	    # Set up result marshalling

	    $out->print('    $serverrequest->result($result_);', "\n");
	    $out->print('    $result_->{_value} = ');
	} else {
	    $out->print('    ');
	}
	$out->print('$self->{impl}->', "$name(\n");
	my $i = 0;
	foreach (@$params) {
	    $out->print('        ');
	    if ($_->{type}->_needs_ref($_->{mode})) {
		$out->print('\\');
	    }
	    $out->print('$arg_list->[', $i++, "]{argument}{_value},\n");
	}
	$out->print("    );\n");
    }

    $out->print("}\n\n");
}

sub enum_as_perl($) {
    $logger->debug("Calling enum_as_perl");
    my($tc) = @_;
    my $retval;

    $retval = "CORBA::TypeCode::_create_enum_tc('";
    $retval .= $tc->id . "', '" . $tc->name . "', [";
    my $count = $tc->member_count;
    my $prefix = '';
    for (my $counter = 0; $counter < $count; $counter++) {
	$retval .= $prefix. "'". $tc->member_name($counter). "'";
	$prefix = ", ";
    }
    $retval .= "])";
    return $retval;
}

sub struct_as_perl($) {
    $logger->debug("Creating struct as perl");
    my($tc) = @_;
    my $retval;

    $retval = "CORBA::TypeCode::_create_struct_tc('";
    $retval .= $tc->id . "', '" . $tc->name . "', [";
    my $count = $tc->member_count;
    my $prefix = '';
    for (my $counter = 0; $counter < $count; $counter++) {
	$retval .= $prefix. "'". $tc->member_name($counter). "' => ";
	$retval .= tc_as_ref($tc->member_type($counter));
	$prefix = ", ";
    }
    $retval .= "])";
    return $retval;
}

sub union_as_perl($) {
    $logger->debug("Creating union as perl");
    my($tc) = @_;
    my $retval;

    $retval = "CORBA::TypeCode::_create_union_tc('";
    $retval .= $tc->id . "', '" . $tc->name . "',";
    $retval .= tc_as_ref($tc->discriminator_type) . ",";
    $retval .= $tc->default_index . ",[";

    my $count = $tc->member_count;
    my $prefix = '';
    for (my $counter = 0; $counter < $count; $counter++) {
	my $label=$tc->member_label($counter);
	if ($counter == $tc->default_index) {
		$label = "-1";
	}
	$retval .= $prefix . "'".$tc->member_name($counter)."',";
	$retval .= tc_as_ref($tc->member_type($counter));
	$retval .= ', ' . litconst($label);

	$prefix = ", ";
    }
    $retval .= "])";
    return $retval;
}


sub exc_as_perl($) {
    $logger->debug("Creating exception as perl");
    my($tc) = @_;
    my $retval;

    $retval = "CORBA::TypeCode::_create_exception_tc('";
    $retval .= $tc->id . "', '" . $tc->name . "', [";
    my $count = $tc->member_count;
    my $prefix = '';
    for (my $counter = 0; $counter < $count; $counter++) {
	$retval .= $prefix. "'". $tc->member_name($counter). "' => ";
	$retval .= tc_as_ref($tc->member_type($counter));
	$prefix = ", ";
    }
    $retval .= "])";
    return $retval;
}

sub interface_as_perl($) {
    $logger->debug("Returning interface as perl");
    my ($tc) = @_;
    return "CORBA::TypeCode::_create_interface_tc('" . $tc->id . "', '" . $tc->name . "')";
}

# Generate perl code to define a complex type code.

sub tc_as_perl ($) {
    $logger->debug("Creating type code as perl");
    my($tc) = @_;
    my $retval = '';
    my $kind = $tc->kind;
    my $id = $tc->id;
    my $indirecting = 0;

    if (defined($indirect_nest) && $id) {
	my $pkg;

	# To generate a definition of a type code that includes
	# indirection, a reference to it in the compiler's type code
	# cache must exist before the value is defined.
	# At run-time that entry must resolve to a reference to the
	# TC object, before its contents are created.  This allows
	# defininition of type codes that contain recursive indirection.

	$indirecting = 1;
	if ($indirect_index == 0 && defined($pkg = $tc_map{$id})) {

	    # This is the creation of the $_tc variable in an implementation
	    # package.  The compiler has already emitted the cache entry
	    # but it must refer to something.  The call to _pre_init()
	    # makes certain of that.
	    # This is rather fragile and ugly but ...

	    $retval = "(CORBA::TypeCode::_pre_init('" . $pkg . "'), ("
	} else {

	    # Something else, so a temporary cache entry for this TC
	    # must be created.  Here _new_basic() gives a temporary value
	    # that is fixed up by _fill_tc() once a dfinition has
	    # been created.

	    record_pkg($id, $indirect_index);
	    $retval =
		'(($COPE::tc_temp[' . $indirect_index .
		'] = CORBA::TypeCode->_new_basic(tk_null))->_fill_tc(';
	}
	$indirect_index++;
    }

    if ($kind == tk_struct) {
	$retval .= struct_as_perl($tc);
    } elsif ($kind == tk_except) {
	$retval .= exc_as_perl($tc);
    } elsif ($kind == tk_objref) {
	$retval .= interface_as_perl($tc);
    } elsif ($kind == tk_union) {
	$retval .= union_as_perl($tc);
    } elsif ($kind == tk_alias) {
        my $name = $tc->name;
        $retval = "CORBA::TypeCode::_create_alias_tc('$id', '$name', ";
        $retval .= tc_as_ref($tc->content_type);
        $retval .= ")";
    } elsif ($kind == tk_enum) {
	$retval .= enum_as_perl($tc);
    } elsif ($kind == tk_sequence) {
        my $length = $tc->length;
        $retval = "CORBA::TypeCode::_create_sequence_tc($length, ";
        $retval .= tc_as_ref($tc->content_type);
        $retval .= ")";
    } elsif ($kind == tk_array) {
        my $length = $tc->length;
        $retval = "CORBA::TypeCode::_create_array_tc($length, ";
        $retval .= tc_as_ref($tc->content_type);
        $retval .= ")";
    } elsif ($kind == tk_string) {
        my $length = $tc->length;
	if ($length > 0) {
	    $retval .= "CORBA::TypeCode::_create_string_tc($length)";
	} else {
	    $retval .= '$CORBA::_tc_string0';
	}
    } elsif ($kind == tk_indirect) {

	# Indirect type codes are explicit.  To deal with them,
	# an exception is used to back out the compilation to the
	# start of the current repository object.  Then it restarts,
	# generating some additional code to allow references
	# to incomplete type codes.

	if (!defined($indirect_nest)) {
	    $indirect_nest = 0;
	    throw 'COPE::Recompile';
	}
	if (++$indirect_nest > 4) {
	     die 'Lethal type code recursion detected';
	}
	$retval .= 'CORBA::TypeCode::__create_indirect_tc(' .
		   tc_as_ref($tc->[TCI_INDIRECT]) . ')';
	--$indirect_nest;
    } else {
	die "internal error, unexpected tk_kind ($kind) in tc_as_perl()";
    }

    # If we are generating code for a type code that includes indirection,
    # close the extra brackets here.

    $retval .= '))' if $indirecting;
    return $retval;
}


# Translate a type code returned from the IR to a perl fragment that
# can evaluated to yield a reference to the perl object representing
# the type code.  Run-time variables representing type codes with
# a repository id are cached in %tc_map by record_pkg().

sub tc_as_ref ($) {
    $logger->debug("Creating type code as ref");
    my($tc) = @_;

    my $kind = $tc->kind;
    if ($kind >= 0 && $kind <= 13) {
        return basic_tc_lookup($tc->kind);
    }

    if ($kind >= 23 && $kind <= 26) {
        return basic_tc_lookup_2($tc->kind);
    }
    if ($kind == CORBA::TypeCode::tk_string) {
	return tc_as_perl($tc);
    }

    my $pkname;
    my $id = $tc->id;
    if ($id && defined($pkname = $tc_map{$id})) {

	# This type is already known.  Record data that will add a 'use'
	# command for the defining file at the end of the current
	# output file.  If the defining file is unrelated, or lower in
	# the module hierarchy, then that may not be enough, as these files
	# may not be read in in the same order they were written.
	# In this case we record additional data, so that the relevant variable
	# will be pre-initialised and can be used before its value is defined.

	if ($pkname =~ /^[0-9]+$/) {
	    return '$COPE::tc_temp[' . $pkname . ']';	# Temporary reference
	} else {
	    if ($kind == CORBA::TypeCode::tk_objref) {
		record_dependency($pkname);	# Interface
		needs_init($pkname, $pkname);
            } elsif ($pkname =~ /^([\w]+)::.*/) {
		my $pfx = $1;			# Inside module or interface.
		record_dependency($pfx);
		needs_init($pkname, $pfx);
            } else {
		record_dependency($infile);	# Defined at file level.
		$modules{$infile} = 1;		# Treat top-level as module.
		$base_deps = 1;
	    }
	    return '$' . $pkname . '::_tc';
	}
    }
    return tc_as_perl($tc);
}

sub basic_tc_lookup($) {
    $logger->debug("Performing basic type code lookup");
    return  '$CORBA::_tc_' .
	('null', 'void', 'short', 'long', 'ushort', 'ulong', 'float', 'double',
	 'boolean', 'char', 'octet', 'any', 'TypeCode', 'Principal')[$_[0]];
}

sub basic_tc_lookup_2($) {
    $logger->debug("Performing basic type code lookup2");
    return  '$CORBA::_tc_' .
	('longlong', 'ulonglong', 'longdouble', 'wchar')[$_[0] - 23];
}

# Record a dependency of the current module or interface on another.

sub record_dependency($) {
    $logger->debug("Recording dependency");
    my $pkg = $_[0];
    if (!(grep {$_ eq $pkg} @{$uselists[-1]})) {
	push @{$uselists[-1]}, $pkg if $options{'prefix'} !~ /^$pkg/;
    }
}

# Record a need to ensure initialialisation of a type code before compiling
# The current module.  This is not done if the target belongs to an
# ancestor of the current module or interface.

sub needs_init ($$) {
    $logger->debug("Checking if needs init");
    my ($pkg, $prefix) = @_;

    return if ($fullname =~ /^$prefix/);

    if (!(grep {$_ eq $pkg} @{$pilists[-1]})) {
	push @{$pilists[-1]}, $pkg;
    }
}

# Link a Perl package or temporary TC reference index
# to the type code that it implements.

sub record_pkg($$) {
    $logger->debug("Recording package");
    my ($id, $package) = @_;
    my $epkg;
    die "No Repository ID for package $package\n" if !$id;

    if (($epkg = $tc_map{$id}) && ($epkg !~ /^[0-9]+$/)) {
	die "Packages $epkg and $package both represent id $id\n"
	  unless $epkg eq $package;
    } else {
	$tc_map{$id} = $package;		# Store package name
    }
}

# Dump 'use' commands at the tail of a type file that depends on
# type codes defined in other modules or interfaces from this compilation.
# Since this is called only at the end of a module or interface, it
# also closes the file.

sub list_uses($) {
    $logger->debug("Listing uses");
    my $out = $_[0];
warn Dumper( @uselists ); # RAV
    my $u_list = pop @uselists;
    my $pi_list = pop @pilists;
    shift @$u_list;			# Drop artificial reference to self

    if ($options{combine} && scalar(@uselists)) {

	# If we are combining output, combine all the dependency lists into
	# one, to be written at the end.  In this case %compiled records all
	# modules and interfaces that we have defined.
	# Combine pre-initialisation lists as well.

	map {record_dependency($_) if !$compiled{$_};} @$u_list;

	my $pi_top = $pilists[-1];
        map {
	    my $pkg = $_;
	    if (!(grep {$_ eq $pkg} @$pi_top)) {
		push @$pi_top, $pkg;
	    }
	} @$pi_list;

	return;
    }

    # Ensure initialisation of typecodes that this file refers to
    # at a lower or unrelated depth in the module/interface hierarchy.

    if (@$pi_list) {
	$out->print("BEGIN {CORBA::TypeCode::_pre_init(\n    '" .
		    join("', '", @$pi_list) .
		    "'\n)}\n");
    }

    # Write out the 'use' commands for this files's dependencies.
    foreach (@$u_list) {
	if ($_ !~ /^CORBA/ && !( $options{combine} && $compiled{$_} ) ) {
	    $_ .= '_types' if !$modules{$_};
	    $out->print("use $_;\n");
	}
    }

    $out->print("\n1;\n");
    $out->close();
}

# Give an error message and exit with error status.
# There seems to be a bug in Perl 5.005_02 that causes die() to exit with
# status zero if the pipe is still open.

sub fail {
    $logger->debug("Failing");
    if (!$options{irref}) {
	kill 'TERM',$pid if $pid;
	$irfh->close;
    }
    die @_;
}

__END__

=head1 NAME

idl2perl - translate CORBA IDL to Perl modules

=head1 SYNOPSIS

 idl2perl [<options>] <file.idl>

=head1 DESCRIPTION

This program processes a CORBA IDL file into Perl modules.
It uses an instance of the (Orbacus) Interface Repository program
B<irserv> to parse the input file, so this program
(or a substitute) must be in the path.
It creates a directory called F<out> if it does not already exist
and writes up to four files for each container construct found in the IDL file.
The B<-combine> option combines multiple output files and is useful for
IDL files that define many containers.

=head2 Type definition files

A Perl module describing the types defined is written
for each container construct (module, interface and the input file itself).
The file is named I<module-name>C<.pm> for a module and
I<interface-name>C<_types.pm>
for an interface.
Compilation of a module that contains any submodules or interfaces
also creates a directory, F<module-name> to hold their output files.

The file-level type file is created only if there are non-container
IDL definitions at file level.
It will take its name from the input file
(input file F<foo.idl> yields F<foo.pm>)
or F<_file_.pm> if that would clash.

=head2 Interface definition files

Two additional files are generated from each interface definition.
Client stubs are contained in I<interface-name>C<.pm> and server
skeletons in I<interface-name>C<_skel.pm>.
If the B<-impl> command-line option is used then a template for
server object implementation is written to the file
I<interface-name>C<_impl.pm>.

=head1 COMMAND OPTIONS

=over 4

=item B<-combine>

All output will be combined into a single file of each category,
named from the input file.

=item B<-include> include-dir

The value is passed to B<irserv> as the option I<-Iinclude-dir>.
This is the usual method of specifing the location of included IDL files.

=item B<-impl>

This option tells the program to create an implementation template
module (I<interface-name>C<_impl.pm>) for each interface it compiles.

=item B<-irref> iorspec

Specifies an Interface Repository whose contents are to be compiled.
This option and the IDL input file option are mutually exclusive.
The option value may be either an IOR string or the name of a file
whose first line should be an IOR string.

=item B<-noprototypes>

Suppresses the use of function prototypes in generated code.

=item B<-outdir> dir

Specifies the directory where output files will be created.
The default is F<./out>.

=item B<-scoped-enums>

The definitions of enum constants are normally placed in the package
containing the definition of the enum type.
With this option they are generated in the enum type's own package.

=item B<--> other-options

Arguments following a '--' option are passed directly to B<irserv>.

=back

!NO!SUBS!