Permalink
Browse files

import version 2.45 from backpan

  • Loading branch information...
1 parent e21148d commit d50513abefb04b4927c8d49ee7e3b177704135bb @fperrad committed with Jul 19, 2005
Showing with 442 additions and 17 deletions.
  1. +4 −0 Changes
  2. +1 −1 META.yml
  3. +47 −3 node.pm
  4. +390 −13 repos_id.pm
View
4 Changes
@@ -1,5 +1,9 @@
Revision history for Perl extension CORBA::IDL.
+2.45 Tue Jul 19 18:30:00 2005
+ - node.pm : native exception
+ - repos_id.pm : add uidVisitor
+
2.44 Sun Apr 3 20:30;00 2005
- lexer.pm : /**< doxygen comment */
- parser* : BooleanLiteral->{value}
View
2 META.yml
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CORBA-IDL
-version: 2.44
+version: 2.45
version_from: node.pm
installdirs: site
requires:
View
50 node.pm
@@ -8,7 +8,7 @@ use UNIVERSAL;
package CORBA::IDL::node;
use vars qw($VERSION);
-$VERSION = '2.44';
+$VERSION = '2.45';
sub _Build {
my $proto = shift;
@@ -300,9 +300,15 @@ sub Configure {
}
$self->{list_export} = \@list;
$self->_CheckLocal($parser); # specialized
+ $self->_CheckNative($parser); # specialized
return $self;
}
+sub _CheckNative {
+ # If a native type is used as an exception for an operation, the
+ # operation must appear in either a local interface or a valuetype.
+}
+
sub Lookup {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -417,6 +423,25 @@ sub _CheckLocal {
}
}
+sub _CheckNative {
+ my $self = shift;
+ my ($parser) = @_;
+
+ # If a native type is used as an exception for an operation, the
+ # operation must appear in either a local interface or a valuetype.
+ foreach (@{$self->{list_export}}) {
+ my $defn = $parser->YYData->{symbtab}->Lookup($_);
+ if (exists $defn->{list_raise}) {
+ foreach (@{$defn->{list_raise}}) {
+ my $except = $parser->YYData->{symbtab}->Lookup($_);
+ if ($except->isa('NativeType')) {
+ $parser->Error("'$except->{idf}' used in a not local interface.\n");
+ }
+ }
+ }
+ }
+}
+
#
# 3.8.4 Forward Declaration
#
@@ -499,6 +524,25 @@ sub _CheckLocal {
}
}
+sub _CheckNative {
+ my $self = shift;
+ my ($parser) = @_;
+
+ # If a native type is used as an exception for an operation, the
+ # operation must appear in either a local interface or a valuetype.
+ foreach (@{$self->{list_export}}) {
+ my $defn = $parser->YYData->{symbtab}->Lookup($_);
+ if (exists $defn->{list_raise}) {
+ foreach (@{$defn->{list_raise}}) {
+ my $except = $parser->YYData->{symbtab}->Lookup($_);
+ if ($except->isa('NativeType')) {
+ $parser->Error("'$except->{idf}' used in a not local interface.\n");
+ }
+ }
+ }
+ }
+}
+
#
# 3.8.7 Local Interface
#
@@ -2027,8 +2071,8 @@ sub Lookup {
my ($parser, $name) = @_;
my $defn = $parser->YYData->{symbtab}->Lookup($name);
if (defined $defn) {
- unless ($defn->isa($class)) {
- $parser->Error("'$name' is not a $class.\n");
+ unless ($defn->isa($class) || $defn->isa('NativeType')) {
+ $parser->Error("'$name' is not a $class or a native type.\n");
}
return $defn->{full};
} else {
View
403 repos_id.pm
@@ -49,12 +49,13 @@ sub _set_repos_id {
}
}
-sub visitType {
+sub _get_defn {
my $self = shift;
- my ($type) =@_;
-
- if (ref $type) {
- $type->visit($self);
+ my ($defn) = @_;
+ if (ref $defn) {
+ return $defn;
+ } else {
+ return $self->{symbtab}->Lookup($defn);
}
}
@@ -67,11 +68,11 @@ sub visitSpecification {
my ($node) = @_;
if (exists $node->{list_import}) {
foreach (@{$node->{list_import}}) {
- $_->visit($self);
+ $self->_get_defn($_)->visit($self);
}
}
foreach (@{$node->{list_export}}) {
- $self->{symbtab}->Lookup($_)->visit($self);
+ $self->_get_defn($_)->visit($self);
}
}
@@ -83,7 +84,7 @@ sub visitImport {
my $self = shift;
my ($node) = @_;
foreach (@{$node->{list_decl}}) {
- $self->{symbtab}->Lookup($_)->visit($self);
+ $self->_get_defn($_)->visit($self);
}
}
@@ -96,7 +97,7 @@ sub visitModules {
my ($node) = @_;
$self->_set_repos_id($node);
foreach (@{$node->{list_export}}) {
- $self->{symbtab}->Lookup($_)->visit($self);
+ $self->_get_defn($_)->visit($self);
}
}
@@ -109,7 +110,7 @@ sub visitBaseInterface {
my ($node) = @_;
$self->_set_repos_id($node);
foreach (@{$node->{list_export}}) {
- $self->{symbtab}->Lookup($_)->visit($self);
+ $self->_get_defn($_)->visit($self);
}
}
@@ -133,7 +134,8 @@ sub visitBoxedValue {
my $self = shift;
my ($node) = @_;
$self->_set_repos_id($node);
- $self->visitType($node->{type});
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
}
#
@@ -154,7 +156,8 @@ sub visitTypeDeclarator {
my $self = shift;
my ($node) = @_;
$self->_set_repos_id($node);
- $self->visitType($node->{type});
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
}
sub visitNativeType {
@@ -205,7 +208,8 @@ sub visitUnionType {
}
}
}
- $self->visitType($node->{type});
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
}
sub visitEnumType {
@@ -334,5 +338,378 @@ sub visitFinder {
$self->_set_repos_id($node);
}
+###############################################################################
+
+package CORBA::IDL::uidVisitor;
+
+use Digest::SHA1 qw(sha1_hex);
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless($self, $class);
+ my ($parser) = @_;
+ $self->{symbtab} = $parser->YYData->{symbtab};
+ return $self;
+}
+
+sub _get_defn {
+ my $self = shift;
+ my ($defn) = @_;
+ if (ref $defn) {
+ return $defn;
+ } else {
+ return $self->{symbtab}->Lookup($defn);
+ }
+}
+
+sub _get_uid {
+ my $self = shift;
+ my ($str) = @_;
+ return uc(substr(sha1_hex($str),0, 16));
+}
+
+#
+# 3.5 OMG IDL Specification
+#
+
+sub visitSpecification {
+ my $self = shift;
+ my ($node) = @_;
+ if (exists $node->{list_import}) {
+ foreach (@{$node->{list_import}}) {
+ $self->_get_defn($_)->visit($self);
+ }
+ }
+ foreach (@{$node->{list_export}}) {
+ $self->_get_defn($_)->visit($self);
+ }
+}
+
+#
+# 3.6 Import Declaration
+#
+
+sub visitImport {
+ my $self = shift;
+ my ($node) = @_;
+ foreach (@{$node->{list_decl}}) {
+ $self->_get_defn($_)->visit($self);
+ }
+}
+
+#
+# 3.7 Module Declaration
+#
+
+sub visitModules {
+ my $self = shift;
+ my ($node) = @_;
+ foreach (@{$node->{list_export}}) {
+ $self->_get_defn($_)->visit($self);
+ }
+}
+
+#
+# 3.8 Interface Declaration
+#
+
+sub visitBaseInterface {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+ my $uid_str = $node->{idf};
+ foreach ($node->getInheritance()) {
+ my $base = $self->_get_defn($_);
+ $uid_str .= $base->{idf} . $base->{serial_uid};
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+ foreach (@{$node->{list_export}}) {
+ $self->_get_defn($_)->visit($self);
+ }
+ if (exists $node->{list_member}) {
+ foreach (@{$node->{list_member}}) {
+ my $defn = $self->_get_defn($_);
+ my $type = $self->_get_defn($defn->{type});
+ $type->visit($self);
+ $uid_str .= $defn->{idf};
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ }
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+sub visitForwardBaseInterface {
+# empty
+}
+
+#
+# 3.9 Value Declaration
+#
+
+sub visitStateMember {
+ # empty
+}
+
+sub visitInitializer {
+ # empty
+}
+
+sub visitBoxedValue {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
+ my $uid_str = $node->{idf};
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+#
+# 3.10 Constant Declaration
+#
+
+sub visitConstant {
+ # empty
+}
+
+#
+# 3.11 Type Declaration
+#
+
+sub visitTypeDeclarator {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
+ my $uid_str = $node->{idf};
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ if (exists $node->{array_size}) {
+ foreach (@{$node->{array_size}}) {
+ $uid_str .= "[" . $_->{value} . "]";
+ }
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+sub visitNativeType {
+ my $self = shift;
+ my ($node) = @_;
+ my $uid_str = $node->{idf};
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+#
+# 3.11.1 Basic Types
+#
+
+sub visitBasicType {
+ # empty
+}
+
+#
+# 3.11.2 Constructed Types
+#
+# 3.11.2.1 Structures
+#
+
+sub visitStructType {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+ my $uid_str = $node->{idf};
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+ foreach (@{$node->{list_member}}) {
+ my $defn = $self->_get_defn($_);
+ my $type = $self->_get_defn($defn->{type});
+ $type->visit($self);
+ $uid_str .= $defn->{idf};
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ if (exists $defn->{array_size}) {
+ foreach (@{$defn->{array_size}}) {
+ $uid_str .= "[" . $_->{value} . "]";
+ }
+ }
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+# 3.11.2.2 Discriminated Unions
+#
+
+sub visitUnionType {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+ $self->_get_defn($node->{type})->visit($self);
+ my $uid_str = $node->{idf};
+ my $type = $self->_get_defn($node->{type});
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+ foreach my $case (@{$node->{list_expr}}) {
+ my $elt = $self->_get_defn($case->{element});
+ foreach my $label (@{$case->{list_label}}) {
+ if (ref $label eq 'Default') {
+ $uid_str .= "_default_";
+ } else {
+ if (ref $label->{value} eq 'Enum') {
+ $uid_str .= $label->{value}->{idf};
+ } else {
+ $uid_str .= $label->{value};
+ }
+ }
+ }
+ my $defn = $self->_get_defn($elt->{value});
+ my $type = $self->_get_defn($defn->{type});
+ $uid_str .= $defn->{idf};
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ if (exists $defn->{array_size}) {
+ foreach (@{$defn->{array_size}}) {
+ $uid_str .= "[" . $_->{value} . "]";
+ }
+ }
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+# 3.11.2.4 Enumerations
+#
+
+sub visitEnumType {
+ my $self = shift;
+ my ($node) = @_;
+ my $uid_str = $node->{idf};
+ foreach (@{$node->{list_expr}}) {
+ $uid_str .= $_->{idf};
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+#
+# 3.11.3 Template Types
+#
+
+sub visitSequenceType {
+ my $self = shift;
+ my ($node) = @_;
+ return if (exists $node->{serial_uid});
+ my $type = $self->_get_defn($node->{type});
+ $type->visit($self);
+ my $uid_str = "_seq_";
+ $uid_str .= $type->{serial_uid} || $type->{value};
+ if (exists $node->{max}) {
+ $uid_str .= "_max_" . $node->{max}->{value};
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+sub visitStringType {
+ my $self = shift;
+ my ($node) = @_;
+ my $uid_str = $node->{value};
+ if (exists $node->{max}) {
+ $uid_str .= "_max_" . $node->{max}->{value};
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+sub visitWideStringType {
+ my $self = shift;
+ my ($node) = @_;
+ my $uid_str = $node->{value};
+ if (exists $node->{max}) {
+ $uid_str .= "_max_" . $node->{max}->{value};
+ }
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+sub visitFixedPtType {
+ my $self = shift;
+ my ($node) = @_;
+ my $uid_str .= "_d_" . $node->{d}->{value};
+ $uid_str .= "_s_" . $node->{s}->{value};
+ $node->{serial_uid} = $self->_get_uid($uid_str);
+}
+
+#
+# 3.12 Exception Declaration
+#
+
+sub visitException {
+ shift->visitStructType(@_);
+}
+
+#
+# 3.13 Operation Declaration
+#
+
+sub visitOperation {
+ # empty
+}
+
+#
+# 3.14 Attribute Declaration
+#
+
+sub visitAttribute {
+ # empty
+}
+
+#
+# 3.15 Repository Identity Related Declarations
+#
+
+sub visitTypeId {
+ # empty
+}
+
+sub visitTypePrefix {
+ # empty
+}
+
+#
+# 3.16 Event Declaration
+#
+
+#
+# 3.17 Component Declaration
+#
+
+sub visitProvides {
+ # empty
+}
+
+sub visitUses {
+ # empty
+}
+
+sub visitPublishes {
+ # empty
+}
+
+sub visitEmits {
+ # empty
+}
+
+sub visitConsumes {
+ # empty
+}
+
+#
+# 3.18 Home Declaration
+#
+
+sub visitFactory {
+ # empty
+}
+
+sub visitFinder {
+ # empty
+}
+
1;

0 comments on commit d50513a

Please sign in to comment.