File Coverage

blib/lib/CORBA/XS/CVisitor.pm

Criterion	Covered	Total	%
statement	12	270	4.4
branch	0	34	0.0
condition	0	3	0.0
subroutine	4	28	14.2
pod	0	22	0.0
total	16	357	4.4

#
#           Interface Definition Language (OMG IDL CORBA v3.0)
#

package CORBA::XS::CVisitor;

use strict;
use warnings;

our $VERSION = '0.62';

use File::Basename;
use POSIX qw(ctime);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless $self, $class;
    my($parser) = @_;
    $self->{srcname} = $parser->YYData->{srcname};
    $self->{srcname_size} = $parser->YYData->{srcname_size};
    $self->{srcname_mtime} = $parser->YYData->{srcname_mtime};
    $self->{symbtab} = $parser->YYData->{symbtab};
    $self->{modules} = [ @{$parser->YYData->{modules}} ];
    $self->{inc} = {};
    $self->{has_methods} = 0;
    $self->{num_key} = 'num_xs_c';
    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 _insert_inc {
    my $self = shift;
    my($filename) = @_;
    my $FH = $self->{out};
    if (! exists $self->{inc}->{$filename}) {
        $self->{inc}->{$filename} = 1;
        $filename = basename($filename, '.idl') . '.h';
        print $FH "#include \"",$filename,"\"\n";
    }
}

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

#
#   3.5     OMG IDL Specification
#

sub visitSpecification {
    my $self = shift;
    my($node) = @_;
    my $src_name = basename($self->{srcname}, '.idl');
    $self->open_stream($src_name . '.c');
    my $FH = $self->{out};
    print $FH "/* ex: set ro: */\n";
    print $FH "/* This file was generated (by ",$0,"). DO NOT modify it */\n";
    print $FH "/*\n";
    print $FH " * From file : ",$self->{srcname},", ",$self->{srcname_size}," octets, ",POSIX::ctime($self->{srcname_mtime});
    print $FH " */\n";
    print $FH "\n";
    print $FH "#include \"EXTERN.h\"\n";
    print $FH "#include \"perl.h\"\n";
    print $FH "#include \"XSUB.h\"\n";
    print $FH "\n";
    $self->{newXS} = q{};
    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }
    print $FH "#ifdef __cplusplus\n";
    print $FH "extern \"C\"\n";
    print $FH "#endif\n";
    print $FH "XS(boot_",$src_name,")\n";
    print $FH "{\n";
    print $FH "    dXSARGS;\n";
    print $FH "    char* file = __FILE__;\n";
    print $FH "\n";
    print $FH "    XS_VERSION_BOOTCHECK ;\n";
    print $FH "\n";
    print $FH $self->{newXS};
    print $FH "    XSRETURN_YES;\n";
    print $FH "}\n";
    print $FH "\n";
    print $FH "/* end of file : ",$self->{filename}," */\n";
    print $FH "\n";
    print $FH "/*\n";
    print $FH " * Local variables:\n";
    print $FH " *   buffer-read-only: t\n";
    print $FH " * End:\n";
    print $FH " */\n";
    close $FH;
    unless ($self->{has_methods}) {
        unlink $self->{filename}
             or die "can't delete $self->{filename} ($!).\n";
        return;
    }

    my $filename = 'Makefile.PL';
    open my $OUT, '>', $filename
            or die "can't open $filename ($!).\n";
    print $OUT "use ExtUtils::MakeMaker;\n";
    print $OUT "# See lib/ExtUtils/MakeMaker.pm for details of how to influence\n";
    print $OUT "# the contents of the Makefile that is written.\n";
    print $OUT "WriteMakefile(\n";
    print $OUT "    'NAME'          => '",$src_name,"',\n";
    print $OUT "    'VERSION_FROM'  => '",$src_name,".pm', # finds \$VERSION\n";
    print $OUT "    'PREREQ_PM'     => {\n";
    print $OUT "                        'Error'                 => 0,\n";
    print $OUT "                        'CORBA::Perl::CORBA'    => 0\n";
    print $OUT "    },\n";
    print $OUT "    'LIBS'          => [''], # e.g., '-lm'\n";
    print $OUT "    'DEFINE'        => '', # e.g., '-DHAVE_SOMETHING'\n";
    print $OUT "    'INC'           => '', # e.g., '-I/usr/include/other'\n";
    print $OUT "    'MYEXTLIB'      => 'cdr_",$src_name,"\$(OBJ_EXT) skel_",$src_name,"\$(OBJ_EXT) corba\$(OBJ_EXT)',\n";
    print $OUT "    'PM'            => {\n";
    foreach (@{$self->{modules}}) {
        print $OUT "                        '",$_,".pm' => '\$(INST_LIBDIR)/",$_,".pm',\n";
    }
    print $OUT "                        '",$src_name,".pm' => '\$(INST_LIBDIR)/",$src_name,".pm'\n";
    print $OUT "    },\n";
    print $OUT ");\n";
    close $OUT;

    $filename = 'MANIFEST';
    open $OUT, '>', $filename
            or die "can't open $filename ($!).\n";
    foreach (@{$self->{modules}}) {
        print $OUT $_,".pm\n";
        print $OUT $_,".h\n";
    }
    print $OUT $src_name,".pm\n";
    print $OUT $src_name,".c\n";
    print $OUT $src_name,".h\n";
    print $OUT "cdr_",$src_name,".c\n";
    print $OUT "skel_",$src_name,".c\n";
    print $OUT "corba.c\n";
    print $OUT "Changes\n";
    print $OUT "Makefile.PL\n";
    print $OUT "MANIFEST\n";
    print $OUT "test.pl\n";
    close $OUT;

    $filename = 'Changes';
    open $OUT, '>', $filename
            or die "can't open $filename ($!).\n";
    print $OUT "Revision history for Perl extension ",$src_name,".\n";
    print $OUT "\n";
    print $OUT "0.01  ",POSIX::ctime(time());
    print $OUT "\t- original version; created by idl2xs_c\n";
    print $OUT "\t\tfrom ",$self->{srcname},", ",$self->{srcname_size}," octets, ",POSIX::ctime($self->{srcname_mtime});
    close $OUT;

    $filename = 'test.pl';
    open $OUT, '>', $filename
            or die "can't open $filename ($!).\n";
    print $OUT "# Before `make install' is performed this script should be runnable with\n";
    print $OUT "# `make test'. After `make install' it should work as `perl test.pl'\n";
    print $OUT "\n";
    print $OUT "######################### We start with some black magic to print on failure.\n";
    print $OUT "\n";
    print $OUT "# Change 1..1 below to 1..last_test_to_print .\n";
    print $OUT "# (It may become useful if the test is moved to ./t subdirectory.)\n";
    print $OUT "\n";
    print $OUT "BEGIN { \$| = 1; print \"1..1\\n\"; }\n";
    print $OUT "END {print \"not ok 1\\n\" unless \$loaded;}\n";
    print $OUT "use ",$src_name,";\n";
    print $OUT "\$loaded = 1;\n";
    print $OUT "print \"ok 1\\n\";\n";
    print $OUT "\n";
    print $OUT "######################### End of black magic.\n";
    print $OUT "\n";
    print $OUT "# Insert your test code below (better if it prints \"ok 13\"\n";
    print $OUT "# (correspondingly \"not ok 13\") depending on the success of chunk 13\n";
    print $OUT "# of the test code):\n";
    close $OUT;

    my $path = $INC{'CORBA/XS/CVisitor.pm'};
    $path =~ s/CVisitor\.pm$//i;
    $path .= 'corba.c';
    open my $IN, '<', $path
            or die "can't read $path ($!)";
    $filename = 'corba.c';
    open $OUT, '>', $filename
            or die "can't open $filename ($!).\n";
    while (<$IN>) {
        print $OUT $_;
    }
    close $OUT;
    close $IN;

    do 'Makefile.PL';
}

#
#   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) = @_;
    my $FH = $self->{out};
    if ($self->{srcname} eq $node->{filename}) {
        foreach (@{$node->{list_decl}}) {
            $self->_get_defn($_)->visit($self);
        }
    }
    else {
        $self->_insert_inc($node->{filename});
    }
}

#
#   3.8     Interface Declaration
#

sub visitRegularInterface {
    my $self = shift;
    my($node) = @_;
    if ($self->{srcname} eq $node->{filename}) {
        $self->{itf} = $node->{c_name};
        my $FH = $self->{out};
        print $FH "/* interface ",$node->{pl_name}," */\n";
        print $FH "\n";
        foreach (values %{$node->{hash_attribute_operation}}) {
            $self->_get_defn($_)->visit($self);
        }
    }
}

sub visitAbstractInterface {
    my $self = shift;
    my($node) = @_;
    if ($self->{srcname} eq $node->{filename}) {
        $self->{itf} = $node->{c_name};
        my $FH = $self->{out};
        print $FH "/* abstract interface ",$node->{pl_name}," */\n";
        print $FH "\n";
        foreach (values %{$node->{hash_attribute_operation}}) {
            $self->_get_defn($_)->visit($self);
        }
    }
}

sub visitForwardRegularInterface {
    # empty
}

sub visitForwardAbstractInterface {
    # empty
}

sub visitBaseInterface {
    # C mapping is aligned with CORBA 2.1
}

sub visitForwardBaseInterface {
    # C mapping is aligned with CORBA 2.1
}

#
#   3.10    Constant Declaration
#

sub visitConstant {
    # 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
}

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};
    $self->{has_methods} = 1;
    my $c_package = $node->{pl_package};
    $c_package =~ s/::/_/g;
    if (exists $node->{modifier}) {     # oneway
        print $FH "extern void cdr_",$self->{itf},"_",$node->{c_name},"(void * ref, char *is);\n";
        print $FH "\n";
        print $FH "XS(XS_",$c_package,"_cdr_",$node->{pl_name},")\n";
        print $FH "{\n";
        print $FH "    dXSARGS;\n";
        print $FH "    if (items != 2)\n";
        print $FH "        Perl_croak(aTHX_ \"Usage: ",$node->{pl_package},"::cdr_",$node->{pl_name},"(ref, is)\");\n";
        print $FH "    {\n";
        print $FH "        void * ref = (void *)SvIV(ST(0));\n";
        print $FH "        char * is = (char *)SvPV(ST(1),PL_na);\n";
        print $FH "        dXSTARG;\n";
        print $FH "        cdr_",$self->{itf},"_",$node->{c_name},"(ref, is);\n";
        print $FH "        XSprePUSH; PUSHi((IV)0);\n";
        print $FH "    }\n";
        print $FH "    XSRETURN(1);\n";
        print $FH "}\n";
        print $FH "\n";
    }
    else {
        print $FH "extern int cdr_",$self->{itf},"_",$node->{c_name},"(void * ref, char *is, char **os);\n";
        print $FH "\n";
        print $FH "XS(XS_",$c_package,"_cdr_",$node->{pl_name},")\n";
        print $FH "{\n";
        print $FH "    dXSARGS;\n";
        print $FH "    if (items != 3)\n";
        print $FH "        Perl_croak(aTHX_ \"Usage: ",$node->{pl_package},"::cdr_",$node->{pl_name},"(ref, is, os)\");\n";
        print $FH "    {\n";
        print $FH "        void * ref = (void *)SvIV(ST(0));\n";
        print $FH "        char * is = (char *)SvPV(ST(1),PL_na);\n";
        print $FH "        char * os;\n";
        print $FH "        int size;\n";
        print $FH "        dXSTARG;\n";
        print $FH "        size = cdr_",$self->{itf},"_",$node->{c_name},"(ref, is, &os);\n";
        print $FH "        if (size >= 0)\n";
        print $FH "            sv_setpvn((SV*)ST(2), os, size);\n";
        print $FH "        SvSETMAGIC(ST(2));\n";
        print $FH "        XSprePUSH; PUSHi((IV)size);\n";
        print $FH "    }\n";
        print $FH "    XSRETURN(1);\n";
        print $FH "}\n";
        print $FH "\n";
    }
    $self->{newXS} .= "        newXS(\"" . $node->{pl_package} . "::cdr_" . $node->{pl_name} . "\", XS_";
        $self->{newXS} .= $c_package . "_cdr_" . $node->{pl_name} . ", file);\n";
}

#
#   3.14    Attribute Declaration
#

sub visitAttribute {
    my $self = shift;
    my($node) = @_;
    $node->{_get}->visit($self);
    $node->{_set}->visit($self) if (exists $node->{_set});
}

1;