Skip to content
Browse files

import version 2.20 from backpan

  • Loading branch information...
1 parent 5f9a443 commit 99486b1320ea1a78d8f9556c1f08dbdc089db836 @fperrad committed Feb 19, 2004
Showing with 30,287 additions and 19,727 deletions.
  1. +7 −0 Changes
  2. +2 −0 MANIFEST
  3. +1 −0 Makefile.PL
  4. +1 −0 README
  5. +177 −113 ascii.pm
  6. +28 −11 idl.pl
  7. +142 −71 lexer.pm
  8. +5 −1 makefile.yapp
  9. +361 −288 node.pm
  10. +1,901 −1,828 parser20.pm
  11. +119 −150 parser20.yp
  12. +2,211 −2,134 parser21.pm
  13. +118 −150 parser21.yp
  14. +2,252 −2,187 parser22.pm
  15. +118 −155 parser22.yp
  16. +3,309 −3,275 parser23.pm
  17. +156 −228 parser23.yp
  18. +3,375 −3,295 parser24.pm
  19. +160 −235 parser24.yp
  20. +4,809 −5,120 parser30.pm
  21. +174 −441 parser30.yp
  22. +8,289 −0 parserxp.pm
  23. +2,523 −0 parserxp.yp
  24. +33 −33 repos_id.pm
  25. +16 −12 symbtab.pm
View
7 Changes
@@ -1,5 +1,12 @@
Revision history for Perl extension CORBA::IDL.
+2.20 Thu Feb 19 18:30:00 2004
+ - modifications of the AST (not compatible with 2.0x version)
+ - node.pm : bug with Math::BigInt 1.66 (Perl 5.8)
+ - add parser for XPIDL (Mozilla)
+ - idl.pl : add option -h (display help)
+ - idl.pl : add optinn -v (display version)
+
2.05 Wed Dec 17 12:30:00 2003
- improvement for EnumType
- improvement for value and boxed value
View
2 MANIFEST
@@ -8,6 +8,7 @@ parser22.pm
parser23.pm
parser24.pm
parser30.pm
+parserxp.pm
repos_id.pm
symbtab.pm
parser20.yp
@@ -16,6 +17,7 @@ parser22.yp
parser23.yp
parser24.yp
parser30.yp
+parserxp.yp
idl.pl
TypeCode.idl
makefile.yapp
View
1 Makefile.PL
@@ -16,6 +16,7 @@ WriteMakefile(
'parser23.pm' => '$(INST_LIBDIR)/IDL/parser23.pm',
'parser24.pm' => '$(INST_LIBDIR)/IDL/parser24.pm',
'parser30.pm' => '$(INST_LIBDIR)/IDL/parser30.pm',
+ 'parserxp.pm' => '$(INST_LIBDIR)/IDL/parserxp.pm',
'repos_id.pm' => '$(INST_LIBDIR)/IDL/repos_id.pm',
'symbtab.pm' => '$(INST_LIBDIR)/IDL/symbtab.pm',
},
View
1 README
@@ -26,6 +26,7 @@ See also:
CORBA::C - Implements CORBA C language mapping
CORBA::JAVA - Implements CORBA Java language mapping
CORBA::HTML - Implements HTML documentation
+ CORBA::XMLSchemas - Implements WSDL/SOAP interworking
References:
-----------
View
290 ascii.pm
@@ -5,20 +5,20 @@ use UNIVERSAL;
# Interface Definition Language (OMG IDL CORBA v3.0)
#
-package asciiVisitor;
+package CORBA::IDL::asciiVisitor;
+
+use File::Basename;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless($self, $class);
- my($parser) = @_;
+ my ($parser, $doc) = @_;
$self->{srcname} = $parser->YYData->{srcname};
$self->{symbtab} = $parser->YYData->{symbtab};
- my $filename = $self->{srcname};
- $filename =~ s/^([^\/]+\/)+//;
- $filename =~ s/\.idl$//i;
- $filename .= '.ast';
+ $self->{doc} = $doc;
+ my $filename = basename($self->{srcname}, ".idl") . ".ast";
open(STDOUT, "> $filename")
or die "can't open $filename ($!).\n";
$self->{num_key} = 'num_ascii';
@@ -47,7 +47,7 @@ sub get_tab {
sub _get_defn {
my $self = shift;
- my($defn) = @_;
+ my ($defn) = @_;
if (ref $defn) {
return $defn;
} else {
@@ -72,7 +72,7 @@ sub visitType {
sub visitSpecification {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
$self->reset_tab();
print "source $self->{srcname} \n\n";
foreach (@{$node->{list_decl}}) {
@@ -86,7 +86,7 @@ sub visitSpecification {
sub visitImport {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "import $node->{value}\n";
}
@@ -96,7 +96,7 @@ sub visitImport {
sub visitModules {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "module $node->{idf} '$node->{repos_id}'\n";
unless (exists $node->{$self->{num_key}}) {
$node->{$self->{num_key}} = 0;
@@ -108,10 +108,11 @@ sub visitModules {
sub visitModule {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
@@ -124,11 +125,12 @@ sub visitModule {
sub visitRegularInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "interface $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -140,11 +142,12 @@ sub visitRegularInterface {
sub visitAbstractInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "interface $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -156,11 +159,12 @@ sub visitAbstractInterface {
sub visitLocalInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "local interface $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -172,20 +176,29 @@ sub visitLocalInterface {
sub visitForwardRegularInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward interface $node->{idf}\n";
+ $self->inc_tab();
+ $self->_xp($node);
+ $self->dec_tab();
}
sub visitForwardAbstractInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward abstract interface $node->{idf}\n";
+ $self->inc_tab();
+ $self->_xp($node);
+ $self->dec_tab();
}
sub visitForwardLocalInterface {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward local interface $node->{idf}\n";
+ $self->inc_tab();
+ $self->_xp($node);
+ $self->dec_tab();
}
#
@@ -196,11 +209,12 @@ sub visitForwardLocalInterface {
sub visitRegularValue {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "regular value $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{modifier}) { # custom
print $self->get_tab(), "modifier $node->{modifier}\n";
}
@@ -215,7 +229,7 @@ sub visitRegularValue {
sub visitInheritanceSpec {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "inheritance spec\n";
$self->inc_tab();
if (exists $node->{modifier}) { # truncatable
@@ -236,8 +250,9 @@ sub visitInheritanceSpec {
sub visitStateMembers {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "state members\n";
+ $self->_xp($node);
$self->inc_tab();
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
@@ -247,7 +262,7 @@ sub visitStateMembers {
sub visitStateMember {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "$node->{modifier} $node->{idf}\n";
$self->inc_tab();
$self->visitType($node->{type});
@@ -261,11 +276,12 @@ sub visitStateMember {
sub visitInitializer {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "factory $node->{idf}\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
foreach (@{$node->{list_param}}) {
$_->visit($self);
}
@@ -283,11 +299,12 @@ sub visitInitializer {
sub visitBoxedValue {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "boxed value $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
$self->visitType($node->{type});
$self->dec_tab();
}
@@ -298,11 +315,12 @@ sub visitBoxedValue {
sub visitAbstractValue {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "abstract value $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -318,14 +336,20 @@ sub visitAbstractValue {
sub visitForwardRegularValue {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward regular value $node->{idf}\n";
+ $self->inc_tab();
+ $self->_xp($node);
+ $self->dec_tab();
}
sub visitForwardAbstractValue {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward abstract value $node->{idf}\n";
+ $self->inc_tab();
+ $self->_xp($node);
+ $self->dec_tab();
}
#
@@ -334,19 +358,20 @@ sub visitForwardAbstractValue {
sub visitConstant {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "constant $node->{idf}\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
$self->visitType($node->{type});
$node->{value}->visit($self); # expression
$self->dec_tab();
}
sub visitExpression {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "expression value $node->{value}\n";
$self->inc_tab();
foreach my $elt (@{$node->{list_expr}}) {
@@ -365,19 +390,19 @@ sub visitExpression {
sub visitUnaryOp {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "unop $node->{op}\n";
}
sub visitBinaryOp {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "binop $node->{op}\n";
}
sub visitLiteral {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "literal $node->{value}\n";
}
@@ -387,9 +412,10 @@ sub visitLiteral {
sub visitTypeDeclarators {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "type declarators\n";
$self->inc_tab();
+ $self->_xp($node);
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
@@ -398,16 +424,18 @@ sub visitTypeDeclarators {
sub visitTypeDeclarator {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
if (exists $node->{modifier}) { # native IDL2.2
print $self->get_tab(), "type declarator $node->{idf}\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "modifier $node->{modifier}\n";
} else {
print $self->get_tab(), "type declarator $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
$self->visitType($node->{type});
if (exists $node->{array_size}) {
foreach (@{$node->{array_size}}) {
@@ -424,7 +452,7 @@ sub visitTypeDeclarator {
sub visitBasicType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "basic type $node->{value}\n";
}
@@ -436,16 +464,17 @@ sub visitBasicType {
sub visitStructType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
if (defined $node->{list_expr}) {
print $self->get_tab(), "struct $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
push @{$self->{seq}}, $node;
foreach (@{$node->{list_expr}}) {
$_->visit($self); # members
}
-# foreach (@{$node->{list_value}}) {
-# $self->_get_defn($_)->visit($self); # single or array
+# foreach (@{$node->{list_member}}) {
+# $self->_get_defn($_)->visit($self); # member
# }
pop @{$self->{seq}};
$self->dec_tab();
@@ -456,47 +485,41 @@ sub visitStructType {
sub visitMembers {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "members\n";
$self->inc_tab();
- foreach (@{$node->{list_value}}) {
- $self->_get_defn($_)->visit($self); # single or array
+ foreach (@{$node->{list_member}}) {
+ $self->_get_defn($_)->visit($self);
}
$self->dec_tab();
}
-sub visitArray {
+sub visitMember {
my $self = shift;
- my($node) = @_;
- print $self->get_tab(), "array $node->{idf}\n";
+ my ($node) = @_;
+ print $self->get_tab(), "member $node->{idf}\n";
$self->inc_tab();
$self->visitType($node->{type});
- foreach (@{$node->{array_size}}) {
- $_->visit($self); # expression
+ if (exists $node->{array_size}) {
+ foreach (@{$node->{array_size}}) {
+ $_->visit($self); # expression
+ }
}
$self->dec_tab();
}
-sub visitSingle {
- my $self = shift;
- my($node) = @_;
- print $self->get_tab(), "single $node->{idf}\n";
- $self->inc_tab();
- $self->visitType($node->{type});
- $self->dec_tab();
-}
-
# 3.11.2.2 Discriminated Unions
#
sub visitUnionType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
if (defined $node->{list_expr}) {
print $self->get_tab(), "union $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
push @{$self->{seq}}, $node;
foreach (@{$node->{list_expr}}) {
$_->visit($self); # case
@@ -510,7 +533,7 @@ sub visitUnionType {
sub visitCase {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "case\n";
$self->inc_tab();
foreach (@{$node->{list_label}}) {
@@ -522,28 +545,28 @@ sub visitCase {
sub visitDefault {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "default\n";
}
sub visitElement {
my $self = shift;
- my($node) = @_;
- $self->_get_defn($node->{value})->visit($self); # single or array
+ my ($node) = @_;
+ $self->_get_defn($node->{value})->visit($self); # member
}
# 3.11.2.3 Constructed Recursive Types and Forward Declarations
#
sub visitForwardStructType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward struct $node->{idf}\n";
}
sub visitForwardUnionType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward union $node->{idf}\n";
}
@@ -552,11 +575,12 @@ sub visitForwardUnionType {
sub visitEnumType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "enum $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
foreach (@{$node->{list_expr}}) {
$_->visit($self); # enum
}
@@ -565,7 +589,7 @@ sub visitEnumType {
sub visitEnum {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "$node->{idf}\n";
}
@@ -575,7 +599,7 @@ sub visitEnum {
sub visitSequenceType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "sequence\n";
$self->inc_tab();
my $found = 0; # recursion prevention
@@ -600,7 +624,7 @@ sub visitSequenceType {
sub visitStringType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "string\n";
$self->inc_tab();
if (exists $node->{max}) {
@@ -611,7 +635,7 @@ sub visitStringType {
sub visitWideStringType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "wstring\n";
$self->inc_tab();
if (exists $node->{max}) {
@@ -622,7 +646,7 @@ sub visitWideStringType {
sub visitFixedPtType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "fixed\n";
$self->inc_tab();
$node->{d}->visit($self);
@@ -632,7 +656,7 @@ sub visitFixedPtType {
sub visitFixedPtConstType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "fixed\n";
}
@@ -642,18 +666,19 @@ sub visitFixedPtConstType {
sub visitException {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "exception $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{list_expr}) {
foreach (@{$node->{list_expr}}) {
$_->visit($self); # members
}
}
-# foreach (@{$node->{list_value}}) {
-# $self->_get_defn($_)->visit($self); # single or array
+# foreach (@{$node->{list_member}}) {
+# $self->_get_defn($_)->visit($self); # member
# }
$self->dec_tab();
}
@@ -664,11 +689,12 @@ sub visitException {
sub visitOperation {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "operation $node->{idf}\n";
$self->inc_tab();
+ $self->_xp($node);
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{attr}) { # oneway
print $self->get_tab(), "attribute $node->{attr}\n";
}
@@ -691,9 +717,10 @@ sub visitOperation {
sub visitParameter {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "parameter $node->{idf}\n";
$self->inc_tab();
+ $self->_xp($node);
# in, out, inout
print $self->get_tab(), "attribute $node->{attr}\n";
$self->visitType($node->{type});
@@ -702,7 +729,7 @@ sub visitParameter {
sub visitVoidType {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "void\n";
}
@@ -712,8 +739,9 @@ sub visitVoidType {
sub visitAttributes {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "attributes\n";
+ $self->_xp($node);
$self->inc_tab();
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
@@ -723,11 +751,11 @@ sub visitAttributes {
sub visitAttribute {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "attribute $node->{idf}\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{modifier}) { # readonly
print $self->get_tab(), "modifier $node->{modifier}\n";
}
@@ -751,13 +779,13 @@ sub visitAttribute {
sub visitTypeId {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "typeid $node->{idf} '$node->{value}'\n";
}
sub visitTypePrefix {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "typeprefix $node->{idf} '$node->{value}'\n";
}
@@ -767,11 +795,11 @@ sub visitTypePrefix {
sub visitRegularEvent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "regular event $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{modifier}) { # custom
print $self->get_tab(), "modifier $node->{modifier}\n";
}
@@ -786,11 +814,11 @@ sub visitRegularEvent {
sub visitAbstractEvent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "abstract event $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -802,13 +830,13 @@ sub visitAbstractEvent {
sub visitForwardRegularEvent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward regular event $node->{idf}\n";
}
sub visitForwardAbstractEvent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward abstract event $node->{idf}\n";
}
@@ -818,11 +846,11 @@ sub visitForwardAbstractEvent {
sub visitComponent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "component $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -841,19 +869,19 @@ sub visitComponent {
sub visitForwardComponent {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "forward component $node->{idf}\n";
}
sub visitProvides {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "provides $node->{idf} $node->{type}\n";
}
sub visitUses {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "uses $node->{idf} $node->{type}\n";
$self->inc_tab();
if (exists $node->{modifier}) { # multiple
@@ -864,19 +892,19 @@ sub visitUses {
sub visitPublishes {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "publishes $node->{idf} $node->{type}\n";
}
sub visitEmits {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "emits $node->{idf} $node->{type}\n";
}
sub visitConsumes {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "consumes $node->{idf} $node->{type}\n";
}
@@ -886,11 +914,11 @@ sub visitConsumes {
sub visitHome {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "home $node->{idf} '$node->{repos_id}'\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
if (exists $node->{inheritance}) {
$node->{inheritance}->visit($self);
}
@@ -913,11 +941,11 @@ sub visitHome {
sub visitFactory {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "factory $node->{idf}\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
foreach (@{$node->{list_param}}) {
$_->visit($self);
}
@@ -931,11 +959,11 @@ sub visitFactory {
sub visitFinder {
my $self = shift;
- my($node) = @_;
+ my ($node) = @_;
print $self->get_tab(), "finder $node->{idf}\n";
$self->inc_tab();
print $self->get_tab(), "doc: $node->{doc}\n"
- if (exists $node->{doc});
+ if ($self->{doc} and exists $node->{doc});
foreach (@{$node->{list_param}}) {
$_->visit($self);
}
@@ -947,5 +975,41 @@ sub visitFinder {
$self->dec_tab();
}
+#
+# XPIDL
+#
+
+sub _xp {
+ my $self = shift;
+ my ($node) = @_;
+ if (exists $node->{declspec}) {
+ print $self->get_tab(), "declspec : ",$node->{declspec},"\n";
+ }
+ if (exists $node->{props}) {
+ print $self->get_tab(), "props : ";
+ while (my ($key, $value) = each (%{$node->{props}})) {
+ print $key," ";
+ print "(",$value,") " if (defined $value);
+ }
+ print "\n";
+ }
+ if (exists $node->{native}) {
+ print $self->get_tab(), "native : ",$node->{native},"\n";
+ }
+}
+
+sub visitEllipsis {
+ my $self = shift;
+ my ($node) = @_;
+ print $self->get_tab(), "...\n";
+}
+
+sub visitCodeFragment {
+ my $self = shift;
+ my ($node) = @_;
+ print $self->get_tab(), "code:\n";
+ print $node->{value},"\n";
+}
+
1;
View
39 idl.pl
@@ -12,7 +12,7 @@
$parser->YYData->{verbose_warning} = 1; # 0, 1
$parser->YYData->{verbose_info} = 1; # 0, 1
$parser->YYData->{verbose_deprecated} = 0; # 0, 1 (concerns only version '2.4' and upper)
-$parser->YYData->{symbtab} = new Symbtab($parser);
+$parser->YYData->{symbtab} = new CORBA::IDL::Symbtab($parser);
my $cflags = '-D__idl';
if ($Parser::IDL_version lt '3.0') {
$cflags .= ' -D_PRE_3_0_COMPILER_';
@@ -23,7 +23,18 @@
} else {
$parser->YYData->{preprocessor} = 'cpp -C ' . $cflags;
}
-$parser->getopts("i:x");
+$parser->getopts("hi:vx");
+if ($parser->YYData->{opt_v}) {
+ print "CORBA::IDL $CORBA::IDL::VERSION\n";
+ print "IDL $Parser::IDL_version\n";
+ print "$0\n";
+ print "Perl $]\n";
+ exit;
+}
+if ($parser->YYData->{opt_h}) {
+ use Pod::Usage;
+ pod2usage(-verbose => 1);
+}
$parser->Run(@ARGV);
$parser->YYData->{symbtab}->CheckForward();
$parser->YYData->{symbtab}->CheckRepositoryID();
@@ -50,12 +61,12 @@
if ( exists $parser->YYData->{root}
and ! exists $parser->YYData->{nb_error} ) {
- $parser->YYData->{root}->visitName(new repositoryIdVisitor($parser));
+ $parser->YYData->{root}->visit(new CORBA::IDL::repositoryIdVisitor($parser));
if ( $Parser::IDL_version ge '3.0'
and $parser->YYData->{opt_x} ) {
$parser->YYData->{symbtab}->Export();
}
- $parser->YYData->{root}->visit(new asciiVisitor($parser));
+ $parser->YYData->{root}->visit(new CORBA::IDL::asciiVisitor($parser));
}
#use Data::Dumper;
@@ -69,13 +80,13 @@ =head1 NAME
idl - IDL parser
-=head1 SYNOPSYS
+=head1 SYNOPSIS
idl [options] I<spec>.idl
=head1 OPTIONS
-All options are forwarded to C preprocessor, except -i -x.
+All options are forwarded to C preprocessor, except -h -i -v -x.
With the GNU C Compatible Compiler Processor, useful options are :
@@ -97,13 +108,21 @@ =head1 OPTIONS
=over 8
+=item B<-h>
+
+Display help.
+
=item B<-i> I<directory>
-Specify a path for import (only for version 3.0).
+Specify a path for import (only for IDL version 3.0).
+
+=item B<-v>
+
+Display version.
=item B<-x>
-Enable export (only for version 3.0).
+Enable export (only for IDL version 3.0).
=back
@@ -115,8 +134,6 @@ =head1 DESCRIPTION
B<idl> is a Perl OO application what uses the visitor design pattern.
The parser is generated by Parse::Yapp.
-B<idl> needs Math::BigInt and Math::BigFloat modules.
-
B<idl> needs a B<cpp> executable.
CORBA Specifications, including IDL (Interface Definition Language)
@@ -128,7 +145,7 @@ =head1 SEE ALSO
=head1 COPYRIGHT
-(c) 2001-2003 Francois PERRAD, France. All rights reserved.
+(c) 2001-2004 Francois PERRAD, France. All rights reserved.
This program and all CORBA::IDL modules are distributed
under the terms of the Artistic Licence.
View
213 lexer.pm
@@ -5,12 +5,13 @@
#
use strict;
+
use Math::BigInt;
use Math::BigFloat;
sub Error {
my $parser = shift;
- my($msg) = @_;
+ my ($msg) = @_;
$msg ||= "Syntax error.\n";
@@ -31,7 +32,7 @@ sub Error {
sub Warning {
my $parser = shift;
- my($msg) = @_;
+ my ($msg) = @_;
$msg ||= ".\n";
@@ -48,7 +49,7 @@ sub Warning {
sub Info {
my $parser = shift;
- my($msg) = @_;
+ my ($msg) = @_;
$msg ||= ".\n";
@@ -65,7 +66,7 @@ sub Info {
sub Deprecated {
my $parser = shift;
- my($msg) = @_;
+ my ($msg) = @_;
$msg ||= ".\n";
@@ -82,15 +83,15 @@ sub Deprecated {
sub _StringLexer {
my $parser = shift;
- my($token) = @_;
+ my ($token) = @_;
my $str = '';
- while ($parser->YYData->{INPUT}) {
+ while ($parser->YYData->{line}) {
- for ($parser->YYData->{INPUT}) {
+ for ($parser->YYData->{line}) {
s/^\"//
- and return($token,$str);
+ and return ($token, $str);
s/^([^"\\]+)//
and $str .= $1, # any character except single quote or backslash
@@ -143,57 +144,57 @@ sub _StringLexer {
$parser->Error("untermined string.\n");
$parser->YYData->{lineno} ++;
- return ($token,$str);
+ return ($token, $str);
}
sub _CharLexer {
my $parser = shift;
- my($token) = @_;
+ my ($token) = @_;
- $_ = $parser->YYData->{INPUT};
+ $_ = $parser->YYData->{line};
s/^([^'\\])\'//
- and return ($token,$1); # any character except single quote or backslash
+ and return ($token, $1); # any character except single quote or backslash
s/^\\n\'//
- and return ($token,"\n"); # new line
+ and return ($token, "\n"); # new line
s/^\\t\'//
- and return ($token,"\t"); # horizontal tab
+ and return ($token, "\t"); # horizontal tab
s/^\\v\'//
- and return ($token,"\013"); # vertical tab
+ and return ($token, "\013"); # vertical tab
s/^\\b\'//
- and return ($token,"\b"); # backspace
+ and return ($token, "\b"); # backspace
s/^\\r\'//
- and return ($token,"\r"); # carriage return
+ and return ($token, "\r"); # carriage return
s/^\\f\'//
- and return ($token,"\f"); # form feed
+ and return ($token, "\f"); # form feed
s/^\\a\'//
- and return ($token,"\a"); # alert
+ and return ($token, "\a"); # alert
s/^\\([\?'"])\'//
- and return ($token,$1); # backslash, question mark, single quote, double quote
+ and return ($token, $1); # backslash, question mark, single quote, double quote
s/^\\([0-7]{1,3})\'//
- and return ($token,chr oct $1);
+ and return ($token, chr oct $1);
s/^\\x([0-9A-Fa-f]{1,2})\'//
- and return ($token,chr hex $1);
+ and return ($token, chr hex $1);
if ($token eq 'WIDE_STRING_LITERAL') {
s/^\\u([0-9A-Fa-f]{1,4})\'//
- and return ($token,chr hex $1);
+ and return ($token, chr hex $1);
}
s/^\\([^\s\(\)\[\]\{\}<>,;:="]*)//
and $parser->Error("invalid escape sequence $1.\n"),
- return ($token,' ');
+ return ($token, ' ');
s/^([^\s\(\)\[\]\{\}<>,;:="]*)//
and $parser->Error("invalid character $1.\n"),
- return ($token,' ');
+ return ($token, ' ');
print "INTERNAL_ERROR:_CharLexer $_\n";
- return ($token,' ');
+ return ($token, ' ');
}
sub _Identifier {
my $parser = shift;
- my($ident) = @_;
+ my ($ident) = @_;
my $key = uc $ident;
if (exists $parser->YYData->{keyword}{$key}) {
@@ -220,7 +221,7 @@ sub _Identifier {
sub _EscIdentifier {
my $parser = shift;
- my($ident) = @_;
+ my ($ident) = @_;
if ($Parser::IDL_version ge '2.3') {
my $key = uc $ident;
@@ -230,40 +231,40 @@ sub _EscIdentifier {
} else {
$parser->Warning("Escaped identifier is not allowed.\n");
}
- return ('IDENTIFIER',$ident);
+ return ('IDENTIFIER', $ident);
}
sub _OctInteger {
my $parser = shift;
- my($str) = @_;
+ my ($str) = @_;
my $val = new Math::BigInt(0);
- foreach (split //,$str) {
+ foreach (split //, $str) {
$val = $val * new Math::BigInt(8) + new Math::BigInt(oct $_);
}
- return('INTEGER_LITERAL',$val);
+ return ('INTEGER_LITERAL', $val);
}
sub _HexInteger {
my $parser = shift;
- my($str) = @_;
+ my ($str) = @_;
my $val = new Math::BigInt(0);
- foreach (split //,$str) {
+ foreach (split //, $str) {
$val = $val * new Math::BigInt(16) + new Math::BigInt(hex $_);
}
- return('INTEGER_LITERAL',$val);
+ return ('INTEGER_LITERAL', $val);
}
sub _CommentLexer {
my $parser = shift;
while (1) {
- $parser->YYData->{INPUT}
- or $parser->YYData->{INPUT} = <YYIN>
+ $parser->YYData->{line}
+ or $parser->YYData->{line} = readline $parser->YYData->{fh}
or return;
- for ($parser->YYData->{INPUT}) {
+ for ($parser->YYData->{line}) {
s/^\n//
and $parser->YYData->{lineno} ++,
last;
@@ -281,24 +282,26 @@ sub _DocLexer {
$parser->YYData->{doc} = '';
my $flag = 1;
while (1) {
- $parser->YYData->{INPUT}
- or $parser->YYData->{INPUT} = <YYIN>
+ $parser->YYData->{line}
+ or $parser->YYData->{line} = readline $parser->YYData->{fh}
or return;
- for ($parser->YYData->{INPUT}) {
+ for ($parser->YYData->{line}) {
s/^(\n)//
and $parser->YYData->{lineno} ++,
$parser->YYData->{doc} .= $1,
$flag = 0,
last;
+ s/^\r//
+ and last;
s/^\*\///
and return;
unless ($flag) {
s/^\*//
and $flag = 1,
last;
}
- s/^([ \r\t\f\013]+)//
+ s/^([ \t\f\013]+)//
and $parser->YYData->{doc} .= $1,
last;
s/^(.)//
@@ -309,6 +312,29 @@ sub _DocLexer {
}
}
+sub _CodeLexer {
+ my $parser = shift;
+ my $frag = "";
+
+ while (1) {
+ $parser->YYData->{line}
+ or $parser->YYData->{line} = readline $parser->YYData->{fh}
+ or return;
+
+ for ($parser->YYData->{line}) {
+ s/^(\n)//
+ and $parser->YYData->{lineno} ++,
+ $frag .= $1,
+ last;
+ s/^%\}//
+ and return ('CODE_FRAGMENT', $frag);
+ s/^(.)//
+ and $frag .= $1,
+ last;
+ }
+ }
+}
+
sub _PragmaLexer { # 10.6.5 Pragma Directives for RepositoryId
my $parser = shift;
my($line) = @_;
@@ -346,12 +372,12 @@ sub _Lexer {
my $parser = shift;
while (1) {
- $parser->YYData->{INPUT}
- or $parser->YYData->{INPUT} = <YYIN>
+ $parser->YYData->{line}
+ or $parser->YYData->{line} = readline $parser->YYData->{fh}
or return('',undef);
unless (exists $parser->YYData->{srcname}) {
- if ($parser->YYData->{INPUT} =~ /^#\s*(line\s+)?\d+\s+["<]([^\s">]+)[">]\s*\n/ ) {
+ if ($parser->YYData->{line} =~ /^#\s*(line\s+)?\d+\s+["<]([^\s">]+)[">]\s*\n/ ) {
$parser->YYData->{srcname} = $2;
} else {
print "INTERNAL_ERROR:_Lexer\n";
@@ -363,7 +389,7 @@ sub _Lexer {
}
}
- for ($parser->YYData->{INPUT}) {
+ for ($parser->YYData->{line}) {
s/^#\s+[\d]+\s+"<[^>]+>"\s*\n// # cpp 3.2.3 ("<build-in>", "<command line>")
and last;
@@ -415,37 +441,56 @@ sub _Lexer {
$parser->YYData->{curr_node} = undef,
last;
+ s/^%\{// # code fragment
+ and return $parser->_CodeLexer();
+
+ if ($parser->YYData->{prop}) {
+ s/^([A-Za-z][0-9A-Za-z_]*)//
+ and return ('PROP_KEY', $1);
+
+ s/^\(([^\)]+)\)//
+ and return ('PROP_VALUE', $1);
+ }
+
+ if ($parser->YYData->{native}) {
+ s/^([^\)]+)\)//
+ and return ('NATIVE_TYPE', $1);
+ }
+
+ s/^__declspec\s*\(\s*([A-Za-z]*)\s*\)//
+ and return ('DECLSPEC', $1);
+
s/^([0-9]+)([Dd])//
and $parser->YYData->{lexeme} = $1 . $2,
- return('FIXED_PT_LITERAL',new Math::BigFloat($1));
+ return ('FIXED_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+\.)([Dd])//
and $parser->YYData->{lexeme} = $1 . $2,
- return('FIXED_PT_LITERAL',new Math::BigFloat($1));
+ return ('FIXED_PT_LITERAL', new Math::BigFloat($1));
s/^(\.[0-9]+)([Dd])//
and $parser->YYData->{lexeme} = $1 . $2,
- return('FIXED_PT_LITERAL',new Math::BigFloat($1));
+ return ('FIXED_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+\.[0-9]+)([Dd])//
and $parser->YYData->{lexeme} = $1 . $2,
- return('FIXED_PT_LITERAL',new Math::BigFloat($1));
+ return ('FIXED_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+\.[0-9]+[Ee][+\-]?[0-9]+)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+[Ee][+\-]?[0-9]+)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^(\.[0-9]+[Ee][+\-]?[0-9]+)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+\.[0-9]+)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^([0-9]+\.)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^(\.[0-9]+)//
and $parser->YYData->{lexeme} = $1,
- return('FLOATING_PT_LITERAL',new Math::BigFloat($1));
+ return ('FLOATING_PT_LITERAL', new Math::BigFloat($1));
s/^0([0-7]+)//
and $parser->YYData->{lexeme} = '0' . $1,
@@ -455,10 +500,10 @@ sub _Lexer {
return $parser->_HexInteger($2);
s/^(0)//
and $parser->YYData->{lexeme} = $1,
- return('INTEGER_LITERAL',new Math::BigInt($1));
+ return ('INTEGER_LITERAL', new Math::BigInt($1));
s/^([1-9][0-9]*)//
and $parser->YYData->{lexeme} = $1,
- return('INTEGER_LITERAL',new Math::BigInt($1));
+ return ('INTEGER_LITERAL', new Math::BigInt($1));
s/^\"//
and return $parser->_StringLexer('STRING_LITERAL');
@@ -490,14 +535,16 @@ sub _Lexer {
and return $parser->_EscIdentifier($1);
s/^(<<)//
- and return($1,$1);
+ and return ($1, $1);
s/^(>>)//
- and return($1,$1);
+ and return ($1, $1);
s/^(::)//
- and return($1,$1);
+ and return ($1, $1);
+ s/^(\.\.\.)//
+ and return ($1, $1);
s/^([\+&\/%\*~\|\-\^\(\)\[\]\{\}<>,;:=])//
- and return($1,$1); # punctuators
+ and return ($1, $1); # punctuators
s/^([\S]+)//
and $parser->Error("lexer error $1.\n"),
@@ -584,12 +631,12 @@ sub getopts { # from Getopt::Std
no strict;
my $parser = shift;
local($argumentative) = @_;
- local(@args,$_,$first,$rest);
+ local(@args, $_, $first, $rest);
$parser->YYData->{args} = [];
@args = split( / */, $argumentative );
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
- ($first,$rest) = ($1,$2);
+ ($first, $rest) = ($1, $2);
if (/^--$/) { # early exit if --
shift(@ARGV);
last;
@@ -619,23 +666,47 @@ sub getopts { # from Getopt::Std
sub Run {
my $parser = shift;
my $preprocessor = $parser->YYData->{preprocessor};
- my @args;
- @args = @{$parser->YYData->{args}}
- if (exists $parser->YYData->{args});
- push @args, @_;
+ if ($preprocessor) {
+ my @args;
+ @args = @{$parser->YYData->{args}}
+ if (exists $parser->YYData->{args});
+ push @args, @_;
- open(YYIN,"$preprocessor @args|")
- || die "can't open @_ ($!).\n";
+ open $parser->YYData->{fh}, "$preprocessor @args|"
+ or die "can't open @_ ($!).\n";
+ } else {
+ my $file = shift;
+ if (ref $file) {
+ $parser->YYData->{fh} = $file;
+ $parser->YYData->{srcname} = shift;
+ } else {
+ open $parser->YYData->{fh}, $file
+ or die "can't open $file ($!).\n";
+ $parser->YYData->{srcname} = shift || $file;
+ }
+ }
$parser->_InitLexico();
$parser->YYData->{doc} = '';
$parser->YYData->{curr_node} = undef;
$parser->YYData->{curr_itf} = undef;
+ $parser->YYData->{prop} = 0;
+ $parser->YYData->{native} = 0;
$parser->YYParse(
yylex => \&_Lexer,
- yyerror => sub { return; }
+ yyerror => sub { return; },
+# yydebug => 0x17,
);
+
+# Bit Value Outputs
+# 0x01 Token reading (useful for Lexer debugging)
+# 0x02 States information
+# 0x04 Driver actions (shifts, reduces, accept...)
+# 0x08 Parse Stack dump
+# 0x10 Error Recovery tracing
+
+ close $parser->YYData->{fh};
}
1;
View
6 makefile.yapp
@@ -3,7 +3,7 @@ YAPP=yapp -s -v -m
CP=copy
RM=-del
-all: parser30.pm parser24.pm parser23.pm parser22.pm parser21.pm parser20.pm
+all: parser30.pm parser24.pm parser23.pm parser22.pm parser21.pm parser20.pm parserxp.pm
$(RM) Parser.pm
parser20.pm: parser20.yp
@@ -30,6 +30,10 @@ parser30.pm: parser30.yp
$(YAPP) Parser parser30.yp
$(CP) Parser.pm parser30.pm
+parserxp.pm: parserxp.yp
+ $(YAPP) Parser parserxp.yp
+ $(CP) Parser.pm parserxp.pm
+
clean:
$(RM) parser*.pm
$(RM) parser*.output
View
649 node.pm
@@ -5,9 +5,12 @@ use UNIVERSAL;
# Interface Definition Language (OMG IDL CORBA v3.0)
#
-package node;
+package CORBA::IDL;
+
use vars qw($VERSION);
-$VERSION = '2.05';
+$VERSION = '2.20';
+
+package CORBA::IDL::node;
sub _Build {
my $proto = shift;
@@ -25,7 +28,7 @@ sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $parser = shift;
- my $self = _Build node(@_);
+ my $self = _Build CORBA::IDL::node(@_);
bless($self, $class);
$self->_Init($parser); # specialized or default
return $self
@@ -38,8 +41,8 @@ sub _Init {
sub configure {
my $self = shift;
my %attr = @_;
- my ($key,$value);
- while ( ($key,$value) = each(%attr) ) {
+ my ($key, $value);
+ while ( ($key, $value) = each(%attr) ) {
if (defined $value) {
$self->{$key} = $value;
}
@@ -82,31 +85,45 @@ sub getInheritance {
return @list;
}
+sub getProperty {
+ my $self = shift;
+ my ($key) = @_;
+ return undef unless (exists $self->{props});
+ return undef unless (exists $self->{props}->{$key});
+ return $self->{props}->{$key};
+}
+
sub visit {
- # overloaded in : BasicType, Literal
my $self = shift;
my $class = ref $self;
my $visitor = shift;
- my $func = 'visit' . $class;
- if($visitor->can($func)) {
- $visitor->$func($self,@_);
- } else {
- warn "Please implement a function '$func' in '",ref $visitor,"'.\n";
+ no strict "refs";
+ while ($class ne "CORBA::IDL::node") {
+ my $func = 'visit' . $class;
+ if ($visitor->can($func)) {
+ return $visitor->$func($self, @_);
+ }
+ $class = ${"$class\::ISA"}[0];
}
+ warn "Please implement a function 'visit",ref $self,"' in '",ref $visitor,"'.\n";
+ return undef;
}
+# deprecated in favor of 'visit'
sub visitName {
- # overloaded in : BasicType, BaseInterface
my $self = shift;
my $class = ref $self;
my $visitor = shift;
- my $func = 'visitName' . $class;
- if($visitor->can($func)) {
- return $visitor->$func($self,@_);
- } else {
- warn "Please implement a function '$func' in '",ref $visitor,"'.\n";
- return undef;
+ no strict "refs";
+ while ($class ne "CORBA::IDL::node") {
+ my $func = 'visitName' . $class;
+ if ($visitor->can($func)) {
+ return $visitor->$func($self, @_);
+ }
+ $class = ${"$class\::ISA"}[0];
}
+ warn "Please implement a function 'visitName",ref $self,"' in '",ref $visitor,"'.\n";
+ return undef;
}
#
@@ -115,7 +132,7 @@ sub visitName {
package Specification;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -146,7 +163,7 @@ sub _Init {
package Import;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -160,11 +177,11 @@ sub _Init {
package Modules;
-use base qw(node);
+use base qw(CORBA::IDL::node);
package Module;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -214,7 +231,7 @@ sub Configure {
package BaseInterface;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -241,10 +258,12 @@ sub _InsertInherited {
foreach ($self->getInheritance()) {
my $base = $parser->YYData->{symbtab}->Lookup($_);
foreach (keys %{$base->{hash_attribute_operation}}) {
- next if ($_->isa('Initializer'));
-# next if ($_->isa('Factory'));
-# next if ($_->isa('Finder'));
my $name = $base->{hash_attribute_operation}{$_};
+ my $defn = $parser->YYData->{symbtab}->Lookup($name);
+ next if ($defn->isa('Initializer'));
+ next if ($defn->isa('StateMember'));
+# next if ($defn->isa('Factory'));
+# next if ($defn->isa('Finder'));
if (exists $self->{hash_attribute_operation}{$_}) {
if ($self->{hash_attribute_operation}{$_} ne $name) {
$parser->Error("multi inheritance of '$_'.\n");
@@ -281,7 +300,7 @@ sub Configure {
sub Lookup {
my $proto = shift;
my $class = ref($proto) || $proto;
- my($parser,$name) = @_;
+ my ($parser, $name) = @_;
my $defn = $parser->YYData->{symbtab}->Lookup($name);
if (defined $defn) {
if ($defn->isa('Forward' . $class)) {
@@ -295,25 +314,13 @@ sub Lookup {
}
}
-sub visitName {
- my $self = shift;
- my $class = ref $self;
- my $visitor = shift;
- my $func = 'visitName' . $class;
- if ($visitor->can($func)) {
- return $visitor->$func($self,@_);
- } else {
- return $visitor->visitNameBaseInterface($self,@_);
- }
-}
-
#
# 3.8.2 Interface Inheritance Specification
#
package InheritanceSpec;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -329,8 +336,10 @@ sub _Init {
$hash{$name} = 1;
$self->{hash_interface}->{$name} = 1;
my $base = $parser->YYData->{symbtab}->Lookup($name);
- foreach (keys %{$base->{inheritance}->{hash_interface}}) {
- $self->{hash_interface}->{$_} = 1;
+ if (exists $base->{inheritance}) {
+ foreach (keys %{$base->{inheritance}->{hash_interface}}) {
+ $self->{hash_interface}->{$_} = 1;
+ }
}
}
}
@@ -344,8 +353,10 @@ sub _Init {
$hash{$name} = 1;
$self->{hash_interface}->{$name} = 1;
my $base = $parser->YYData->{symbtab}->Lookup($name);
- foreach (keys %{$base->{inheritance}->{hash_interface}}) {
- $self->{hash_interface}->{$_} = 1;
+ if (exists $base->{inheritance}) {
+ foreach (keys %{$base->{inheritance}->{hash_interface}}) {
+ $self->{hash_interface}->{$_} = 1;
+ }
}
}
}
@@ -362,7 +373,7 @@ use base qw(Interface);
sub _CheckInheritance {
my $self = shift;
- my($parser) = @_;
+ my ($parser) = @_;
if (exists $self->{inheritance}) {
foreach (@{$self->{inheritance}->{list_interface}}) {
my $base = $parser->YYData->{symbtab}->Lookup($_);
@@ -376,7 +387,7 @@ sub _CheckInheritance {
sub _CheckLocal {
my $self = shift;
- my($parser) = @_;
+ my ($parser) = @_;
# A local type may not appear as a parameter, attribute, return type, or exception
# declaration of an unconstrained interface or as a state member of a valuetype.
@@ -405,7 +416,7 @@ sub _CheckLocal {
package ForwardBaseInterface;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -443,7 +454,7 @@ use base qw(Interface);
sub _CheckInheritance {
my $self = shift;
- my($parser) = @_;
+ my ($parser) = @_;
if (exists $self->{inheritance}) {
foreach (@{$self->{inheritance}->{list_interface}}) {
my $base = $parser->YYData->{symbtab}->Lookup($_);
@@ -458,7 +469,7 @@ sub _CheckInheritance {
sub _CheckLocal {
my $self = shift;
- my($parser) = @_;
+ my ($parser) = @_;
# A local type may not appear as a parameter, attribute, return type, or exception
# declaration of an unconstrained interface or as a state member of a valuetype.
@@ -518,27 +529,53 @@ use base qw(Value);
sub _CheckInheritance {
my $self = shift;
- my($parser) = @_;
+ my ($parser) = @_;
if (exists $self->{inheritance}) {
if ( exists $self->{inheritance}->{modifier} # truncatable
and exists $self->{modifier} ) { # custom
$parser->Error("'truncatable' is used in a custom value.\n");
}
+ if (exists $self->{inheritance}->{list_interface}) {
+ my $nb = 0;
+ foreach (@{$self->{inheritance}->{list_interface}}) {
+ my $base = $parser->YYData->{symbtab}->Lookup($_);
+ if ($base->isa('RegularInterface')) {
+ $nb ++;
+ }
+ }
+ $parser->Error("'$self->{idf}' inherits from more than once regular interface.\n")
+ if ($nb > 1);
+ }
+ if (exists $self->{inheritance}->{list_value}) {
+ my $nb = 0;
+ foreach (@{$self->{inheritance}->{list_value}}) {
+ my $base = $parser->YYData->{symbtab}->Lookup($_);
+ if ($base->isa('RegularValue')) {
+ $nb ++;
+ }
+ if ($base->isa('BoxedValue')) {
+ $parser->Error("'$_' is a boxed value.\n")
+ }
+ }
+ $parser->Error("'$self->{idf}' inherits from more than once regular value.\n")
+ if ($nb > 1);
+ }
}
}
sub Configure {
my $self = shift;
my $parser = shift;
- $self->SUPER::Configure($parser,@_);
+ $self->SUPER::Configure($parser, @_);
my @list;
foreach my $value_element (@{$self->{list_decl}}) {
next unless (ref $value_element eq 'StateMembers');
foreach (@{$value_element->{list_decl}}) {
push @list, $_;
+ $self->{deprecated} = 1 if (TypeDeclarator->IsDeprecated($parser, $_));
}
}
- $self->configure(list_value => \@list); # list of 'StateMember'
+ $self->configure(list_member => \@list); # list of 'StateMember'
return $self;
}
@@ -553,38 +590,43 @@ sub _CheckLocal {
package StateMembers;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
my ($parser) = @_;
+ TypeDeclarator->CheckDeprecated($parser, $self->{type});
+ TypeDeclarator->CheckForward($parser, $self->{type});
my @list;
foreach (@{$self->{list_expr}}) {
my $member;
my @array_size = @{$_};
my $idf = shift @array_size;
if (@array_size) {
$member = new StateMember($parser,
+ declspec => $self->{declspec},
+ props => $self->{props},
modifier => $self->{modifier},
type => $self->{type},
idf => $idf,
- array_size => \@array_size
+ array_size => \@array_size,
+ deprecated => 1,
);
- if ($Parser::IDL_version ge '2.4') {
- $parser->Deprecated("Anonymous type (array).\n");
- }
+ $parser->Deprecated("Anonymous type (array).\n")
+ if ($Parser::IDL_version ge '2.4');
} else {
$member = new StateMember($parser,
+ declspec => $self->{declspec},
+ props => $self->{props},
modifier => $self->{modifier},
type => $self->{type},
idf => $idf,
+ deprecated => TypeDeclarator->IsDeprecated($parser, $self->{type}),
);
}
push @list, $member->{full};
}
$self->configure(list_decl => \@list);
- TypeDeclarator->CheckDeprecated($parser,$self->{type});
- TypeDeclarator->CheckForward($parser,$self->{type});
# A local type may not appear as a parameter, attribute, return type, or exception
# declaration of an unconstrained interface or as a state member of a valuetype.
if (TypeDeclarator->IsaLocal($parser, $self->{type})) {
@@ -596,7 +638,7 @@ sub _Init {
package StateMember; # modifier, idf, type[, array_size]
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
@@ -620,13 +662,13 @@ sub _Init {
package Initializer;
-use base qw(node);
+use base qw(CORBA::IDL::node);
sub _Init {
my $self = shift;
my ($parser) = @_;
$parser->YYData->{symbtab}->Insert($self);
- $parser->YYData->{unnamed_symbtab} = new UnnamedSymbtab($parser);
+ $parser->YYData->{unnamed_symbtab} = new CORBA::IDL::UnnamedSymbtab($parser);