/usr/local/CPAN/CORBA-XPIDL/CORBA/XPIDL/JavaVisitor.pm

• package CORBA::XPIDL::JavaVisitor
  • new
  • open_stream
  • _get_defn
  • _classname_iid
  • _comment
  • _java_type
  • visitSpecification
  • visitImport
  • visitModules
  • visitModule
  • visitBaseInterface
  • visitRegularInterface
  • visitForwardBaseInterface
  • visitConstant
  • visitExpression
  • visitTypeDeclarators
  • visitNativeType
  • visitStructType
  • visitUnionType
  • visitForwardStructType
  • visitForwardUnionType
  • visitEnumType
  • visitException
  • visitOperation
  • visitAttributes
  • visitAttribute
  • visitTypeId
  • visitTypePrefix
  • visitCodeFragment
• EOF

package CORBA::XPIDL::JavaVisitor;

use strict;
use warnings;

our $VERSION = '0.20';

use File::Basename;

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};
    my $filename;
    if ($parser->YYData->{opt_e}) {
        $filename = $parser->YYData->{opt_e};
    }
    else {
        if ($parser->YYData->{opt_o}) {
            $filename = $parser->YYData->{opt_o} . '.java';
        }
        else {
            $filename = basename($self->{srcname}, '.idl') . '.java';
        }
    }
    $self->open_stream($filename);
    $self->{num_key} = 'num_doc_xp';
    return $self;
}

sub open_stream {
    my $self = shift;
    my ($filename) = @_;
    open $self->{out}, '>', $filename
            or die "can't open $filename ($!).\n";
    $self->{filename} = $filename;
}

sub _get_defn {
    my $self = shift;
    my ($defn) = @_;
    if (ref $defn) {
        return $defn;
    }
    else {
        return $self->{symbtab}->Lookup($defn);
    }
}

sub _classname_iid {
    my $self = shift;
    my ($node) = @_;
    my $idf = $node->{idf};
    $idf =~ s/^ns/NS_/;     # backcompat naming styles
    my $classname = uc $idf;
    $classname .= '_IID';
    return $classname;
}

sub _comment {
    my $self = shift;
    my ($node) = @_;
    return q{} unless ($node->{doc});
    my $FH = $self->{out};
    my $indent = q{ } x 4;
    print $FH $indent,"/**\n";
    foreach (split /\n/, $node->{doc}) {
        s/^\s+//;
        next unless ($_);
        print $FH $indent," * ",$_,"\n";
    }
    print $FH $indent," */\n";
}

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

    while ($node->isa('TypeDeclarator')) {
        $node = $self->_get_defn($node->{type});
    }

    if    ($node->isa('VoidType')) {
        return 'Object';
    }
    elsif ($node->isa('IntegerType')) {
        if    ($node->{value} eq 'short') {
            return 'short';
        }
        elsif ($node->{value} eq 'unsigned short') {
            return 'short';
        }
        elsif ($node->{value} eq 'long') {
            return 'int';
        }
        elsif ($node->{value} eq 'unsigned long') {
            return 'int';
        }
        elsif ($node->{value} eq 'long long') {
            return 'long';
        }
        elsif ($node->{value} eq 'unsigned long long') {
            return 'long';
        }
        else {
            warn __PACKAGE__,"::_java_type (IntegerType) $node->{value}.\n";
        }
    }
    elsif ($node->isa('CharType')) {
        return 'char';
    }
    elsif ($node->isa('WideCharType')) {
        return 'char';
    }
    elsif ($node->isa('StringType')) {
        return 'String';
    }
    elsif ($node->isa('WideStringType')) {
        return 'String';
    }
    elsif ($node->isa('BooleanType')) {
        return 'boolean';
    }
    elsif ($node->isa('OctetType')) {
        return 'byte';
    }
    elsif ($node->isa('FloatingPtType')) {
        if    ($node->{value} eq 'float') {
            return 'float';
        }
        elsif ($node->{value} eq 'double') {
            return 'double';
        }
        elsif ($node->{value} eq 'long double') {
            warn __PACKAGE__," 'long double' not available at this time for Java.\n";
            return 'double';
        }
        else {
            warn __PACKAGE__,"::_java_type (FloatingType) $node->{value}.\n";
        }
    }
    elsif ($node->isa('NativeType')) {
        if    (  $node->{native} eq 'void' ) {
            return 'Object';
        }
        elsif (  $node->{native} eq 'nsID'
                or $node->{native} eq 'nsIID'
                or $node->{native} eq 'nsCID' ) {
            # XXX: s.b test for "iid" attribute
            # XXX: special class for nsIDs
            return 'nsID';
        }
        else {
            # XXX: special class for opaque types
            return 'OpaqueValue';
        }
    }
    elsif ($node->isa('BaseInterface')) {
        return $node->{idf};
    }
    elsif ($node->isa('ForwardBaseInterface')) {
        return $node->{idf};
    }
    else {
        my $class = ref $node;
        warn __PACKAGE__,"::_java_type unknown type ($class).\n";
    }
}

#
#   3.5     OMG IDL Specification
#

sub visitSpecification {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};

    print $FH "/*\n";
    print $FH " * ************* DO NOT EDIT THIS FILE ***********\n";
    print $FH " *\n";
    print $FH " * This file was automatically generated from ",$self->{srcname},".\n";
    print $FH " */\n";
    print $FH "\n";
    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }
    print $FH "\n";
    print $FH "/*\n";
    print $FH " * end\n";
    print $FH " */\n";
    close $FH;
}

#
#   3.6     Import Declaration
#

sub visitImport {
    # empty
}

#
#   3.7     Module Declaration
#

sub visitModules {
    my $self = shift;
    my ($node) = @_;
    unless (exists $node->{$self->{num_key}}) {
        $node->{$self->{num_key}} = 0;
    }
    my $module = ${$node->{list_decl}}[$node->{$self->{num_key}}];
    $module->visit($self);
    $node->{$self->{num_key}} ++;
}

sub visitModule {
    my $self = shift;
    my ($node) = @_;
    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }
}

#
#   3.8     Interface Declaration
#

sub visitBaseInterface {
    # empty
}

sub visitRegularInterface {
    my $self = shift;
    my ($node) = @_;
    return unless ($self->{srcname} eq $node->{filename});
    my $FH = $self->{out};

    # Write out JavaDoc comment
    print $FH "\n";
    print $FH "/**\n";
    print $FH " * Interface ",$node->{idf},"\n";
    my $iid = $node->getProperty('uuid');
    if (defined $iid) {
        print $FH " *\n";
        print $FH " * IID: 0x",$iid,"\n";
    }
    print $FH " */\n";
    print $FH "\n";

    # Write "public interface <foo>"
    print $FH "public interface ",$node->{idf};
    if (exists $node->{inheritance}) {
        print $FH " extends ";
        my $first = 1;
        foreach (@{$node->{inheritance}->{list_interface}}) {
            my $base = $self->_get_defn($_);
            print $FH ", " unless ($first);
            print $FH $base->{idf};
            $first = 0;
        }
    }
    print $FH "\n";
    print $FH "{\n";
    if (defined $iid) {
        my $classname_iid = $self->_classname_iid($node);
        # Write interface constants for IID
        print $FH "    public static final String ",$classname_iid,"_STRING =\n";
        print $FH "        \"",$iid,"\";\n";
        print $FH "\n";
        print $FH "    public static final nsID ",$classname_iid," =\n";
        print $FH "        new nsID(\"",$iid,"\");\n";
        print $FH "\n";
    }

    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }
    print $FH "}\n";
    print $FH "\n";
}

sub visitForwardBaseInterface {
    # empty
}

#
#   3.10        Constant Declaration
#

sub visitConstant {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};

    my $type = $self->_get_defn($node->{type});
    my $java_type = $self->_java_type($type);
    my $value = $node->{value}->{value};
    print $FH "\n";
    $self->_comment($node);
    print $FH "    public static final ",$java_type," ",$node->{idf}," = ",$value,";\n";
}

sub visitExpression {
    # empty
}

#
#   3.11    Type Declaration
#

sub visitTypeDeclarators {
    # empty
}

sub visitNativeType {
    # empty
}

#
#   3.11.2  Constructed Types
#

sub visitStructType {
    # empty
}

sub visitUnionType {
    # empty
}

sub visitForwardStructType {
    # empty
}

sub visitForwardUnionType {
    # empty
}

#   3.11.2.4    Enumerations
#

sub visitEnumType {
    # empty
}

#
#   3.12    Exception Declaration
#

sub visitException {
    # empty
}

#
#   3.13    Operation Declaration
#

sub visitOperation {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};

    my $method_notxpcom = $node->hasProperty('notxpcom');
    my $method_noscript = $node->hasProperty('noscript');

    print $FH "\n";
    $self->_comment($node);

    # Write beginning of method declaration
    print $FH "    ";
    # Nonscriptable methods become package-protected
    print $FH "public " unless ($method_noscript);

    # Write return type
    # Unlike C++ headers, Java interfaces return the declared
    # return value; an exception indicates XPCOM method failure.
    my $type = $self->_get_defn($node->{type});
    if ($method_notxpcom or !$type->isa('VoidType')) {
        print $FH $self->_java_type($type);
    }
    else {
        # Check for retval attribute
        my $retval_param;
        foreach (@{$node->{list_param}}) {
            if ($_->hasProperty('retval')) {
                $retval_param = $_;
                last;
            }
        }
        if (defined $retval_param) {
            $type = $self->_get_defn($retval_param->{type});
            print $FH $self->_java_type($type);
        }
        else {
            print $FH "void";
        }
    }

    # Write method name
    print $FH " ",lcfirst($node->{idf}),"(";

    # Write parameters
    my $first = 1;
    foreach (@{$node->{list_param}}) {
        # Skip "retval"
        next if ($_->hasProperty('retval'));
        print $FH ", " unless ($first);
        # Put in type of parameter
        $type = $self->_get_defn($_->{type});
        print $FH $self->_java_type($type);
        # If the parameter is out or inout, make it a Java array of the
        # appropriate type
        print $FH "[]" if ($_->{attr} ne "in");
        #Put in name of parameter
        print $FH " ",$_->{idf};
        $first = 0;
    }
    print $FH ")";

    if (exists $node->{list_raise}) {
        print $FH " throws ";
        $first = 1;
        foreach (@{$node->{list_raise}}) {      # exception
            my $defn = $self->_get_defn($_);
            print $FH ", " unless ($first);
            print $FH $defn->{idf};
            $first = 0;
        }
    }

    print $FH ";\n";
}

#
#   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 $FH = $self->{out};

    my $method_noscript = $node->hasProperty('noscript');
    my $type = $self->_get_defn($node->{type});

    print $FH "\n";
    $self->_comment($node);

    # Write access permission ("public" unless nonscriptable)
    print $FH "    ";
    print $FH "public " unless ($method_noscript);
    # Write the proper Java return value for the get operation
    print $FH $self->_java_type($type);
    # Write the name of the accessor ("get") method.
    print $FH " get",ucfirst($node->{idf}),"();\n";

    unless (exists $node->{modifier}) {     # readonly
        # Nonscriptable methods become package-protected
        print $FH "    ";
        print $FH "public " unless ($method_noscript);
        # Write attribute access method name and return type
        print $FH "void set",ucfirst($node->{idf}),"(";
        # Write the proper Java type for the set operation
        print $FH $self->_java_type($type);
        # Write the name of the formal parameter.
        print $FH " value);\n"
    }
}

#
#   3.15    Repository Identity Related Declarations
#

sub visitTypeId {
    # empty
}

sub visitTypePrefix {
    # empty
}

#
#   XPIDL
#

sub visitCodeFragment {
    # empty
}

1;