File Coverage

blib/lib/CORBA/IDL/Symbtab.pm

Criterion	Covered	Total	%
statement	12	517	2.3
branch	0	258	0.0
condition	0	111	0.0
subroutine	4	36	11.1
pod	0	21	0.0
total	16	943	1.7

#
#           Interface Definition Language (OMG IDL CORBA v3.0)
#

use strict;
use warnings;

package CORBA::IDL::Scope;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless $self, $class;
    my($symbtab, $classname, $full, $name) = @_;
    $self->{class} = $classname;
    $self->{full} = $full;
    $self->{entry} = {};
    return $self;
}

sub _Insert {
    my $self = shift;
    my($name, $defn) = @_;
    $self->{entry}->{lc $name} = $defn;
}

sub _Lookup {
    my $self = shift;
    return $self->{entry}->{lc shift};
}

##############################################################################

package CORBA::IDL::Symbtab;

our $VERSION = '2.63';

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless $self, $class;
    my($parser) = @_;
    $self->{current_root} = q{};
    $self->{current_scope} = q{};
    $self->{parser} = $parser;

    $self->{scopes} = {
        q{}     => new CORBA::IDL::Scope($self, 'CORBA::IDL::Module', q{}, q{})
    };
    $self->{prefix} = {};
    $self->{typeprefix} = {};
    # C Mapping
    $self->{c_mapping} = {};
#   $self->_Init();
    return $self;
}

#sub _Init {
#   my $self = shift;
#}

sub _CheckCMapping {
    my $self = shift;
    my($full) = @_;

    my $c_key = $full;
    $c_key =~ s/^:://;
    $c_key =~ s/::/_/g;
    if (exists $self->{c_mapping}{$c_key}) {
        $self->{parser}->Info(
                "'$full' is ambiguous (C mapping) with '$self->{c_mapping}{$c_key}'.\n");
    }
    else {
        $self->{c_mapping}{$c_key} = $full
    }
}

sub PushCurrentRoot {
    my $self = shift;
    my($node) = @_;
    my $name = $node->{idf};
    my $class = ref $node;
    $class = substr $class, rindex($class, ':') + 1;
##  print "PushCurrentRoot '$name' $class\n";
    $self->{parser}->Error("PushCurrentRoot: INTERNAL_ERROR ($class).\n")
            unless ($class eq 'Module');
    # OpenModule
    $self->{parser}->Error("PushCurrentRoot: INTERNAL_ERROR current_scope not empty ($self->{current_scope}).\n")
            if ($self->{current_scope});
    delete $self->{msg} if (exists $self->{msg});
    my $scope = $self->{current_root};
    my $key_prefix = $self->{parser}->YYData->{filename} . $scope;
    my $new_scope = $self->{current_root} . '::' . $name;
    my $prev = $self->{scopes}->{$scope}->_Lookup($name);
    if (defined $prev) {
        while ($prev->isa('Entry')) {
            $prev = $self->{scopes}->{$prev->{scope}}->_Lookup($name);
        }
        if ($prev->isa('Modules')) {
            # reopen
            push @{$prev->{list_decl}}, $node;
            if ($prev->{prefix} ne $node->{prefix}) {
                $self->{parser}->Error("Prefix redefinition for '$name'.\n");
            }
        }
        else {
            $self->{msg} ||= "Identifier '$name' already exists.\n";
            $self->{parser}->Error($self->{msg});
            unless (exists $self->{scopes}->{$new_scope}) {
                $self->{scopes}->{$new_scope} = new CORBA::IDL::Scope($self, ref $node, $new_scope, $name);
                my $modules = bless {
                        idf                 => $name,
                        full                => $new_scope,
                        prefix              => $node->{prefix},
                        _typeprefix         => $node->{_typeprefix},
                        list_decl           => [ $node ],
                }, 'CORBA::IDL::Modules';
                $modules->{typeprefix} = $node->{typeprefix}
                        if (exists $node->{typeprefix});
                $modules->{declspec} = $node->{declspec}
                        if (exists $node->{declspec});
                $self->{scopes}->{$new_scope}->_Insert($name, $modules);
            }
        }
    }
    else {
        $self->{scopes}->{$scope}->_Insert($name, bless({'scope' => $new_scope}, 'Entry'));
        $self->_CheckCMapping($new_scope);
        $self->{scopes}->{$new_scope} = new CORBA::IDL::Scope($self, ref $node, $new_scope, $name);
        my $modules = bless {
                idf                 => $name,
                full                => $new_scope,
                prefix              => $node->{prefix},
                _typeprefix         => $node->{_typeprefix},
                list_decl           => [ $node ],
        }, 'CORBA::IDL::Modules';
        $modules->{typeprefix} = $node->{typeprefix}
                if (exists $node->{typeprefix});
        $modules->{declspec} = $node->{declspec}
                if (exists $node->{declspec});
        $self->{scopes}->{$new_scope}->_Insert($name, $modules);
    }

    $self->{current_root} = $new_scope;
    $node->{full} = $new_scope;
    if (defined $node->{_typeprefix}) {
        my $typeprefix = $node->{_typeprefix};
        if ($typeprefix) {
            $typeprefix .= '/' . $node->{idf};
        }
        else {
            $typeprefix = $node->{idf};
        }
        $self->{typeprefix}->{$new_scope} = $typeprefix;
    }
    else {
        $key_prefix .= '::' . $node->{idf};
        my $prefix = $node->{prefix};
        if ($prefix) {
            $prefix .= '/' . $node->{idf};
        }
        else {
            $prefix = $node->{idf};
        }
        $self->{prefix}->{$key_prefix} = $prefix;
    }
    return;
}

sub PopCurrentRoot {
    my $self = shift;
    my($node) = @_;
    return unless (defined $node);
    return if ($self->{current_root} =~ s/::$node->{idf}$//);
    $self->{parser}->Error(
            "PopCurrentRoot: INTERNAL_ERROR $self->{current_root} $node->{idf}.\n");
    return;
}

sub PushCurrentScope {
    my $self = shift;
    my($node) = @_;
    my $name = $node->{idf};
    my $class = ref $node;
    $class = substr $class, rindex($class, ':') + 1;
##  print "PushCurrentScope '$name' $class\n";
    # Insert
    delete $self->{msg} if (exists $self->{msg});
    my $scope = $self->{current_root} . $self->{current_scope};
    my $key_prefix = $self->{parser}->YYData->{filename} . $scope;
    my $new_scope = $scope . '::' . $name;
    my $prev = $self->{scopes}->{$scope}->_Lookup($name);
    if (defined $prev) {
        while ($prev->isa('Entry')) {
            $prev = $self->{scopes}->{$prev->{scope}}->_Lookup($name);
        }
        if ($prev->isa('Forward' . $class)) {
            # the previous must be the same
            foreach (keys %{$prev}) {
                if (       $_ eq 'full'
                        or $_ eq 'filename'
                        or $_ eq 'lineno'
                        or $_ eq 'typeprefix'
                        or $_ eq '_typeprefix'
                        or $_ eq 'hash_attribute_operation' ) {
                    next;
                }
                if (       $_ eq 'id'
                        or $_ eq 'version' ) {
                    $node->{$_} = $prev->{$_};
                    next;
                }
                if ($prev->{$_} ne $node->{$_}) {
##                  print "$_ $prev->{$_} $node->{$_}\n";
                    if ($_ eq 'prefix') {
                        unless (defined $node->{_typeprefix}) {
                            $self->{parser}->Error(
                                    "Prefix redefinition for '$name'.\n");
                        }
                        next;
                    }
                    $self->{parser}->Error(
                            "Definition of '$name' conflicts with previous declaration.\n");
                    return;
                }
            }
            $node->{typeprefix} = $prev->{typeprefix}
                    if (exists $prev->{typeprefix});
            $self->{scopes}->{$scope}->_Insert($name, bless({'scope' => $new_scope}, 'Entry'));
            $self->{scopes}->{$new_scope} = new CORBA::IDL::Scope($self, ref $node, $new_scope, $name);
            $self->{scopes}->{$new_scope}->_Insert($name, $node);
        }
        else {
            $self->{msg} ||= "Identifier '$name' already exists.\n";
            $self->{parser}->Error($self->{msg});
            unless (exists $self->{scopes}->{$new_scope}) {
                $self->{scopes}->{$new_scope} = new CORBA::IDL::Scope($self, ref $node, $new_scope, $name);
                $self->{scopes}->{$new_scope}->_Insert($name, $node);
            }
        }
    }
    else {
        $self->{scopes}->{$scope}->_Insert($name, bless({'scope' => $new_scope}, 'Entry'));
        $self->_CheckCMapping($new_scope);
        $self->{scopes}->{$new_scope} = new CORBA::IDL::Scope($self, ref $node, $new_scope, $name);
        $self->{scopes}->{$new_scope}->_Insert($name, $node);
    }

    $self->{current_scope} .= '::' . $name;
    $node->{full} = $new_scope;
    if (defined $node->{_typeprefix}) {
        my $typeprefix = $node->{_typeprefix};
        if ($typeprefix) {
            $typeprefix .= '/' . $node->{idf};
        }
        else {
            $typeprefix = $node->{idf};
        }
        $self->{typeprefix}->{$new_scope} = $typeprefix;
    }
    else {
        $key_prefix .= '::' . $node->{idf};
        my $prefix = $node->{prefix};
        if ($prefix) {
            $prefix .= '/' . $node->{idf};
        }
        else {
            $prefix = $node->{idf};
        }
        $self->{prefix}->{$key_prefix} = $prefix;
    }
    return;
}

sub PopCurrentScope {
    my $self = shift;
    my($node) = @_;
    return unless (defined $node);
    return if ($self->{current_scope} =~ s/::$node->{idf}$//);
    $self->{parser}->Error(
            "PopCurrentScope: INTERNAL_ERROR $self->{current_scope} $node->{idf}.\n");
    return;
}

sub Insert {
    my $self = shift;
    my($node) = @_;
    if ($node->isa('Specification')) {
        $node->{full} = q{};
        $self->{scopes}->{''}->_Insert(q{}, $node);
        return;
    }
    my $name = $node->{idf};
    return unless ($name);
    delete $self->{msg} if (exists $self->{msg});
    my $scope = $self->{current_root} . $self->{current_scope};
##  print "Insert '$name' ",ref $node," => $scope\n";
    unless (exists $self->{scopes}->{$scope}) {
        warn "'$scope' not exist.\n";
        return;
    }
    my $prev = $self->{scopes}->{$scope}->_Lookup($name);
    if (defined $prev) {
        while ($prev->isa('Entry')) {
            $prev = $self->{scopes}->{$prev->{scope}}->_Lookup($name);
        }
        my $class = ref $prev;
        $class = substr $class, rindex($class, ':') + 1;
        if ($class =~ s/^Forward//) {
            if (ref $node ne $class) {
                $self->{parser}->Error(
                        "Definition of '$name' conflicts with previous declaration.\n");
                return;
            }
            else {
                # the previous must be the same
                foreach (keys %{$prev}) {
                    if (       $_ eq 'full'
                            or $_ eq 'lineno'
                            or $_ eq 'hash_attribute_operation' ) {
                        next;
                    }
                    if (       $_ eq 'id'
                            or $_ eq 'version' ) {
                        $node->{$_} = $prev->{$_};
                        next;
                    }
                    if ($_ eq 'filename') {
                        if (       $prev->isa('ForwardStruct')
                                or $prev->isa('ForwardUnion') ) {
                            if ($prev->{$_} ne $node->{$_}) {
                                $self->{parser}->Error(
                                "Definition of '$name' is not in the same file.\n");
                            }
                        }
                        next;
                    }
                    if ($prev->{$_} ne $node->{$_}) {
                        if ($_ eq 'prefix') {
                            unless (defined $node->{_typeprefix}) {
                                $self->{parser}->Error(
                                        "Prefix redefinition for '$name'.\n");
                            }
                            next;
                        }
                        $self->{parser}->Error(
                                "Definition of '$name' conflicts with previous declaration.\n");
                    }
                }
            }
        }
        else {
            if ($prev->{idf} eq $name) {
                $self->{msg} ||= "Identifier '$name' already exists.\n";
            }
            else {
                $self->{msg} ||= "Identifier '$name' collides with '$prev->{idf}'.\n";
            }
            $self->{parser}->Error($self->{msg});
            return;
        }
    }
    # insert
    $node->{full} = $scope . '::' . $name;
    $self->{scopes}->{$scope}->_Insert($name, $node);
    $self->_CheckCMapping($node->{full});
    return;
}

sub InsertForward {
    my $self = shift;
    my($node) = @_;
    my $name = $node->{idf};
    return unless ($name);
    my $class = ref $node;
    $class = substr $class, rindex($class, ':') + 1;
##  print "InsertForward '$name' '$node->{idf}'\n";
    delete $self->{msg} if (exists $self->{msg});
    my $scope = $self->{current_root} . $self->{current_scope};
    my $prev = $self->{scopes}->{$scope}->_Lookup($name);
    if (defined $prev) {
        while ($prev->isa('Entry')) {
            $prev = $self->{scopes}->{$prev->{scope}}->_Lookup($name);
        }
        my $class = ref $prev;
        $class = substr $class, rindex($class, ':') + 1;
        if ($class =~ /^Forward/) {
            # redeclaration
            if (ref $node ne ref $prev) {
                $self->{parser}->Error(
                        "Definition of '$name' conflicts with previous declaration.\n");
                return;
            }
            else {
                # the previous must be the same
                foreach (keys %{$prev}) {
                    if (       $_ eq 'full'
                            or $_ eq 'lineno'
                            or $_ eq 'filename'
                            or $_ eq 'typeprefix'
                            or $_ eq '_typeprefix' ) {
                        next;
                    }
                    if (       $_ eq 'id'
                            or $_ eq 'version' ) {
                        $node->{$_} = $prev->{$_};
                        next;
                    }
                    if ($prev->{$_} ne $node->{$_}) {
                        if ($_ eq 'prefix') {
                            unless (defined $node->{_typeprefix}) {
                                $self->{parser}->Error(
                                        "Prefix redefinition for '$name'.\n");
                            }
                            next;
                        }
                        $self->{parser}->Error(
                                "Definition of '$name' conflicts with previous declaration.\n");
                        return;
                    }
                }
            }
        }
        else {
            $self->{msg} ||= "Identifier '$name' already exists.\n";
            $self->{parser}->Error($self->{msg});
            return;
        }
    }
    # insert
    $node->{full} = $scope . '::' . $name;
    $self->{scopes}->{$scope}->_Insert($name, $node);
    return;
}

sub InsertInherit {
    my $self = shift;
    my($node, $name, $full) = @_;
##  print "InsertInherit '$name' $full \n";

    # Insert
    delete $self->{msg} if (exists $self->{msg});
    my $scope = $self->{current_root} . $self->{current_scope};
    my $prev = $self->{scopes}->{$scope}->_Lookup($name);
    if (defined $prev) {
        $self->{parser}->Error(__PACKAGE__ . "::InsertInherit: INTERNAL_ERROR ($full).\n");
    }
    else {
        my $scope_base = $full;
        $scope_base =~ s/::[0-9A-Z_a-z]+$//;
        $self->{scopes}->{$scope}->_Insert($name, bless({'scope' => $scope_base}, 'Entry'));
    }
    return;
}

sub InsertBogus {
    my $self = shift;
    my($node) = @_;
    my $scope =  $self->{current_root} . $self->{current_scope};
    $node->{full} = $scope . '::_seq_';
}

sub Lookup {
    my $self = shift;
    my($name) = @_;
    delete $self->{msg} if (exists $self->{msg});
    if (ref $name) {
        warn __PACKAGE__,"::Lookup $name ",caller," PB\n";
        return $name;
    }
    my $defn = $self->_Lookup($name);
    if (defined $defn) {
        $self->{parser}->Error($self->{msg}) if (exists $self->{msg});
    }
    else {
##      print __PACKAGE__,"::Lookup $name ",caller()," PB\n";
        $self->{parser}->Error("Undefined symbol '$name'.\n");
    }
    return $defn;
}

sub _Lookup {
    my $self = shift;
    my($name) = @_;
    my $defn;
##  print "_Lookup: '$name'\n";
    if (ref $name) {
        warn __PACKAGE__,"::_Lookup $name ",caller," PB\n";
        return $name;
    }
    return undef unless ($name);
    if ($name =~ /^::/) {
        # global name
##      print "_global name.\n";
        return $self->___Lookup($name);
    }
    elsif ($name =~ /^[0-9A-Z_a-z]+$/) {
        # identifier alone
        my $scope_init = $self->{current_root} . $self->{current_scope};
        my $scope = $scope_init;
##      print "_Lookup init : '$scope'\n";
        while (1) {
            # Section 3.15.3 Special Scoping Rules for Type Names
            my $g_name = $scope . '::' . $name;
            $defn = $self->__Lookup($scope, $g_name, $name);
            last if (defined $defn || $scope eq '');
            $scope =~ s/::[0-9A-Z_a-z]+$//;
##          print "_Lookup curr : '$scope'\n";
        };
        if (defined $defn) {
##          print "_found $name $scope_init $scope\n";
            my $scope_real = $defn->{full};
            $scope_real =~ s/::[0-9A-Z_a-z]+$//;
            while ($scope_init ne $scope) {
                my $node = $self->___Lookup($scope_init);
                if ($defn->isa('Modules') or ! $node->isa('Modules')) {
##                  print "_insert $name $scope_init $scope_real\n";
                    $self->{scopes}->{$scope_init}->_Insert($name, bless({'scope' => $scope_real}, 'Entry'));
                }
                $scope_init =~ s/::[0-9A-Z_a-z]+$//;
            }
        }
        return $defn;
    }
    else {
        # qualified name
        my @list = split /::/, $name;
        my $idf = pop @list;
        my $scoped_name = $name;
        $scoped_name =~ s/::[0-9A-Z_a-z]+$//;
##      print "_qualified name : '$scoped_name' '$idf'\n";
        my $scope = $self->_Lookup($scoped_name);       # recursive
        if (defined $scope) {
            $defn = $self->___Lookup($scope->{full} . '::' . $idf);
        }
        return $defn;
    }
}

sub __Lookup {
    my $self = shift;
    my ($scope, $g_name, $name) = @_;
##  print "__Lookup: '$scope' '$g_name' '$name'\n";
    my $defn = $self->___Lookup($g_name);
    return $defn if (defined $defn);
    return undef unless($scope);
    my $node = $self->___Lookup($scope);
    if (defined $node) {
##      print "__inherit $node->{full}\n";
        my @list;
        foreach ($node->getInheritance()) {
            my $base = $self->Lookup($_);
            if (defined $base) {
                $g_name = $base->{full} . '::' . $name;
                $defn = $self->___Lookup($g_name);
                if (defined $defn) {
                    my $found = 0;
                    foreach (@list) {
                        if ($defn == $_) {
                            $found = 1;
                            last;
                        }
                    }
                    push @list, $defn unless ($found);
                }
            }
        }
        if (@list) {
            if (scalar @list > 1) {
                $self->{parser}->Error("Ambiguous symbol '$name'.\n");
            }
            return pop @list;
        }
    }
    return undef;
}

sub ___Lookup {
    my $self = shift;
    my ($full) = @_;
##  print "___Lookup: '$full'\n";
    if ($full =~ /^((?:::[0-9A-Z_a-z]+)*)::([0-9A-Z_a-z]+)$/) {
        if (exists $self->{scopes}->{$1}) {
            my $defn = $self->{scopes}->{$1}->_Lookup($2);
            if (defined $defn) {
                while ($defn->isa('Entry')) {
                    $defn = $self->{scopes}->{$defn->{scope}}->_Lookup($2);
                    last unless (defined $defn);
                }
                unless (defined $defn) {
                    $self->{parser}->Error(__PACKAGE__ . "::___Lookup: INTERNAL_ERROR ($full).\n");
                    return undef;
                }
                if ($defn->{idf} ne $2) {
                    $self->{msg} = "Identifier '$2' collides with '$defn->{idf}'.\n";
                }
##              print "___found $defn->{full}\n";
                return $defn;
            }
            else {
##              print "___not found '$2' in '$1'.\n";
                return undef;
            }
        }
        else {
##          print "___not found scope '$1'.\n";
            return undef;
        }
    }
    else {
        $self->{parser}->Error(__PACKAGE__ . "::___Lookup: INTERNAL_ERROR not match ($full).\n");
        return undef;
    }
}

sub PragmaID {                          #   10.7.5.1    The ID Pragma
    my $self = shift;
    my($name, $id) = @_;
    my $node = $self->Lookup($name);
    if (defined $node) {
        if (exists $node->{typeid}) {
            $self->{parser}->Warning("TypeId/pragma conflict for '$self->{idf}'.\n");
        }
        if (exists $node->{id}) {
            $self->{parser}->Error("Repository ID redefinition for '$name'.\n")
                    unless ($id eq $node->{id});
        }
        else {
            $node->{id} = $id;
            $self->CheckID($node, $id);
        }
        if ($node->isa('Modules')) {
            foreach (@{$node->{list_decl}}) {
                if ($_->{filename} eq $self->{parser}->YYData->{filename}) {
                    $_->{id} = $id;
                }
            }
        }
    }
    else {
        $self->{parser}->Warning("Undefined symbol '$name' for '$id'.\n")
    }
}

sub CheckID {
    my $self = shift;
    my($node, $id) = @_;
    if ($id =~ /^IDL:/) {
        #   10.7.1      OMG IDL Format
        if ($id =~ /^IDL:[0-9A-Za-z_:\.\/\-]+:([0-9]+)\.([0-9]+)/) {
            my $version = $1 . '.' . $2;
            if (exists $node->{version}) {
                $self->{parser}->Error("Version redefinition for '$node->{idf}'.\n")
                        unless ($version eq $node->{version});
            }
            else {
                $node->{version} = $version;
            }
        }
        else {
            $self->{parser}->Error("Bad IDL format for Repository ID '$id'.\n");
        }
    }
    elsif ($id =~ /^RMI:/) {
        #   10.7.2      RMI Hashed Format
        $self->{parser}->Error("Bad RMI format for Repository ID '$id'.\n")
                unless ($id =~ /^RMI:[0-9A-Za-z_\[\-\.\/\$\\]+:[0-9A-Fa-f]{16}(:[0-9A-Fa-f]{16})?/);
    }
    elsif ($id =~ /^DCE:/) {
        #   10.7.3      DCE UUID Format
        $self->{parser}->Error("Bad DCE format for Repository ID '$id'.\n")
                unless ($id =~ /^DCE:[0-9A-Fa-f]{8}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{4}-[0-9A-Fa-f]{12}(:[0-9]+)?/);
    }
    elsif ($id =~ /^LOCAL:/) {
        #   10.7.4      LOCAL Format
        # followed by an arbitrary string.
    }
}

sub PragmaPrefix {                      #   10.7.5.2    The Prefix Pragma
    my $self = shift;
    my($prefix) = @_;
    my $key_prefix = $self->{parser}->YYData->{filename} . $self->{current_root} . $self->{current_scope};
    $self->{prefix}->{$key_prefix} = $prefix;
}

sub GetPrefix {
    my $self = shift;
    my $scope = $self->{current_root} . $self->{current_scope};
    my $key_prefix = $self->{parser}->YYData->{filename} . $scope;
    if (exists $self->{prefix}->{$key_prefix}) {
        return $self->{prefix}->{$key_prefix};
    }
    else {
        return q{};
    }
}

sub GetTypePrefix {
    my $self = shift;
    my $scope = $self->{current_root} . $self->{current_scope};
    if (exists $self->{typeprefix}->{$scope}) {
        return $self->{typeprefix}->{$scope};
    }
    else {
        return undef;
    }
}

sub PragmaVersion {                     #   10.7.5.3    The Version Pragma
    my $self = shift;
    my($name, $major, $minor) = @_;
    my $version = $major . '.' . $minor;
    my $node = $self->Lookup($name);
    if (defined $node) {
        if (exists $node->{version}) {
            $self->{parser}->Error("Version redefinition for '$name'.\n")
                    unless ($version eq $node->{version});
        }
        else {
            $node->{version} = $version;
        }
    }
}

sub CheckForward {
    my $self = shift;

    foreach my $scope (values %{$self->{scopes}}) {
        foreach my $entry (values %{$scope->{entry}}) {
            if ($entry->isa('_ForwardConstructedType')) {
                $self->{parser}->Error("'$entry->{idf}' never defined.\n");
            }
        }
    }
}

sub CheckRepositoryID {
    my $self = shift;

    foreach my $scope (values %{$self->{scopes}}) {
        foreach my $entry (values %{$scope->{entry}}) {
            if ($entry->isa('Modules') and exists $entry->{id}) {
                foreach (@{$entry->{list_decl}}) {
                    if (       ! exists $_->{id}
                            or $_->{id} ne $entry->{id} ) {
                        $self->{parser}->Error("Repository ID inconsistent for '$entry->{idf}'.\n");
                    }
                }
            }
        }
    }
}

sub Import {
    my $self = shift;
    my($node) = @_;

    my %imports = ($node->{value} => 1) ;
    my $dirname = $self->{parser}->YYData->{opt_i};
    my $fullname = $node->{value};
    $fullname =~ s/::/_/g;
    my $filename = $fullname . '.mod';
    $filename = $dirname . '/' . $filename if ($dirname);
    require $filename;
    my $scope = eval('$main::' . $fullname);
    if (defined $scope and $scope->isa('CORBA::IDL::Scope')) {
        my $class = $scope->{class};
        if (       $class eq 'CORBA::IDL::Module'
                or $class eq 'CORBA::IDL::RegularInterface'
                or $class eq 'CORBA::IDL::LocalInterface'
                or $class eq 'CORBA::IDL::AbstractInterface'
                or $class eq 'CORBA::IDL::RegularValue'
                or $class eq 'CORBA::IDL::BoxedValue'
                or $class eq 'CORBA::IDL::AbstractValue'
                or $class eq 'CORBA::IDL::RegularEvent'
                or $class eq 'CORBA::IDL::AbstractEvent' ) {
            $self->{scopes}->{$node->{value}} = $scope;
            my $root = $node->{value};
            $root =~ s/::([0-9A-Z_a-z]+)$//;
            my $name = lc $1;
            $self->{scopes}->{$root}->_Insert($name, bless({'scope' => $node->{value}}, 'Entry'));
            foreach (values %{$scope->{entry}}) {
                next if (ref $_ ne 'Entry');
                next if (exists $self->{scopes}->{$_->{scope}});
                $self->_Import($_->{scope}, \%imports);
            }
            $node->{list_decl} = [ keys %imports ];
        }
        else {
            $self->{parser}->Error("'$node->{value}' can't imported (bad type).\n");
        }
    }
    else {
        $self->{parser}->Error("Import: INTERNAL_ERROR ($node->{value}).\n");
    }
}

sub _Import {
    my $self = shift;
    my($full, $r_import) = @_;

    $r_import->{$full} = 1;
    my $dirname = $self->{parser}->YYData->{opt_i};
    my $fullname = $full;
    $fullname =~ s/::/_/g;
    my $filename = $fullname . '.mod';
    $filename = $dirname . '/' . $filename if ($dirname);
    require $filename;
    my $scope = eval('$main::' . $fullname);
    if (defined $scope and $scope->isa('CORBA::IDL::Scope')) {
        $self->{scopes}->{$full} = $scope;
        my $root = $full;
        $root =~ s/::([0-9A-Z_a-z]+)$//;
        my $name = lc $1;
        $self->{scopes}->{$root}->_Insert($name, bless({'scope' => $full}, 'Entry'));
        foreach (values %{$scope->{entry}}) {
            next if (ref $_ ne 'Entry');
            next if (exists $self->{scopes}->{$_->{scope}});
            $self->_Import($_->{scope}, $r_import);
        }
    }
    else {
        $self->{parser}->Error("_Import: INTERNAL_ERROR ($full).\n");
    }
}

sub Export {
    my $self = shift;
    use Data::Dumper;

    my $dirname = $self->{parser}->YYData->{opt_i};
    if ($dirname) {
        unless (-d $dirname) {
            mkdir $dirname
                    or die "can't create $dirname ($!).\n";
        }
    }
    foreach my $scope (values %{$self->{scopes}}) {
        my $fullname = $scope->{full};
        next unless ($fullname);
        $fullname =~ s/::/_/g;
        my $filename = $fullname . '.mod';
        $filename = $dirname . '/' . $filename if ($dirname);
        open my $OUT, '>', $filename
                or die "can't open $filename ($!).\n";
        my $d = Data::Dumper->new([$scope], [$fullname]);
        $d->Indent(1);
#       $d->Indent(0);
        $d->Purity(1);
        print $OUT "package main;\n";
        print $OUT $d->Dump();
        close $OUT;
    }
}

sub Dump {
    my $self = shift;
    use Data::Dumper;

    my $d = Data::Dumper->new([$self->{scopes}], [qw(scopes)]);
    $d->Indent(1);
#   $d->Indent(0);
    print $d->Dump();
}

##############################################################################

package CORBA::IDL::UnnamedSymbtab;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my($parser) = @_;
    my $self = {};
    bless $self, $class;
    $self->{parser} = $parser;
    $self->{entry} = {};
    return $self;
}

sub Insert {
    my $self = shift;
    my($name) = @_;
##  print "Insert '$name'\n";
    my $key = lc $name;
    if (exists $self->{entry}{$key}) {
        if ($self->{entry}{$key} eq $name) {
            $self->{parser}->Error(
                    "Identifier '$name' already exists.\n");
        }
        else {
            $self->{parser}->Error(
                    "Identifier '$name' collides with '$self->{entry}{$key}'.\n");
        }
    }
    else {
        $self->{entry}{$key} = $name;
    }
    return;
}

sub InsertUsed {
    my $self = shift;
    return if ($self->{parser}->YYData->{collision_allowed});
    my($name) = @_;
##  print "InsertUsed '$name'\n";
    my $key = lc $name;
    $self->{entry}{$key} = $name unless (exists $self->{entry}{$key});
    return;
}

1;