view release on metacpan or  search on metacpan

lib/CORBA/IDLtree.pm  view on Meta::CPAN

        my ($name) = @_;

        $this->{_queries}++;
        if (exists $this->{_cache}{$name}) {
            $this->{_hits}++;
            return $this->{_cache}{$name};
        }
        return undef;
    }

    # return hits / queries ratio
    sub ratio {
        my $this = shift;
        return $this->{_hits}." / ".$this->{_queries};
    }

    # return known names
    sub symbols {
        my $this = shift;
        return keys %{$this->{_cache}};
    }
}

# The @predef_types array must have the types in the same order as
# the numeric order of type identifying constants defined above.
my @predef_types = qw/ none boolean octet char wchar short long long_long
                       unsigned_short unsigned_long unsigned_long_long
                       float double long_double string wstring Object
                       TypeCode any fixed bounded_string bounded_wstring
                       sequence enum typedef native struct union case default
                       exception const module interface interface_fwd
                       valuetype valuetype_fwd valuetype_box
                       attribute oneway void factory method
                       include pragma_prefix pragma_version pragma_id pragma /;

# list of all IDL keywords (as of CORBA 3.0) in lower case
# used to check for name conflicts
my %keywords = map { $_ => undef } qw/
  abstract any attribute boolean case char component const
  consumes context custom default double emits enum exception
  eventtype factory false finder fixed float getraises home
  import in inout interface local long module multiple native
  object octet oneway out port primarykey private provides public
  publishes raises readonly setraises sequence short string
  struct supports switch true truncatable typedef typeid
  typeprefix unsigned union uses valuebase valuetype void
  wchar wstring/;

my @infilename = ();    # infilename and line_number move in parallel.
my @line_number = ();
my @remark = ();        # Auxiliary to comment processing
my @post_comment = ();  # Auxiliary to comment processing
my @global_items = ();  # Auxiliary to sub unget_items
my $findnode_cache = new CORBA::IDLtree::Cache();
   # Auxiliary to find_node_i(): cache for lookups
my $abstract = 0;       # can also contain LOCAL (for interfaces)
my $currfile = -1;
my $starting_line_number_of_remark = 0;  # 0 = there is no pre comment
my $line_number_of_post_comment    = 0;  # 0 = there is no post comment
my $emucpp = 1;         # use C preprocessor emulation
my $locale_was_determined = 0;
my $locale = undef;

sub locate_executable {
    # FIXME: this is probably another reinvention of the wheel.
    # Should look for builtin Perl solution or CPAN module that does this.
    my $executable = shift;
    # my $pathsep = $Config{'path_sep'};
    my $pathsep = ':';
    my $fully_qualified_name = "";
    my @dirs = split(/$pathsep/, $ENV{'PATH'});
    foreach (@dirs) {
        my $fqn = "$_/$executable";
        if (-e $fqn) {
            $fully_qualified_name = $fqn;
            last;
        }
    }
    $fully_qualified_name;
}


sub idlsplit {
    my $str = shift;
    my $in_preprocessor = $str =~ /^\s*#/;
    my $in_string = 0;
    my $in_lit = 0;
    my $in_space = 0;
    my $i;
    my @out = ();
    my $ondx = -1;
    for ($i = 0; $i < length($str); $i++) {
        my $ch = substr($str, $i, 1);
        if ($in_string) {
            $out[$ondx] .= $ch;
            if ($ch eq '"' and substr($str, $i-1, 1) ne "\\") {
                $in_string = 0;
            }
        } elsif ($ch eq '"') {
            $in_string = 1;
            $out[++$ondx] = $ch;
        } elsif ($ch eq "'") {
            my $endx = index $str, "'", $i + 2;
            if ($endx < $i + 2) {
                error "cannot find closing apostrophe of char literal";
                return @out;
            }
            $out[++$ondx] = substr($str, $i, $endx - $i + 1);
            # print "idlsplit: $out[$ondx]\n";
            $i = $endx;
        } elsif ($ch =~ /[a-z_0-9\.]/i) {
            if (! $in_lit) {
                $in_lit = 1;
                $ondx++;
            }
            $out[$ondx] .= $ch;
        } elsif ($in_lit) {
            $in_lit = 0;
            # do preprocessor substitution
            if (exists $active_defines{$out[$ondx]}) {
                my $value = $active_defines{$out[$ondx]};
                if ("$value" ne "") {

lib/CORBA/IDLtree.pm  view on Meta::CPAN

        } elsif (is_a($type, CHAR)) {
            foreach $c (@{$case->[SUBORDINATES]}) {
                unless ($c =~ /^'.*'$/ || $c =~ /^\d+$/) {
                    error "invalid case value $c";
                    return undef;
                }
            }
        } else {
            # must be integer
            foreach $c (@{$case->[SUBORDINATES]}) {
                unless ($c =~ /^[-+]?\d+$/) {
                    my $resolved_const = get_numeric($symroot, $c, curr_scope);
                    unless ($resolved_const =~ /^[-+]?\d+$/) {
                        error "invalid case value $c";
                        return undef;
                    }
                }
            }
        }
        foreach (@$known_cases) {
            next if $i++ == 0;
            next unless $_->[TYPE] == CASE;
            foreach (@{$_->[SUBORDINATES]}) {
                foreach $c (@{$case->[SUBORDINATES]}) {
                    if ($c eq $_) {
                        error "duplicate case label $c";
                        return undef;
                    }
                }
            }
        }
    }
    return 1;
}


sub Parse_File {
    my $filename = shift;
    if ($cache_trees) {
        my $incfile_contents_ref = $includecache->get($filename);
        if ($incfile_contents_ref) {
            bless($incfile_contents_ref, "CORBA::IDLtree");
            return $incfile_contents_ref;
        }
    } else {
        $includecache->clear();    # Roots of previously parsed includefiles
        $findnode_cache->clear();  # Flush the find_node_i() cache
    }
    $global_idlfile = $filename;
    @infilename = ();    # infilename and line_number move in parallel.
    @line_number = ();
    $n_errors = 0;       # auxiliary to sub error
    @remark = ();        # Auxiliary to comment processing
    @post_comment = ();  # Auxiliary to comment processing
    $abstract = 0;
    $currfile = -1;
    $did_emucppmsg = 0;  # auxiliary to sub emucppmsg
    @scopestack = ();
    @prev_symroots = ();
    %active_defines = %defines;
    unless ($locale_was_determined) {
        foreach my $env ('LANG', 'LOCALE', 'LC_ALL') {
            if (exists $ENV{$env}) {
                my $lang = $ENV{$env};
                if ($lang && $lang ne "C") {
                    $locale = $lang;
                    last;
                }
            }
        }
        $locale_was_determined = 1;
    }
    my $res = Parse_File_i($filename);
    if ($cache_statistics) {
        print "Node cache: " . $findnode_cache->ratio()."\n";
        print "Include cache: " . $includecache->ratio()."\n";
    }
    if ($res && !@$res) {
        warn "Warning: CORBA::IDLtree::Parse_File: $filename is empty\n";
        $res = 0;
    } elsif ($cache_trees) {
        # Put the main unit in the include cache, too
        # (it may be #included by a subsequent main file.)
        $includecache->add($filename, $res);
    }
    return $res;
}

# the function changes the passed in struct node
# into an "equivalent" valuetype
sub convert_to_valuetype {
    my ($node) = @_;

    # just in case...
    return  unless $node->[TYPE] == STRUCT;

    # first, convert the members to public state members
    foreach (@{$node->[SUBORDINATES]}) {
        my $membertype = $_->[TYPE];
        if ($membertype == REMARK) {
            $_ = [ 0, $_ ];
        } else {
            if (isnode($membertype) &&
                ($membertype->[TYPE] == CORBA::IDLtree::BOUNDED_STRING ||
                 $membertype->[TYPE] == CORBA::IDLtree::BOUNDED_WSTRING)) {
                # Ad hoc member type declaration shall have its own
                # enclosing valuetype as the SCOPEREF
                $membertype->[SCOPEREF] = $node;
            }
            $_ = [ PUBLIC, $_ ];
        }
    }
    # now, change the subordinates:
    $node->[SUBORDINATES] = [
                             0,   # abstract
                             [ 0, # is_truncatable
                               0  # ancestors
                             ],
                             $node->[SUBORDINATES], # members
                            ];
    # change the type into VALUETYPE
    $node->[TYPE] = VALUETYPE;
}

# Parses an annotation application.
# Parsing of an @annotation definition is not done here.
# Expects the annotation name as the first parameter and possible
# annotation arguments by an array reference in the second parameter.
# Is expected to be called not too long after get_items (the sub may find
# that too many args were returned by get_items and may therefore call
# unget_items).