/usr/local/CPAN/CORBA-XPIDL/CORBA/XPIDL/XptVisitor.pm
package CORBA::XPIDL::XptVisitor;
use strict;
use warnings;
our $VERSION = '0.20';
use File::Basename;
use POSIX qw(ctime);
use CORBA::XPIDL::XPT;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless $self, $class;
my ($parser) = @_;
$self->{srcname} = $parser->YYData->{srcname};
$self->{symbtab} = $parser->YYData->{symbtab};
$self->{emit_typelib_annotations} = $parser->YYData->{opt_a};
$self->{typelib} = $parser->YYData->{opt_t};
my $filename;
if ($parser->YYData->{opt_e}) {
$filename = $parser->YYData->{opt_e};
}
else {
if ($parser->YYData->{opt_o}) {
$filename = $parser->YYData->{opt_o} . '.xpt';
}
else {
$filename = basename($self->{srcname}, '.idl') . '.xpt';
}
}
$self->{outfile} = $filename;
return $self;
}
sub _get_defn {
my $self = shift;
my ($defn) = @_;
if (ref $defn) {
return $defn;
}
else {
return $self->{symbtab}->Lookup($defn);
}
}
sub _is_dipper {
my $self = shift;
my ($node) = @_; # type
return $node->hasProperty('domstring')
|| $node->hasProperty('utf8string')
|| $node->hasProperty('cstring')
|| $node->hasProperty('astring');
}
sub _arg_num {
my $self = shift;
my ($name, $node) = @_;
my $count = 0;
foreach (@{$node->{list_param}}) {
return $count
if ($_->{idf} eq $name);
$count ++;
}
warn __PACKAGE__,"::_arg_num : can't found argument ($name) in method '$node->{idf}'.\n";
}
#
# 3.5 OMG IDL Specification
#
sub visitSpecification {
my $self = shift;
my ($node) = @_;
my $major_version = substr($self->{typelib}, 0, 1);
my $minor_version = substr($self->{typelib}, 2, 1);
$self->{xpt} = new XPT::File(
magic => XPT::File::MAGIC,
major_version => $major_version,
minor_version => $minor_version,
);
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
$self->{xpt}->indexe();
if ($self->{emit_typelib_annotations}) {
my $creator = 'xpidl ' . $CORBA::XPIDL::VERSION;
my $data = "Created from " . $self->{srcname} .
"\nCreation date: " . POSIX::ctime(time()) . "Interfaces:";
foreach (sort keys %{$self->{xpt}->{interface_iid}}) {
my $itf = ${$self->{xpt}->{interface_iid}}{$_};
next unless (defined $itf->{interface_descriptor});
$data .= q{ } . $itf->{name};
}
my $anno = new XPT::Annotation(
tag => 1,
creator => $creator,
private_data => $data,
);
$self->{xpt}->add_annotation($anno);
}
$self->{xpt}->terminate_annotations();
# print $self->{xpt}->stringify();
open my $OUT, '>', $self->{outfile}
or die "FAILED: can't open $self->{outfile}\n";
binmode $OUT, ':raw';
print $OUT $self->{xpt}->marshal();
close $OUT;
}
#
# 3.7 Module Declaration
#
sub visitModules {
my $self = shift;
my ($node) = @_;
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
}
sub visitModule {
my $self = shift;
my ($node) = @_;
if ($self->{srcname} eq $node->{filename}) {
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
}
}
#
# 3.8 Interface Declaration
#
sub visitRegularInterface {
my $self = shift;
my ($node) = @_;
if ($self->{srcname} eq $node->{filename}) {
my $parent_interface_name;
if (exists $node->{inheritance}) {
my $base = $self->_get_defn(${$node->{inheritance}->{list_interface}}[0]);
my $namespace = $base->getProperty('namespace') || q{};
$parent_interface_name = $namespace . '::' . $base->{idf};
$self->_add_interface($base);
}
my $interface_descriptor = new XPT::InterfaceDescriptor(
parent_interface => $parent_interface_name,
method_descriptors => [],
const_descriptors => [],
is_scriptable => $node->hasProperty('scriptable'),
is_function => $node->hasProperty('function'),
);
$self->{itf} = $interface_descriptor;
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
$self->_add_interface($node, $interface_descriptor);
}
}
sub _add_interface {
my $self = shift;
my ($node, $desc) = @_;
my $iid = chr(0) x 16;
my $str_iid = $node->getProperty('uuid');
if (defined $str_iid) {
$str_iid =~ s/-//g;
$iid = q{};
while ($str_iid) {
$iid .= chr(hex(substr $str_iid, 0, 2));
$str_iid = substr $str_iid, 2;
}
}
my $name = $node->{idf};
my $namespace = $node->getProperty('namespace') || q{};
my $entry = new XPT::InterfaceDirectoryEntry(
iid => new XPT::IID($iid),
name => $name,
name_space => $namespace,
interface_descriptor => $desc,
);
$self->{xpt}->add_interface($entry);
}
sub visitForwardRegularInterface {
my $self = shift;
my ($node) = @_;
if ($self->{srcname} eq $node->{filename}) {
$self->_add_interface($node);
}
}
sub visitBaseInterface {
# empty
}
sub visitForwardBaseInterface {
# empty
}
#
# 3.10 Constant Declaration
#
sub visitConstant {
my $self = shift;
my ($node) = @_;
my $type = $self->_get_defn($node->{type});
my $desc = $self->_type($type);
my $value = $node->{value}->{value};
my $cst = new XPT::ConstDescriptor(
name => $node->{idf},
type => $desc,
value => $value,
);
push @{$self->{itf}->{const_descriptors}}, $cst;
}
#
# 3.11 Type Declaration
#
sub visitTypeDeclarators {
# empty
}
sub visitNativeType {
# empty
}
sub _type {
my $self = shift;
my ($node, $param, $method) = @_;
my $is_array = defined $method && $param->hasProperty('array');
my $type = $node;
while ($type->isa('TypeDeclarator')) {
$type = $self->_get_defn($type->{type});
}
my %hash;
my $iid_is = $param->getProperty('iid_is') if (defined $param);
if ( $type->isa('IntegerType')) {
if ($type->{value} eq 'short') {
$hash{tag} = XPT::int16;
}
elsif ($type->{value} eq 'unsigned short') {
$hash{tag} = XPT::uint16;
}
elsif ($type->{value} eq 'long') {
$hash{tag} = XPT::int32;
}
elsif ($type->{value} eq 'unsigned long') {
$hash{tag} = XPT::uint32;
}
elsif ($type->{value} eq 'long long') {
$hash{tag} = XPT::int64;
}
elsif ($type->{value} eq 'unsigned long long') {
$hash{tag} = XPT::uint64;
}
else {
warn __PACKAGE__,"::_type (IntegerType) $node->{value}.\n";
}
}
elsif ($type->isa('OctetType')) {
$hash{tag} = XPT::uint8;
}
elsif ($type->isa('FloatingPtType')) {
if ( $type->{value} eq 'float') {
$hash{tag} = XPT::float;
}
elsif ($type->{value} eq 'double') {
$hash{tag} = XPT::double;
}
else {
warn __PACKAGE__,"::_type (FloatingPtType) $node->{value}.\n";
}
}
elsif ($type->isa('BooleanType')) {
$hash{tag} = XPT::boolean;
}
elsif ($type->isa('CharType')) {
$hash{tag} = XPT::char;
}
elsif ($type->isa('WideCharType')) {
$hash{tag} = XPT::wchar_t;
}
elsif ($type->isa('StringType')) {
my $size_is = $param->getProperty('size_is')
if (defined $param);
if ($is_array or !defined $method or !defined $size_is) {
$hash{tag} = XPT::pstring;
$hash{is_pointer} = 1;
}
else {
$hash{tag} = XPT::StringWithSizeTypeDescriptor;
$hash{is_pointer} = 1;
$hash{size_is_arg_num} = $self->_arg_num($size_is, $method);
$hash{length_is_arg_num} = $hash{size_is_arg_num};
my $length_is = $param->getProperty('length_is');
$hash{length_is_arg_num} = $self->_arg_num($length_is, $method)
if (defined $length_is);
}
}
elsif ($type->isa('WideStringType')) {
my $size_is = $param->getProperty('size_is')
if (defined $param);
if ($is_array or !defined $method or !defined $size_is) {
$hash{tag} = XPT::pwstring;
$hash{is_pointer} = 1;
}
else {
$hash{tag} = XPT::WideStringWithSizeTypeDescriptor;
$hash{is_pointer} = 1;
$hash{size_is_arg_num} = $self->_arg_num($size_is, $method);
$hash{length_is_arg_num} = $hash{size_is_arg_num};
my $length_is = $param->getProperty('length_is');
$hash{length_is_arg_num} = $self->_arg_num($length_is, $method)
if (defined $length_is);
}
}
elsif ($type->isa('NativeType') and !defined $iid_is) {
if ($node->hasProperty('nsid')) {
$hash{tag} = XPT::nsIID;
if ($node->hasProperty('ref')) {
$hash{is_pointer} = 1;
$hash{is_reference} = 1;
}
elsif ($node->hasProperty('ptr')) {
$hash{is_pointer} = 1;
}
}
elsif ($node->hasProperty('domstring')) {
$hash{tag} = XPT::domstring;
$hash{is_pointer} = 1;
if ($node->hasProperty('ref')) {
$hash{is_reference} = 1;
}
}
elsif ($node->hasProperty('astring')) {
$hash{tag} = XPT::astring;
$hash{is_pointer} = 1;
if ($node->hasProperty('ref')) {
$hash{is_reference} = 1;
}
}
elsif ($node->hasProperty('utf8string')) {
$hash{tag} = XPT::utf8string;
$hash{is_pointer} = 1;
if ($node->hasProperty('ref')) {
$hash{is_reference} = 1;
}
}
elsif ($node->hasProperty('cstring')) {
$hash{tag} = XPT::cstring;
$hash{is_pointer} = 1;
if ($node->hasProperty('ref')) {
$hash{is_reference} = 1;
}
}
else {
$hash{tag} = XPT::void;
$hash{is_pointer} = 1;
}
}
elsif ( $type->isa('RegularInterface')
or $type->isa('ForwardRegularInterface')
or $type->isa('NativeType') ) {
if (defined $iid_is) {
$hash{tag} = XPT::InterfaceIsTypeDescriptor;
$hash{is_pointer} = 1;
$hash{arg_num} = $self->_arg_num($iid_is, $method);
}
else {
$self->_add_interface($type);
my $namespace = $type->getProperty('namespace') || q{};
$hash{interface} = $namespace . '::' . $type->{idf};
$hash{tag} = XPT::InterfaceTypeDescriptor;
$hash{is_pointer} = 1;
}
}
elsif ($type->isa('VoidType')) {
$hash{tag} = XPT::void;
}
my $desc = new XPT::TypeDescriptor( %hash );
if ($is_array) {
# size_is is required
my $size_is = $param->getProperty('size_is');
# die "[array] requires [size_is()].\n"
# unless (defined $size_is);
my $size_is_arg_num = $self->_arg_num($size_is, $method);
# length_is is optional
my $length_is_arg_num = $size_is_arg_num;
my $length_is = $param->getProperty('length_is');
$length_is_arg_num = $self->_arg_num($size_is, $method)
if (defined $length_is);
return new XPT::TypeDescriptor(
is_pointer => 1,
is_unique_pointer => 0,
is_reference => 0,
tag => XPT::ArrayTypeDescriptor,
size_is_arg_num => $size_is_arg_num,
length_is_arg_num => $length_is_arg_num,
type_descriptor => $desc,
);
}
else {
return $desc
}
}
#
# 3.11.2 Constructed Types
#
sub visitStructType {
# empty
}
sub visitUnionType {
# empty
}
sub visitEnumType {
# empty
}
#
# 3.12 Exception Declaration
#
sub visitException {
# empty
}
#
# 3.13 Operation Declaration
#
sub visitOperation {
my $self = shift;
my ($node) = @_;
my $notxpcom = $node->hasProperty('notxpcom');
my @params = ();
foreach (@{$node->{list_param}}) {
push @params, $self->_param($_, $node);
}
my $type = $self->_get_defn($node->{type});
my $result;
if ($notxpcom) {
$result = new XPT::ParamDescriptor(
in => 0,
out => 0,
retval => 1,
shared => 0,
dipper => 0,
type => $self->_type($type),
);
}
else {
unless ($type->isa('VoidType')) {
my $dipper = $self->_is_dipper($type);
my $desc = $self->_type($type);
push @params, new XPT::ParamDescriptor(
in => $dipper,
out => !$dipper,
retval => 1,
shared => 0,
dipper => $dipper,
type => $desc,
);
}
$result = $self->_ns_result();
}
my $method = new XPT::MethodDescriptor(
is_getter => 0,
is_setter => 0,
is_not_xpcom => $notxpcom,
is_constructor => 0,
is_hidden => $node->hasProperty('noscript'),
name => $node->{idf},
params => \@params,
result => $result,
);
push @{$self->{itf}->{method_descriptors}}, $method;
}
sub _param {
my $self = shift;
my ($node, $parent) = @_;
my $type = $self->_get_defn($node->{type});
my $in = 0;
my $out = 0;
if ($node->{attr} eq 'in') {
$in = 1;
}
elsif ($node->{attr} eq 'out') {
$out = 1;
}
elsif ($node->{attr} eq 'inout') {
$in = 1;
$out = 1;
}
# my $dipper = $self->_is_dipper($type);
my $dipper = $self->_is_dipper($node);
if ($dipper and $out) {
$out = 0;
$in = 1;
}
my $desc = $self->_type($type, $node, $parent);
return new XPT::ParamDescriptor(
in => $in,
out => $out,
retval => $node->hasProperty('retval'),
shared => $node->hasProperty('shared'),
dipper => $dipper,
type => $desc,
);
}
sub _ns_result {
my $self = shift;
return new XPT::ParamDescriptor(
in => 0,
out => 0,
retval => 0,
shared => 0,
dipper => 0,
type => new XPT::TypeDescriptor(
is_pointer => 0,
is_unique_pointer => 0,
is_reference => 0,
tag => XPT::uint32,
),
);
}
#
# 3.14 Attribute Declaration
#
sub visitAttributes {
my $self = shift;
my ($node) = @_;
foreach (@{$node->{list_decl}}) {
$self->_get_defn($_)->visit($self);
}
}
sub visitAttribute {
my $self = shift;
my ($node) = @_;
my $type = $self->_get_defn($node->{type});
my $dipper = $self->_is_dipper($type);
my $getter = new XPT::MethodDescriptor(
is_getter => 1,
is_setter => 0,
# is_not_xpcom => $node->hasProperty('notxpcom'),
is_not_xpcom => 0, # functionality or bug
is_constructor => 0,
is_hidden => $node->hasProperty('noscript'),
name => $node->{idf},
params => [
new XPT::ParamDescriptor(
in => $dipper,
out => !$dipper,
retval => 1,
shared => 0,
dipper => $dipper,
type => $self->_type($type),
)
],
result => $self->_ns_result(),
);
push @{$self->{itf}->{method_descriptors}}, $getter;
unless (exists $node->{modifier}) { # readonly
my $setter = new XPT::MethodDescriptor(
is_getter => 0,
is_setter => 1,
# is_not_xpcom => $node->hasProperty('notxpcom'),
is_not_xpcom => 0, # functionality or bug
is_constructor => 0,
is_hidden => $node->hasProperty('noscript'),
name => $node->{idf},
params => [
new XPT::ParamDescriptor(
in => 1,
out => 0,
retval => 0,
shared => 0,
dipper => 0,
type => $self->_type($type),
)
],
result => $self->_ns_result(),
);
push @{$self->{itf}->{method_descriptors}}, $setter;
}
}
#
# 3.15 Repository Identity Related Declarations
#
sub visitTypeId {
# empty
}
sub visitTypePrefix {
# empty
}
#
# XPIDL
#
sub visitCodeFragment {
# empty
}
1;