Skip to content
Browse files

import version 0.61 from backpan

  • Loading branch information...
1 parent 721a7d1 commit a4b6a564d6d4c54f0582fa6b06a12ee6fe5a5f1f @fperrad committed with Oct 19, 2007
Showing with 913 additions and 1,476 deletions.
  1. +3 −0 Changes
  2. +3 −0 MANIFEST
  3. +2 −2 META.yml
  4. +16 −3 Makefile.PL
  5. +3 −3 bin/idl2xs_c
  6. +31 −0 example1/t/01-calc.t
  7. +21 −0 example2/t/01-calc.t
  8. +21 −0 example3/t/01-calc.t
  9. +1 −1 lib/CORBA/XS.pm
  10. +789 −1,449 lib/CORBA/XS/StubCVisitor.pm
  11. +23 −18 lib/CORBA/XS/StubPerlVisitor.pm
View
3 Changes
@@ -1,5 +1,8 @@
Revision history for Perl extension CORBA::XS.
+0.61 Fri Oct 19 08:30:00 2007
+ - compatible with CORBA::IDL 2.61
+
0.60 Fri Oct 12 08:30:00 2007
- compatible with CORBA::IDL 2.60
- some Perl Best Practices
View
3 MANIFEST
@@ -16,6 +16,7 @@ C/cdr.h
example1/Calc.idl
example1/skel_Calc.c
example1/README
+example1/t/01-calc.t
example1/testunit/test_add.pm
example1/testunit/test_sub.pm
example1/testunit/test_mul.pm
@@ -25,11 +26,13 @@ example2/Cplx.idl
example2/CalcCplx.idl
example2/skel_CalcCplx.c
example2/README
+example2/t/01-calc.t
example2/testunit/test_cplx.pm
example3/Cplx.idl
example3/CalcCplx.idl
example3/skel_CalcCplx.c
example3/README
+example3/t/01-calc.t
example3/testunit/test_cplx.pm
META.yml Module meta-data (added by MakeMaker)
View
4 META.yml
@@ -1,13 +1,13 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: CORBA-XS
-version: 0.60
+version: 0.61
version_from: lib/CORBA/XS.pm
installdirs: site
requires:
CORBA::C: 2.6
CORBA::IDL: 2.6
- CORBA::Perl: 0.4
+ CORBA::Perl: 0.41
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.30
View
19 Makefile.PL
@@ -8,7 +8,7 @@ WriteMakefile(
'PREREQ_PM' => {
'CORBA::IDL' => 2.60,
'CORBA::C' => 2.60,
- 'CORBA::Perl' => 0.40,
+ 'CORBA::Perl' => 0.41,
},
'INSTALLDIRS' => 'site',
'PM' => {
@@ -19,8 +19,6 @@ WriteMakefile(
'lib/CORBA/XS/StubCVisitor.pm' => '$(INST_LIBDIR)/XS/StubCVisitor.pm',
'lib/CORBA/XS/StubPerlVisitor.pm' => '$(INST_LIBDIR)/XS/StubPerlVisitor.pm',
'C/corba.c' => '$(INST_LIBDIR)/XS/corba.c',
- 'C/corba.h' => '$(INSTALLARCHLIB)/CORE/corba.h',
- 'C/cdr.h' => '$(INSTALLARCHLIB)/CORE/cdr.h',
},
'EXE_FILES' => [ 'bin/idl2xs_c' ],
'AUTHOR' => "Francois PERRAD (francois.perrad\@gadz.org)",
@@ -30,3 +28,18 @@ WriteMakefile(
},
);
+sub MY::install {
+ package MY;
+ my $script = shift->SUPER::install(@_);
+ $script =~ s/install :: (.*)$/install :: $1 install_core_h/m;
+ $script .= <<"INSTALL";
+
+install_core_h :
+\t\$(CP) C/corba.h \$(INSTALLARCHLIB)/CORE/corba.h
+\t\$(CP) C/cdr.h \$(INSTALLARCHLIB)/CORE/cdr.h
+
+INSTALL
+
+ return $script;
+}
+
View
6 bin/idl2xs_c
@@ -5,7 +5,7 @@ use warnings;
use CORBA::IDL 2.60;
use CORBA::C 2.60;
-use CORBA::Perl 0.40;
+use CORBA::Perl 0.41;
use CORBA::XS;
# visitors
use CORBA::IDL::RepositoryIdVisitor;
@@ -65,9 +65,9 @@ if (defined $root) {
$root->visit(new CORBA::C::IncSkelVisitor($parser, q{}, q{}));
$root->visit(new CORBA::XS::SkeletonCVisitor($parser));
$root->visit(new CORBA::XS::StubCVisitor($parser));
- $root->visit(new CORBA::Perl::NameVisitor($parser));
+ $root->visit(new CORBA::Perl::NameVisitor($parser, $parser->YYData->{opt_J}));
$root->visit(new CORBA::Perl::LiteralVisitor($parser));
- $root->visit(new CORBA::XS::StubPerlVisitor($parser));
+ $root->visit(new CORBA::XS::StubPerlVisitor($parser, $parser->YYData->{opt_J}));
$root->visit(new CORBA::XS::CVisitor($parser));
}
View
31 example1/t/01-calc.t
@@ -0,0 +1,31 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+use Test::Exception;
+
+use Calc;
+
+my $calc = new Calc();
+my $result;
+$result = $calc->Add(5, 2);
+ok($result == 7, "5 + 2");
+
+$result = $calc->Mul(5, 2);
+ok($result == 10, "5 * 2");
+
+$result = $calc->Mul(5, 0);
+ok($result == 0, "5 * 0");
+
+$result = $calc->Sub(5, 2);
+ok($result == 3, "5 - 2");
+
+$result = $calc->Div(5, 2);
+ok($result == 2, "5 / 2");
+
+$result = $calc->Div(0, 2);
+ok($result == 0, "0 / 2");
+
+throws_ok { $calc->Div(5, 0); } 'Calc::DivisionByZero', '5 / 0';
+
View
21 example2/t/01-calc.t
@@ -0,0 +1,21 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use CalcCplx;
+
+my $calc = new CalcCplx();
+my $c1 = { re => 1, im => 3 };
+my $c2 = { re => 2, im => -1 };
+my $result;
+
+$result = $calc->Add($c1, $c2);
+ok($result->{re} == 3, 'Add (re)');
+ok($result->{im} == 2, 'Add (im)');
+
+$result = $calc->Sub($c1, $c2);
+ok($result->{re} == -1, 'Sub (re)');
+ok($result->{im} == 4, 'Sub (im)');
+
View
21 example3/t/01-calc.t
@@ -0,0 +1,21 @@
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use CalcCplx;
+
+my $calc = new CalcCplx();
+my $c1 = { re => 1, im => 3 };
+my $c2 = { re => 2, im => -1 };
+my $result;
+
+$result = $calc->Add($c1, $c2);
+ok($result->{re} == 3, 'Add (re)');
+ok($result->{im} == 2, 'Add (im)');
+
+$result = $calc->Sub($c1, $c2);
+ok($result->{re} == -1, 'Sub (re)');
+ok($result->{im} == 4, 'Sub (im)');
+
View
2 lib/CORBA/XS.pm
@@ -3,7 +3,7 @@ use warnings;
package CORBA::XS;
-our $VERSION = '0.60';
+our $VERSION = '0.61';
use CORBA::XS::CdrCVisitor;
use CORBA::XS::CVisitor;
View
2,238 lib/CORBA/XS/StubCVisitor.pm
@@ -1,12 +1,15 @@
-use strict;
-use POSIX qw(ctime);
#
# Interface Definition Language (OMG IDL CORBA v3.0)
#
package CORBA::XS::StubCVisitor;
+use strict;
+use POSIX qw(ctime);
+
+our $VERSION = '0.61';
+
use CORBA::XS::CdrCVisitor;
use base qw(CORBA::XS::CdrCVisitor);
@@ -36,1622 +39,959 @@ sub new {
return $self;
}
-#
-# 3.5 OMG IDL Specification
-#
-
-sub visitSpecification {
+sub _get_c_decl_var {
my $self = shift;
- my($node) = @_;
- my $filename = $self->{prefix} . basename($self->{srcname}, '.idl') . '.h';
- my $FH = $self->{out};
- print $FH "/* This file was generated (by ",$0,"). DO NOT modify it */\n";
- print $FH "// From file : ",$self->{srcname},", ",$self->{srcname_size}," octets, ",POSIX::ctime($self->{srcname_mtime});
- print $FH "\n";
- print $FH "#include <string.h>\n";
- print $FH "#include <",$self->{incpath},"cdr.h>\n";
- print $FH "#include \"",$filename,"\"\n";
- print $FH "\n";
- print $FH "\n";
- foreach (@{$node->{list_decl}}) {
- $self->_get_defn($_)->visit($self);
- }
- print $FH "/* end of file : ",$self->{filename}," */\n";
- close $FH;
-}
-
-#
-# 3.7 Module Declaration (inherited)
-#
+ my($type, $attr, $name) = @_;
-#
-# 3.8 Interface Declaration
-#
-
-sub visitRegularInterface {
- my $self = shift;
- my($node) = @_;
- my $FH = $self->{out};
- print $FH "/*\n";
- print $FH " * begin of interface ",$node->{c_name},"\n";
- print $FH " */\n";
- foreach (@{$node->{list_decl}}) {
- my $defn = $self->_get_defn($_);
- if ( $defn->isa('Operation')
- or $defn->isa('Attributes') ) {
- next;
+ if ( $type->isa('BasicType')
+ or $type->isa('EnumType')
+ or $type->isa('FixedPtType') ) {
+ if ( $attr eq 'in' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'inout' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'out' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'return' ) {
+ return $type->{c_name} . q{ } . $name;
}
- $defn->visit($self);
}
- print $FH "\n";
- if ( $self->{srcname} eq $node->{filename}
- and keys %{$node->{hash_attribute_operation}} ) {
- $self->{itf} = $node->{c_name};
- print $FH "\t\t/*-- functions --*/\n";
- print $FH "\n";
- foreach (values %{$node->{hash_attribute_operation}}) {
- $self->_get_defn($_)->visit($self);
+ elsif ( $type->isa('StructType')
+ or $type->isa('UnionType') ) {
+ if ( $attr eq 'in' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'inout' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return $type->{c_name} . ' * ' . $name;
+ }
+ else {
+ return $type->{c_name} . q{ } . $name;
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ if (defined $type->{length}) { # variable
+ return $type->{c_name} . ' * ' . $name;
+ }
+ else {
+ return $type->{c_name} . q{ } . $name;
+ }
}
- print $FH "\n";
}
- print $FH "/*\n";
- print $FH " * end of interface ",$node->{c_name},"\n";
- print $FH " */\n";
- print $FH "\n";
-}
-
-sub visitAbstractInterface {
- # C mapping is aligned with CORBA 2.1
- my $self = shift;
- my($node) = @_;
- my $FH = $self->{out};
- print $FH "/*\n";
- print $FH " * begin of interface ",$node->{c_name},"\n";
- print $FH " */\n";
- foreach (@{$node->{list_decl}}) {
- my $defn = $self->_get_defn($_);
- if ( $defn->isa('Operation')
- or $defn->isa('Attributes') ) {
- next;
+ elsif ( $type->isa('SequenceType') ) {
+ my $max = 0;
+ $max = $type->{max}->{c_literal} if (exists $type->{max});
+ if ( $attr eq 'in' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'inout' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'out' ) {
+ return $type->{c_name} . ' * ' . $name;
+ }
+ elsif ( $attr eq 'return' ) {
+ return $type->{c_name} . ' * ' . $name;
}
- $defn->visit($self);
}
- print $FH "\n";
- print $FH "/*\n";
- print $FH " * end of interface ",$node->{c_name},"\n";
- print $FH " */\n";
- print $FH "\n";
-}
-
-#
-# 3.9 Value Declaration (inherited)
-#
-
-#
-# 3.10 Constant Declaration (inherited)
-#
-
-#
-# 3.11 Type Declaration (inherited)
-#
-
-#
-# 3.12 Exception Declaration (inherited)
-#
-
-#
-# 3.13 Operation Declaration
-#
-
-sub visitOperation {
- my $self = shift;
- my($node) = @_;
- my $FH = $self->{out};
- my $label_err = undef;
- my $nb_param_out = 0;
- my $nb_param_in = 0;
- my $type = $self->_get_defn($node->{type});
- unless ($type->isa('VoidType')) { # return
- $label_err = $type->{length};
- $nb_param_out ++;
- $node->{c_put_name} = CORBA::XS::Cname_put2->NameAttr($self->{symbtab}, $type, 'return') . '_ret';
+ elsif ( $type->isa('StringType')
+ or $type->isa('WideStringType') ) {
+ if ( $attr eq 'in' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'inout' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'out' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'return' ) {
+ return $type->{c_name} . '* ' . $name;
+ }
}
- foreach (@{$node->{list_in}}) { # parameter
- $type = $self->_get_defn($_->{type});
- $_->{c_get_ptr_name} = CORBA::XS::Cptrname_get2->NameAttr($self->{symbtab}, $type, $_->{attr}) . $_->{c_name};
- $label_err ||= $type->{length};
- $nb_param_in ++;
+ elsif ( $type->isa('TypeDeclarator') ) {
+ if (exists $type->{array_size}) {
+ warn "_get_c_decl_var TypeDeclarator $type->{idf} : empty array_size.\n"
+ unless (@{$type->{array_size}});
+ if ( $attr eq 'in' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'inout' ) {
+ return $type->{c_name} . q{ } . $name;
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return $type->{c_name} . '_slice * ' . $name;
+ }
+ else {
+ return $type->{c_name} . q{ } . $name;
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ return $type->{c_name} . '_slice ' . $name;
+ }
+ }
+ else {
+ my $type = $type->{type};
+ unless (ref $type) {
+ $type = $self->{symbtab}->Lookup($type);
+ }
+ return $self->_get_c_decl_var($type, $attr, $name);
+ }
}
- foreach (@{$node->{list_inout}}) { # parameter
- $type = $self->_get_defn($_->{type});
- $_->{c_get_ptr_name} = CORBA::XS::Cptrname_get2->NameAttr($self->{symbtab}, $type, $_->{attr}) . $_->{c_name};
- $_->{c_put_name} = CORBA::XS::Cname_put2->NameAttr($self->{symbtab}, $type, $_->{attr}) . $_->{c_name};
- $label_err ||= $type->{length};
- $nb_param_in ++;
- $nb_param_out ++;
+ elsif ( $type->isa('NativeType') ) {
+ warn "_get_c_decl_var NativeType : not supplied \n";
+ return;
}
- foreach (@{$node->{list_out}}) { # parameter
- $type = $self->_get_defn($_->{type});
- $_->{c_get_ptr_name} = CORBA::XS::Cptrname_get2->NameAttr($self->{symbtab}, $type, $_->{attr}) . $_->{c_name};
- $_->{c_put_name} = CORBA::XS::Cname_put2->NameAttr($self->{symbtab}, $type, $_->{attr}) . $_->{c_name};
- $nb_param_out ++;
+ elsif ( $type->isa('BaseInterface')
+ or $type->isa('ForwardBaseInterface') ) {
+ warn "_get_c_decl_var BaseInterface : not supplied \n";
+ return;
}
- my $nb_user_except = 0;
- $nb_user_except = @{$node->{list_raise}} if (exists $node->{list_raise});
- print $FH "\n";
- if (exists $node->{modifier}) { # oneway
- print $FH "void cdr_",$self->{itf},"_",$node->{c_name},"(void * _ref, char *_is)\n";
+ elsif ( $type->isa('AnyType') ) {
+ warn "_get_c_decl_var AnyType : not supplied \n";
+ return;
}
else {
- print $FH "int cdr_",$self->{itf},"_",$node->{c_name},"(void * _ref, char *_is, char **_os)\n";
- }
- print $FH "{\n";
- print $FH "\tCORBA_Environment _Ev;\n";
- $type = $self->_get_defn($node->{type});
- unless ($type->isa('VoidType')) {
- print $FH "\t",CORBA::XS::Cdecl_var->NameAttr($self->{symbtab}, $type, 'return', '_ret'),";\n";
- }
- foreach (@{$node->{list_param}}) { # parameter
- $type = $self->_get_defn($_->{type});
- print $FH "\t",CORBA::XS::Cdecl_var->NameAttr($self->{symbtab}, $type, $_->{attr}, $_->{c_name}),";\n";
- }
- if ($nb_param_in or $nb_param_out or $nb_user_except) {
- print $FH "\tCORBA_char *_p;\n";
- print $FH "\tunsigned _align = 4;\n";
- }
- unless (exists $node->{modifier}) { # oneway
- print $FH "\tint _size = 0;\n";
+ my $class = ref $type;
+ warn "Please implement '$class' in '_get_c_decl_var'.\n";
+ return;
}
- print $FH "\n";
- $type = $self->_get_defn($node->{type});
- unless ($type->isa('VoidType')) {
- my @init = CORBA::XS::Cinit_var->NameAttr($self->{symbtab}, $type, 'return', '_ret');
- foreach (@init) {
- print $FH "\t",$_,";\n";
+}
+
+sub _get_c_init_var {
+ my $self = shift;
+ my($type, $attr, $name) = @_;
+
+ if ( $type->isa('BasicType')
+ or $type->isa('EnumType') ) {
+ if ( $attr eq 'in' ) {
+ return ();
}
- }
- foreach (@{$node->{list_param}}) { # parameter
- $type = $self->_get_defn($_->{type});
- my @init = CORBA::XS::Cinit_var->NameAttr($self->{symbtab}, $type, $_->{attr}, $_->{c_name});
- foreach (@init) {
- print $FH "\t",$_,";\n";
+ elsif ( $attr eq 'inout' ) {
+ return ();
+ }
+ elsif ( $attr eq 'out' ) {
+ return ();
+ }
+ elsif ( $attr eq 'return' ) {
+ return ();
}
}
- print $FH "\tmemset(&_Ev, 0, sizeof _Ev);\n";
- if ($nb_param_in) {
- print $FH "\t_p = _is;\n";
- foreach (@{$node->{list_param}}) { # parameter
- if ( $_->{attr} eq 'in'
- or $_->{attr} eq 'inout' ) {
- $type = $self->_get_defn($_->{type});
- print $FH "\tGET_",$type->{c_name},"(_p,",$_->{c_get_ptr_name},");\n";
- }
+ elsif ( $type->isa('FixedPtType') ) {
+ my $d = $type->{d}->{c_literal};
+ my $s = $type->{s}->{c_literal};
+ if ( $attr eq 'in' ) {
+ return (
+ $name . '._digits = ' . $d,
+ $name . '._scale = ' . $s,
+ );
+ }
+ elsif ( $attr eq 'inout' ) {
+ return (
+ $name . '._digits = ' . $d,
+ $name . '._scale = ' . $s,
+ );
+ }
+ elsif ( $attr eq 'out' ) {
+ return (
+ $name . '._digits = ' . $d,
+ $name . '._scale = ' . $s,
+ );
+ }
+ elsif ( $attr eq 'return' ) {
+ return (
+ $name . '._digits = ' . $d,
+ $name . '._scale = ' . $s,
+ );
}
- print $FH "\n";
}
- $type = $self->_get_defn($node->{type});
- if ($type->isa('VoidType')) {
- print $FH "\t",$self->{prefix},$self->{itf},"_",$node->{c_name},"(\n";
- }
- else {
- print $FH "\t",CORBA::XS::Cname_call->NameAttr($self->{symbtab}, $type, 'return'),"_ret = ";
- print $FH $self->{prefix},$self->{itf},"_",$node->{c_name},"(\n";
- }
- print $FH "\t\t_ref,\n";
- foreach (@{$node->{list_param}}) {
- $type = $self->_get_defn($_->{type});
- print $FH "\t\t",CORBA::XS::Cname_call->NameAttr($self->{symbtab}, $type, $_->{attr}),$_->{c_name},",";
- print $FH " /* ",$_->{attr}," (variable length) */\n" if (defined $type->{length});
- print $FH " /* ",$_->{attr}," (fixed length) */\n" unless (defined $type->{length});
+ elsif ( $type->isa('BaseInterface')
+ or $type->isa('ForwardBaseInterface') ) {
+ warn "_get_c_init_var BaseInterface : not supplied \n";
+ return;
}
- print $FH "\t\t&_Ev\n";
- print $FH "\t);\n";
- unless (exists $node->{modifier}) { # oneway
- print $FH "\n";
- print $FH "\tif (CORBA_NO_EXCEPTION == _Ev._major)\n";
- print $FH "\t{\n";
- print $FH "\t\t_align = 4;\n";
- print $FH "\t\tADD_SIZE_CORBA_long(_size,CORBA_NO_EXCEPTION);\n";
- if ($nb_param_out) {
- $type = $self->_get_defn($node->{type});
- unless ($type->isa('VoidType')) {
- print $FH "\t\tADD_SIZE_",$type->{c_name},"(_size,",$node->{c_put_name},");\n";
- }
- foreach (@{$node->{list_param}}) { # parameter
- if ( $_->{attr} eq 'inout'
- or $_->{attr} eq 'out' ) {
- $type = $self->_get_defn($_->{type});
- print $FH "\t\tADD_SIZE_",$type->{c_name},"(_size,",$_->{c_put_name},");\n";
- }
- }
+ elsif ( $type->isa('StructType')
+ or $type->isa('UnionType') ) {
+ if ( $attr eq 'in' ) {
+ return ();
}
- print $FH "\n";
- print $FH "\t\tif (NULL == (*_os = CORBA_alloc(_size)))\n";
- print $FH "\t\t{\n";
- print $FH "\t\t\treturn -1;\n";
- print $FH "\t\t}\n";
- print $FH "\t\telse\n";
- print $FH "\t\t{\n";
- print $FH "\t\t\t_align = 4;\n";
- print $FH "\t\t\t_p = *_os;\n";
- print $FH "\t\t\tPUT_CORBA_long(_p,CORBA_NO_EXCEPTION);\n";
- if ($nb_param_out) {
- $type = $self->_get_defn($node->{type});
- unless ($type->isa('VoidType')) {
- print $FH "\t\t\tPUT_",$type->{c_name},"(_p,",$node->{c_put_name},");\n";
+ elsif ( $attr eq 'inout' ) {
+ return ();
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return ($name . ' = NULL');
}
- foreach (@{$node->{list_param}}) { # parameter
- if ( $_->{attr} eq 'inout'
- or $_->{attr} eq 'out' ) {
- $type = $self->_get_defn($_->{type});
- print $FH "\t\t\tPUT_",$type->{c_name},"(_p,",$_->{c_put_name},");\n";
- }
+ else {
+ return ();
}
}
- print $FH "\t\t}\n";
- print $FH "\t}\n";
- if (exists $node->{list_raise}) {
- print $FH "\telse if (CORBA_USER_EXCEPTION == _Ev._major)\n";
- print $FH "\t{\n";
- my $condition = "if ";
- foreach (@{$node->{list_raise}}) {
- my $defn = $self->_get_defn($_);
- if ($nb_user_except > 1) {
- print $FH "\t\t",$condition,"(0 == strcmp(ex_",$defn->{c_name},",CORBA_exception_id(&_Ev)))\n";
- print $FH "\t\t{\n";
- }
- print $FH "\t\t\t",$defn->{c_name}," * _",$defn->{c_name}," = CORBA_exception_value(&_Ev);\n"
- if (exists $defn->{list_expr});
- print $FH "\t\t\t_align = 4;\n";
- print $FH "\t\t\tADD_SIZE_CORBA_long(_size,CORBA_USER_EXCEPTION);\n";
- print $FH "\t\t\tADD_SIZE_CORBA_string(_size,ex_",$defn->{c_name},");\n";
- print $FH "\t\t\tADD_SIZE_",$defn->{c_name},"(_size,*_",$defn->{c_name},");\n"
- if (exists $defn->{list_expr});
- print $FH "\n";
- print $FH "\t\t\tif (NULL == (*_os = CORBA_alloc(_size)))\n";
- print $FH "\t\t\t{\n";
- print $FH "\t\t\t\treturn -1;\n";
- print $FH "\t\t\t}\n";
- print $FH "\t\t\telse\n";
- print $FH "\t\t\t{\n";
- print $FH "\t\t\t\t_align = 4;\n";
- print $FH "\t\t\t\t_p = *_os;\n";
- print $FH "\t\t\t\tPUT_CORBA_long(_p,CORBA_USER_EXCEPTION);\n";
- print $FH "\t\t\t\tPUT_CORBA_string(_p,ex_",$defn->{c_name},");\n";
- print $FH "\t\t\t\tPUT_",$defn->{c_name},"(_p,*_",$defn->{c_name},");\n"
- if (exists $defn->{list_expr});
- print $FH "\t\t\t}\n";
- $condition = "else if ";
- if ($nb_user_except > 1) {
- print $FH "\t\t}\n";
- }
+ elsif ( $attr eq 'return' ) {
+ if (defined $type->{length}) { # variable
+ return ($name . ' = NULL');
+ }
+ else {
+ return ();
}
- print $FH "\t}\n";
}
- print $FH "\telse if (CORBA_SYSTEM_EXCEPTION == _Ev._major)\n";
- print $FH "\t{\n";
- print $FH "\t\tCORBA_SystemException *_pSE;\n";
- print $FH "\t\t_pSE = CORBA_exception_value(&_Ev);\n";
- print $FH "\t\t_align = 4;\n";
- print $FH "\t\tADD_SIZE_CORBA_long(_size,CORBA_SYSTEM_EXCEPTION);\n";
- print $FH "\t\tADD_SIZE_CORBA_string(_size,CORBA_exception_id(&_Ev));\n";
- print $FH "\t\tADD_SIZE_CORBA_long(_size,_pSE->minor);\n";
- print $FH "\t\tADD_SIZE_CORBA_long(_size,_pSE->completed);\n";
- print $FH "\t\tif (NULL == (*_os = CORBA_alloc(4)))\n";
- print $FH "\t\t{\n";
- print $FH "\t\t\treturn -1;\n";
- print $FH "\t\t}\n";
- print $FH "\t\telse\n";
- print $FH "\t\t{\n";
- print $FH "\t\t\t_align = 4;\n";
- print $FH "\t\t\t_p = *_os;\n";
- print $FH "\t\t\tPUT_CORBA_long(_p,CORBA_SYSTEM_EXCEPTION);\n";
- print $FH "\t\t\tPUT_CORBA_string(_p,CORBA_exception_id(&_Ev));\n";
- print $FH "\t\t\tPUT_CORBA_long(_p,_pSE->minor);\n";
- print $FH "\t\t\tPUT_CORBA_long(_p,_pSE->completed);\n";
- print $FH "\t\t}\n";
- print $FH "\t}\n";
- print $FH "\treturn _size;\n";
}
- if ($label_err) {
- print $FH "\n";
- print $FH "err:\n";
- foreach (@{$node->{list_param}}) { # parameter
- $type = $self->_get_defn($_->{type});
- print $FH "\tFREE_",$_->{attr},"_",$type->{c_name},"(",$_->{c_get_ptr_name},");\n"
- if (defined $type->{length});
+ elsif ( $type->isa('SequenceType') ) {
+ my $max = 0;
+ $max = $type->{max}->{c_literal} if (exists $type->{max});
+ if ( $attr eq 'in' ) {
+ return (
+ $name . '._maximum = ' . $max,
+ $name . '._length = 0',
+ $name . '._buffer = NULL'
+ );
}
- unless (exists $node->{modifier}) { # oneway
- print $FH "\treturn -1;\n";
+ elsif ( $attr eq 'inout' ) {
+ return (
+ $name . '._maximum = ' . $max,
+ $name . '._length = 0',
+ $name . '._buffer = NULL'
+ );
+ }
+ elsif ( $attr eq 'out' ) {
+ return ($name . ' = NULL');
+ }
+ elsif ( $attr eq 'return' ) {
+ return ($name . ' = NULL');
}
}
- print $FH "}\n";
-}
-
-#
-# 3.14 Attribute Declaration (inherited)
-#
-
-##############################################################################
-
-package CORBA::XS::Cdecl_var;
-
-#
-# See 1.21 Summary of Argument/Result Passing
-#
-
-# needs $type->{length}
-
-sub NameAttr {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- my $class = ref $type;
- $class = 'BasicType' if ($type->isa('BasicType'));
- $class = 'AnyType' if ($type->isa('AnyType'));
- $class = 'BaseInterface' if ($type->isa('BaseInterface'));
- $class = 'ForwardBaseInterface' if ($type->isa('ForwardBaseInterface'));
- my $func = 'NameAttr' . $class;
- if($proto->can($func)) {
- return $proto->$func($symbtab, $type, $attr, $name);
- }
- else {
- warn "Please implement a function '$func' in '",__PACKAGE__,"'.\n";
- }
-}
-
-sub NameAttrBaseInterface {
- warn __PACKAGE__,"::NameAttrBaseInterface : not supplied \n";
-}
-
-sub NameAttrForwardBaseInterface {
- warn __PACKAGE__,"::NameAttrForwardInterface : not supplied \n";
-}
-
-sub NameAttrTypeDeclarator {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if (exists $type->{array_size}) {
- warn __PACKAGE__,"::NameAttrTypeDeclarator $type->{idf} : empty array_size.\n"
- unless (@{$type->{array_size}});
+ elsif ( $type->isa('StringType')
+ or $type->isa('WideStringType') ) {
if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
+ return ($name . ' = NULL');
}
elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
+ return ($name . ' = NULL');
}
elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return $type->{c_name} . '_slice * ' . $name;
- }
- else {
- return $type->{c_name} . q{ } . $name;
- }
+ return ($name . ' = NULL');
}
elsif ( $attr eq 'return' ) {
- return $type->{c_name} . '_slice ' . $name;
- }
- else {
- warn __PACKAGE__,"::NameAttrTypeDeclarator : ERROR_INTERNAL $attr \n";
+ return ($name . ' = NULL');
}
}
- else {
- my $type = $type->{type};
- unless (ref $type) {
- $type = $symbtab->Lookup($type);
+ elsif ( $type->isa('TypeDeclarator') ) {
+ if (exists $type->{array_size}) {
+ warn "_get_c_init_var TypeDeclarator $type->{idf} : empty array_size.\n"
+ unless (@{$type->{array_size}});
+ if ( $attr eq 'in' ) {
+ return ();
+ }
+ elsif ( $attr eq 'inout' ) {
+ return ();
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return ($name . ' = NULL');
+ }
+ else {
+ return ();
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ return ();
+ }
+ }
+ else {
+ my $type = $type->{type};
+ unless (ref $type) {
+ $type = $self->{symbtab}->Lookup($type);
+ }
+ return $self->_get_c_init_var($type, $attr, $name);
}
- return $proto->NameAttr($symbtab, $type, $attr, $name);
- }
-}
-
-sub NameAttrNativeType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- warn __PACKAGE__,"::NameAttrNativeType native : not supplied \n";
-}
-
-sub NameAttrBasicType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
}
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('NativeType') ) {
+ warn "_get_c_init_var NativeType : not supplied \n";
+ return;
}
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('AnyType') ) {
+ warn "_get_c_init_var AnyType : not supplied \n";
+ return;
}
else {
- warn __PACKAGE__,"::NameAttrBasicType : ERROR_INTERNAL $attr \n";
+ my $class = ref $type;
+ warn "Please implement '$class' in '_get_c_init_var'.\n";
+ return;
}
}
-sub NameAttrAnyType {
- warn __PACKAGE__,"::NameAttrAnyType : not supplied \n";
-}
+sub _get_c_name_call {
+ my $self = shift;
+ my($type, $attr, $name) = @_;
-sub NameAttrStructType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return $type->{c_name} . ' * ' . $name;
+ if ( $type->isa('BasicType')
+ or $type->isa('EnumType') ) {
+ if ( $attr eq 'in' ) {
+ return q{};
}
- else {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $attr eq 'inout' ) {
+ return '&';
}
- }
- elsif ( $attr eq 'return' ) {
- if (defined $type->{length}) { # variable
- return $type->{c_name} . ' * ' . $name;
+ elsif ( $attr eq 'out' ) {
+ return '&';
}
- else {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $attr eq 'return' ) {
+ return q{};
}
}
- else {
- warn __PACKAGE__,"::NameAttrStructType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrUnionType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('BaseInterface')
+ or $type->isa('ForwardBaseInterface') ) {
+ warn "_get_c_name_call BaseInterface : not supplied \n";
+ return;
}
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return $type->{c_name} . ' * ' . $name;
+ elsif ( $type->isa('StructType')
+ or $type->isa('UnionType')
+ or $type->isa('SequenceType')
+ or $type->isa('FixedPtType') ) {
+ if ( $attr eq 'in' ) {
+ return '&';
}
- else {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $attr eq 'inout' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'out' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
}
}
- elsif ( $attr eq 'return' ) {
- if (defined $type->{length}) { # variable
- return $type->{c_name} . ' * ' . $name;
+ elsif ( $type->isa('StringType')
+ or $type->isa('WideStringType') ) {
+ if ( $attr eq 'in' ) {
+ return q{};
}
- else {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $attr eq 'inout' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'out' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
}
}
- else {
- warn __PACKAGE__,"::NameAttrUnionType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrEnumType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . q{ } . $name;
- }
- else {
- warn __PACKAGE__,"::NameAttrEnumType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrSequenceType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- my $max = 0;
- $max = $type->{max}->{c_literal} if (exists $type->{max});
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('TypeDeclarator') ) {
+ if (exists $type->{array_size}) {
+ warn "_get_c_name_call TypeDeclarator $type->{idf} : empty array_size.\n"
+ unless (@{$type->{array_size}});
+ if ( $attr eq 'in' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return q{};
+ }
+ else {
+ return q{};
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
+ }
+ }
+ else {
+ my $type = $type->{type};
+ unless (ref $type) {
+ $type = $self->{symbtab}->Lookup($type);
+ }
+ return $self->_get_c_name_call($type, $attr);
+ }
}
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . ' * ' . $name;
+ elsif ( $type->isa('NativeType') ) {
+ warn "_get_c_name_call NativeType : not supplied \n";
+ return;
}
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . ' * ' . $name;
+ elsif ( $type->isa('AnyType') ) {
+ warn "_get_c_name_call AnyType : not supplied \n";
+ return;
}
else {
- warn __PACKAGE__,"::NameAttrSequenceType : ERROR_INTERNAL $attr \n";
+ my $class = ref $type;
+ warn "Please implement '$class' in '_get_c_name_call'.\n";
+ return;
}
}
-sub NameAttrStringType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . '* ' . $name;
- }
- else {
- warn __PACKAGE__,"::NameAttrStringType : ERROR_INTERNAL $attr \n";
- }
-}
+sub _get_c_name_put {
+ my $self = shift;
+ my($type, $attr, $name) = @_;
-sub NameAttrWideStringType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
- }
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
+ if ( $type->isa('BasicType')
+ or $type->isa('EnumType')
+ or $type->isa('FixedPtType') ) {
+ if ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
+ }
}
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('BaseInterface')
+ or $type->isa('ForwardBaseInterface') ) {
+ warn "_get_c_name_put BaseInterface : not supplied \n";
+ return;
}
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . '* ' . $name;
+ elsif ( $type->isa('StructType')
+ or $type->isa('UnionType') ) {
+ if ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return '*';
+ }
+ else {
+ return q{};
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ if (defined $type->{length}) { # variable
+ return '*';
+ }
+ else {
+ return q{};
+ }
+ }
}
- else {
- warn __PACKAGE__,"::NameAttrWideStringType : ERROR_INTERNAL $attr \n";
+ elsif ( $type->isa('SequenceType') ) {
+ if ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ return '*';
+ }
+ elsif ( $attr eq 'return' ) {
+ return '*';
+ }
}
-}
-
-sub NameAttrFixedPtType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('StringType')
+ or $type->isa('WideStringType') ) {
+ if ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'return' ) {
+ return '*';
+ }
}
- elsif ( $attr eq 'inout' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('TypeDeclarator') ) {
+ if (exists $type->{array_size}) {
+ warn "_get_c_name_put TypeDeclarator $type->{idf} : empty array_size.\n"
+ unless (@{$type->{array_size}});
+ if ( $attr eq 'inout' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'out' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
+ }
+ }
+ else {
+ my $type = $type->{type};
+ unless (ref $type) {
+ $type = $self->{symbtab}->Lookup($type);
+ }
+ return $self->_get_c_name_put($type, $attr);
+ }
}
- elsif ( $attr eq 'out' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('NativeType') ) {
+ warn "_get_c_name_put NativeType : not supplied \n";
+ return;
}
- elsif ( $attr eq 'return' ) {
- return $type->{c_name} . q{ } . $name;
+ elsif ( $type->isa('AnyType') ) {
+ warn "_get_c_name_put AnyType : not supplied \n";
+ return;
}
else {
- warn __PACKAGE__,"::NameAttrFixedPtType : ERROR_INTERNAL $attr \n";
+ my $class = ref $type;
+ warn "Please implement '$class' in '_get_c_name_put'.\n";
+ return;
}
}
-##############################################################################
-
-package CORBA::XS::Cinit_var;
-
-#
-# See 1.21 Summary of Argument/Result Passing
-#
-
-# needs $type->{length}
+sub _get_c_ptrname_get {
+ my $self = shift;
+ my($type, $attr, $name) = @_;
-sub NameAttr {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- my $class = ref $type;
- $class = 'BasicType' if ($type->isa('BasicType'));
- $class = 'AnyType' if ($type->isa('AnyType'));
- $class = 'BaseInterface' if ($type->isa('BaseInterface'));
- $class = 'ForwardBaseInterface' if ($type->isa('ForwardBaseInterface'));
- my $func = 'NameAttr' . $class;
- if($proto->can($func)) {
- return $proto->$func($symbtab, $type, $attr, $name);
+ if ( $type->isa('BasicType')
+ or $type->isa('EnumType')
+ or $type->isa('FixedPtType') ) {
+ if ( $attr eq 'in' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'inout' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'out' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'return' ) {
+ return '&';
+ }
}
- else {
- warn "Please implement a function '$func' in '",__PACKAGE__,"'.\n";
+ elsif ( $type->isa('BaseInterface')
+ or $type->isa('ForwardBaseInterface') ) {
+ warn "_get_c_ptrname_get BaseInterface : not supplied \n";
+ return;
}
-}
-
-sub NameAttrBaseInterface {
- warn __PACKAGE__,"::NameAttrBaseInterface : not supplied \n";
-}
-
-sub NameAttrForwardBaseInterface {
- warn __PACKAGE__,"::NameAttrForwardBaseInterface : not supplied \n";
-}
-
-sub NameAttrTypeDeclarator {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if (exists $type->{array_size}) {
- warn __PACKAGE__,"::NameAttrTypeDeclarator $type->{idf} : empty array_size.\n"
- unless (@{$type->{array_size}});
+ elsif ( $type->isa('StructType')
+ or $type->isa('UnionType') ) {
if ( $attr eq 'in' ) {
- return ();
+ return '&';
}
elsif ( $attr eq 'inout' ) {
- return ();
+ return '&';
}
elsif ( $attr eq 'out' ) {
if (defined $type->{length}) { # variable
- return ($name . ' = NULL');
+ return q{};
}
else {
- return ();
+ return '&';
}
}
elsif ( $attr eq 'return' ) {
- return ();
- }
- else {
- warn __PACKAGE__,"::NameAttrTypeDeclarator : ERROR_INTERNAL $attr \n";
+ if (defined $type->{length}) { # variable
+ return q{};
+ }
+ else {
+ return '&';
+ }
}
}
- else {
- my $type = $type->{type};
- unless (ref $type) {
- $type = $symbtab->Lookup($type);
+ elsif ( $type->isa('SequenceType') ) {
+ my $max = 0;
+ $max = $type->{max}->{c_literal} if (exists $type->{max});
+ if ( $attr eq 'in' ) {
+ return '&';
}
- return $proto->NameAttr($symbtab, $type, $attr, $name);
- }
-}
-
-sub NameAttrNativeType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- warn __PACKAGE__,"::NameAttrNativeType native : not supplied \n";
-}
-
-sub NameAttrBasicType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ();
- }
- elsif ( $attr eq 'inout' ) {
- return ();
- }
- elsif ( $attr eq 'out' ) {
- return ();
- }
- elsif ( $attr eq 'return' ) {
- return ();
- }
- else {
- warn __PACKAGE__,"::NameAttrBasicType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrAnyType {
- warn __PACKAGE__,"::NameAttrAnyType : not supplied \n";
-}
-
-sub NameAttrStructType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ();
- }
- elsif ( $attr eq 'inout' ) {
- return ();
- }
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return ($name . ' = NULL');
+ elsif ( $attr eq 'inout' ) {
+ return '&';
}
- else {
- return ();
+ elsif ( $attr eq 'out' ) {
+ return q{};
+ }
+ elsif ( $attr eq 'return' ) {
+ return q{};
}
}
- elsif ( $attr eq 'return' ) {
- if (defined $type->{length}) { # variable
- return ($name . ' = NULL');
+ elsif ( $type->isa('StringType')
+ or $type->isa('WideStringType') ) {
+ if ( $attr eq 'in' ) {
+ return '&';
}
- else {
- return ();
+ elsif ( $attr eq 'inout' ) {
+ return '&';
}
- }
- else {
- warn __PACKAGE__,"::NameAttrStructType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrUnionType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ();
- }
- elsif ( $attr eq 'inout' ) {
- return ();
- }
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return ($name . ' = NULL');
+ elsif ( $attr eq 'out' ) {
+ return '&';
}
- else {
- return ();
+ elsif ( $attr eq 'return' ) {
+ return q{};
}
}
- elsif ( $attr eq 'return' ) {
- if (defined $type->{length}) { # variable
- return ($name . ' = NULL');
+ elsif ( $type->isa('TypeDeclarator') ) {
+ if (exists $type->{array_size}) {
+ warn "_get_c_ptrname_get TypeDeclarator $type->{idf} : empty array_size.\n"
+ unless (@{$type->{array_size}});
+ if ( $attr eq 'in' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'inout' ) {
+ return '&';
+ }
+ elsif ( $attr eq 'out' ) {
+ if (defined $type->{length}) { # variable
+ return '&';
+ }
+ else {
+ return '&';
+ }
+ }
+ elsif ( $attr eq 'return' ) {
+ return '&';
+ }
}
else {
- return ();
+ my $type = $type->{type};
+ unless (ref $type) {
+ $type = $self->{symbtab}->Lookup($type);
+ }
+ return $self->_get_c_ptrname_get($type, $attr);
}
}
- else {
- warn __PACKAGE__,"::NameAttrUnionType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrEnumType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ();
- }
- elsif ( $attr eq 'inout' ) {
- return ();
- }
- elsif ( $attr eq 'out' ) {
- return ();
+ elsif ( $type->isa('NativeType') ) {
+ warn "_get_c_ptrname_get NativeType native : not supplied \n";
+ return;
}
- elsif ( $attr eq 'return' ) {
- return ();
+ elsif ( $type->isa('AnyType') ) {
+ warn "_get_c_ptrname_get AnyType : not supplied \n";
+ return;
}
else {
- warn __PACKAGE__,"::NameAttrEnumType : ERROR_INTERNAL $attr \n";
+ my $class = ref $type;
+ warn "Please implement '$class' in '_get_c_ptrname_get'.\n";
+ return;
}
}
-sub NameAttrSequenceType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- my $max = 0;
- $max = $type->{max}->{c_literal} if (exists $type->{max});
- if ( $attr eq 'in' ) {
- return (
- $name . '._maximum = ' . $max,
- $name . '._length = 0',
- $name . '._buffer = NULL'
- );
- }
- elsif ( $attr eq 'inout' ) {
- return (
- $name . '._maximum = ' . $max,
- $name . '._length = 0',
- $name . '._buffer = NULL'
- );
- }
- elsif ( $attr eq 'out' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'return' ) {
- return ($name . ' = NULL');
- }
- else {
- warn __PACKAGE__,"::NameAttrSequenceType : ERROR_INTERNAL $attr \n";
- }
-}
+#
+# 3.5 OMG IDL Specification
+#
-sub NameAttrStringType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'inout' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'out' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'return' ) {
- return ($name . ' = NULL');
- }
- else {
- warn __PACKAGE__,"::NameAttrStringType : ERROR_INTERNAL $attr \n";
+sub visitSpecification {
+ my $self = shift;
+ my($node) = @_;
+ my $filename = $self->{prefix} . basename($self->{srcname}, '.idl') . '.h';
+ my $FH = $self->{out};
+ print $FH "/* This file was generated (by ",$0,"). DO NOT modify it */\n";
+ print $FH "// From file : ",$self->{srcname},", ",$self->{srcname_size}," octets, ",POSIX::ctime($self->{srcname_mtime});
+ print $FH "\n";
+ print $FH "#include <string.h>\n";
+ print $FH "#include <",$self->{incpath},"cdr.h>\n";
+ print $FH "#include \"",$filename,"\"\n";
+ print $FH "\n";
+ print $FH "\n";
+ foreach (@{$node->{list_decl}}) {
+ $self->_get_defn($_)->visit($self);
}
+ print $FH "/* end of file : ",$self->{filename}," */\n";
+ close $FH;
}
-sub NameAttrWideStringType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- if ( $attr eq 'in' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'inout' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'out' ) {
- return ($name . ' = NULL');
- }
- elsif ( $attr eq 'return' ) {
- return ($name . ' = NULL');
- }
- else {
- warn __PACKAGE__,"::NameAttrWideStringType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrFixedPtType {
- my $proto = shift;
- my($symbtab, $type, $attr, $name) = @_;
- my $d = $type->{d}->{c_literal};
- my $s = $type->{s}->{c_literal};
- if ( $attr eq 'in' ) {
- return (
- $name . '._digits = ' . $d,
- $name . '._scale = ' . $s,
- );
- }
- elsif ( $attr eq 'inout' ) {
- return (
- $name . '._digits = ' . $d,
- $name . '._scale = ' . $s,
- );
- }
- elsif ( $attr eq 'out' ) {
- return (
- $name . '._digits = ' . $d,
- $name . '._scale = ' . $s,
- );
- }
- elsif ( $attr eq 'return' ) {
- return (
- $name . '._digits = ' . $d,
- $name . '._scale = ' . $s,
- );
- }
- else {
- warn __PACKAGE__,"::NameAttrFixedPtType : ERROR_INTERNAL $attr \n";
- }
-}
-
-##############################################################################
-
-package CORBA::XS::Cname_call;
+#
+# 3.7 Module Declaration (inherited)
+#
#
-# See 1.21 Summary of Argument/Result Passing
+# 3.8 Interface Declaration
#
-# needs $type->{length}
-
-sub NameAttr {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- my $class = ref $type;
- $class = 'BasicType' if ($type->isa('BasicType'));
- $class = 'AnyType' if ($type->isa('AnyType'));
- $class = 'BaseInterface' if ($type->isa('BaseInterface'));
- $class = 'ForwardBaseInterface' if ($type->isa('ForwardBaseInterface'));
- my $func = 'NameAttr' . $class;
- if($proto->can($func)) {
- return $proto->$func($symbtab, $type, $attr);
- }
- else {
- warn "Please implement a function '$func' in '",__PACKAGE__,"'.\n";
- }
-}
-
-sub NameAttrBaseInterface {
- warn __PACKAGE__,"::NameAttrBaseInterface : not supplied \n";
-}
-
-sub NameAttrAbstractInterface {
- warn __PACKAGE__,"::NameAttrForwardBaseInterface : not supplied \n";
-}
-
-sub NameAttrTypeDeclarator {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if (exists $type->{array_size}) {
- warn __PACKAGE__,"::NameAttrTypeDeclarator $type->{idf} : empty array_size.\n"
- unless (@{$type->{array_size}});
- if ( $attr eq 'in' ) {
- return q{};
- }
- elsif ( $attr eq 'inout' ) {
- return q{};
- }
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return q{};
- }
- else {
- return q{};
- }
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrTypeDeclarator : ERROR_INTERNAL $attr \n";
+sub visitRegularInterface {
+ my $self = shift;
+ my($node) = @_;
+ my $FH = $self->{out};
+ print $FH "/*\n";
+ print $FH " * begin of interface ",$node->{c_name},"\n";
+ print $FH " */\n";
+ foreach (@{$node->{list_decl}}) {
+ my $defn = $self->_get_defn($_);
+ if ( $defn->isa('Operation')
+ or $defn->isa('Attributes') ) {
+ next;
}
+ $defn->visit($self);
}
- else {
- my $type = $type->{type};
- unless (ref $type) {
- $type = $symbtab->Lookup($type);
+ print $FH "\n";
+ if ( $self->{srcname} eq $node->{filename}
+ and keys %{$node->{hash_attribute_operation}} ) {
+ $self->{itf} = $node->{c_name};
+ print $FH "\t\t/*-- functions --*/\n";
+ print $FH "\n";
+ foreach (values %{$node->{hash_attribute_operation}}) {
+ $self->_get_defn($_)->visit($self);
}
- return $proto->NameAttr($symbtab, $type, $attr);
+ print $FH "\n";
}
+ print $FH "/*\n";
+ print $FH " * end of interface ",$node->{c_name},"\n";
+ print $FH " */\n";
+ print $FH "\n";
}
-sub NameAttrNativeType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- warn __PACKAGE__,"::NameAttrNativeType native : not supplied \n";
-}
-
-sub NameAttrBasicType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return q{};
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrBasicType : ERROR_INTERNAL $attr \n";
+sub visitAbstractInterface {
+ # C mapping is aligned with CORBA 2.1
+ my $self = shift;
+ my($node) = @_;
+ my $FH = $self->{out};
+ print $FH "/*\n";
+ print $FH " * begin of interface ",$node->{c_name},"\n";
+ print $FH " */\n";
+ foreach (@{$node->{list_decl}}) {
+ my $defn = $self->_get_defn($_);
+ if ( $defn->isa('Operation')
+ or $defn->isa('Attributes') ) {
+ next;
+ }
+ $defn->visit($self);
}
+ print $FH "\n";
+ print $FH "/*\n";
+ print $FH " * end of interface ",$node->{c_name},"\n";
+ print $FH " */\n";
+ print $FH "\n";
}
-sub NameAttrAnyType {
- warn __PACKAGE__,"::NameAttrAnyType : not supplied \n";
-}
+#
+# 3.9 Value Declaration (inherited)
+#
-sub NameAttrStructType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return '&';
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrStructType : ERROR_INTERNAL $attr \n";
- }
-}
+#
+# 3.10 Constant Declaration (inherited)
+#
-sub NameAttrUnionType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return '&';
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrUnionType : ERROR_INTERNAL $attr \n";
- }
-}
+#
+# 3.11 Type Declaration (inherited)
+#
-sub NameAttrEnumType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return q{};
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrEnumType : ERROR_INTERNAL $attr \n";
- }
-}
+#
+# 3.12 Exception Declaration (inherited)
+#
-sub NameAttrSequenceType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return '&';
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrSequenceType : ERROR_INTERNAL $attr \n";
- }
-}
+#
+# 3.13 Operation Declaration
+#
-sub NameAttrStringType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return q{};
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrStringType : ERROR_INTERNAL $attr \n";
+sub visitOperation {
+ my $self = shift;
+ my($node) = @_;
+ my $FH = $self->{out};
+ my $label_err = undef;
+ my $nb_param_out = 0;
+ my $nb_param_in = 0;
+ my $type = $self->_get_defn($node->{type});
+ unless ($type->isa('VoidType')) { # return
+ $label_err = $type->{length};
+ $nb_param_out ++;
+ $node->{c_put_name} = $self->_get_c_name_put($type, 'return') . '_ret';
}
-}
-
-sub NameAttrWideStringType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return q{};
+ foreach (@{$node->{list_in}}) { # parameter
+ $type = $self->_get_defn($_->{type});
+ $_->{c_get_ptr_name} = $self->_get_c_ptrname_get($type, $_->{attr}) . $_->{c_name};
+ $label_err ||= $type->{length};
+ $nb_param_in ++;
}
- elsif ( $attr eq 'inout' ) {
- return '&';
+ foreach (@{$node->{list_inout}}) { # parameter
+ $type = $self->_get_defn($_->{type});
+ $_->{c_get_ptr_name} = $self->_get_c_ptrname_get($type, $_->{attr}) . $_->{c_name};
+ $_->{c_put_name} = $self->_get_c_name_put($type, $_->{attr}) . $_->{c_name};
+ $label_err ||= $type->{length};
+ $nb_param_in ++;
+ $nb_param_out ++;
}
- elsif ( $attr eq 'out' ) {
- return '&';
+ foreach (@{$node->{list_out}}) { # parameter
+ $type = $self->_get_defn($_->{type});
+ $_->{c_get_ptr_name} = $self->_get_c_ptrname_get($type, $_->{attr}) . $_->{c_name};
+ $_->{c_put_name} = $self->_get_c_name_put($type, $_->{attr}) . $_->{c_name};
+ $nb_param_out ++;
}
- elsif ( $attr eq 'return' ) {
- return q{};
+ my $nb_user_except = 0;
+ $nb_user_except = @{$node->{list_raise}} if (exists $node->{list_raise});
+ print $FH "\n";
+ if (exists $node->{modifier}) { # oneway
+ print $FH "void cdr_",$self->{itf},"_",$node->{c_name},"(void * _ref, char *_is)\n";
}
else {
- warn __PACKAGE__,"::NameAttrWideStringType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrFixedPtType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'in' ) {
- return '&';
- }
- elsif ( $attr eq 'inout' ) {
- return '&';
- }
- elsif ( $attr eq 'out' ) {
- return '&';
+ print $FH "int cdr_",$self->{itf},"_",$node->{c_name},"(void * _ref, char *_is, char **_os)\n";
}
- elsif ( $attr eq 'return' ) {
- return q{};
+ print $FH "{\n";
+ print $FH "\tCORBA_Environment _Ev;\n";
+ $type = $self->_get_defn($node->{type});
+ unless ($type->isa('VoidType')) {
+ print $FH "\t",$self->_get_c_decl_var($type, 'return', '_ret'),";\n";
}
- else {
- warn __PACKAGE__,"::NameAttrFixedPtType : ERROR_INTERNAL $attr \n";
+ foreach (@{$node->{list_param}}) { # parameter
+ $type = $self->_get_defn($_->{type});
+ print $FH "\t",$self->_get_c_decl_var($type, $_->{attr}, $_->{c_name}),";\n";
}
-}
-
-##############################################################################
-
-package CORBA::XS::Cname_put2;
-
-#
-# See 1.21 Summary of Argument/Result Passing
-#
-
-# needs $type->{length}
-
-sub NameAttr {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- my $class = ref $type;
- $class = 'BasicType' if ($type->isa('BasicType'));
- $class = 'AnyType' if ($type->isa('AnyType'));
- $class = 'BaseInterface' if ($type->isa('BaseInterface'));
- $class = 'ForwardBaseInterface' if ($type->isa('ForwardBaseInterface'));
- my $func = 'NameAttr' . $class;
- if($proto->can($func)) {
- return $proto->$func($symbtab, $type, $attr);
+ if ($nb_param_in or $nb_param_out or $nb_user_except) {
+ print $FH "\tCORBA_char *_p;\n";
+ print $FH "\tunsigned _align = 4;\n";
}
- else {
- warn "Please implement a function '$func' in '",__PACKAGE__,"'.\n";
+ unless (exists $node->{modifier}) { # oneway
+ print $FH "\tint _size = 0;\n";
}
-}
-
-sub NameAttrBaseInterface {
- warn __PACKAGE__,"::NameAttrBaseInterface : not supplied \n";
-}
-
-sub NameAttrForwardBaseInterface {
- warn __PACKAGE__,"::NameAttrForwardBaseInterface : not supplied \n";
-}
-
-sub NameAttrTypeDeclarator {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if (exists $type->{array_size}) {
- warn __PACKAGE__,"::NameAttrTypeDeclarator $type->{idf} : empty array_size.\n"
- unless (@{$type->{array_size}});
- if ( $attr eq 'inout' ) {
- return q{};
- }
- elsif ( $attr eq 'out' ) {
- return q{};
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameTypeDeclarator : ERROR_INTERNAL $attr \n";
+ print $FH "\n";
+ $type = $self->_get_defn($node->{type});
+ unless ($type->isa('VoidType')) {
+ my @init = $self->_get_c_init_var($type, 'return', '_ret');
+ foreach (@init) {
+ print $FH "\t",$_,";\n";
}
}
- else {
- my $type = $type->{type};
- unless (ref $type) {
- $type = $symbtab->Lookup($type);
+ foreach (@{$node->{list_param}}) { # parameter
+ $type = $self->_get_defn($_->{type});
+ my @init = $self->_get_c_init_var($type, $_->{attr}, $_->{c_name});
+ foreach (@init) {
+ print $FH "\t",$_,";\n";
}
- return $proto->NameAttr($symbtab, $type, $attr);
}
-}
-
-sub NameAttrNativeType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- warn __PACKAGE__,"::NameAttrNativeType native : not supplied \n";
-}
-
-sub NameAttrBasicType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'inout' ) {
- return q{};
+ print $FH "\tmemset(&_Ev, 0, sizeof _Ev);\n";
+ if ($nb_param_in) {
+ print $FH "\t_p = _is;\n";
+ foreach (@{$node->{list_param}}) { # parameter
+ if ( $_->{attr} eq 'in'
+ or $_->{attr} eq 'inout' ) {
+ $type = $self->_get_defn($_->{type});
+ print $FH "\tGET_",$type->{c_name},"(_p,",$_->{c_get_ptr_name},");\n";
+ }
+ }
+ print $FH "\n";
}
- elsif ( $attr eq 'out' ) {
- return q{};
- }
- elsif ( $attr eq 'return' ) {
- return q{};
- }
- else {
- warn __PACKAGE__,"::NameAttrBasicType : ERROR_INTERNAL $attr \n";
- }
-}
-
-sub NameAttrAnyType {
- warn __PACKAGE__,"::NameAttrAnyType : not supplied \n";
-}
-
-sub NameAttrStructType {
- my $proto = shift;
- my($symbtab, $type, $attr) = @_;
- if ( $attr eq 'inout' ) {
- return q{};
- }
- elsif ( $attr eq 'out' ) {
- if (defined $type->{length}) { # variable
- return '*';
- }
- else {
- return q{};