view release on metacpan or  search on metacpan

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

sub collect_includes {
   my($symroot, $dependency_hash_ref) = @_;
   my $myname = "CORBA::IDLtree::collect_includes";

   if (! $symroot) {
       warn "\n$myname: encountered empty elem (returning)\n";
       return;
   } elsif (not ref $symroot) {
       warn "\n$myname: incoming symroot is $symroot (returning)\n";
       return;
   } elsif (isnode $symroot) {
       warn "\n$myname: usage error: invoked on node (returning)\n";
       return;
   }
   foreach my $noderef (@{$symroot}) {
       my @node = @{$noderef};
       my $type = $node[TYPE];
       my $name = $node[NAME];
       if ($type == INCFILE) {
           $dependency_hash_ref->{$name} = 1;
           collect_includes($noderef->[SUBORDINATES], $dependency_hash_ref);
       }
   }
}

# For floating point notation, FORTRAN and C inspired languages support
# omitting the trailing dot-zero but Ada does not.
sub append_dot_zero {
    my $res = shift;
    my $epos = index($res, 'e');
    if ($epos < 0) {
        $epos = index($res, 'E');
    }
    if ($epos > 0) {
        $res = substr($res, 0, $epos) . ".0" . substr($res, $epos);
    } else {
        $res .= ".0";
    }
    return $res;
}

sub get_numeric {
    my $tree = shift;
    my ($value, $scoperef, $wantfloat) = @_;

    if ($value =~ /^[-+]?(?:0x)?[0-9a-f]*$/i) {
        # integer literal, convert to decimal
        if ($is64bit) {
            my $res = eval($value);
            if ($wantfloat) {
                $res = append_dot_zero($res);
            }
            return $res;
        } else {
            # use BigInt so that Perl won't switch to
            # floating point for large values
            my $v;
            if ($value =~ /^[-+]?0[0-7]/) {
                # Math::BigInt->new won't convert octal numbers
                # (and from_oct produces NaN for '0')...
                if (Math::BigInt->can('from_oct')) {
                    $v = Math::BigInt->from_oct($value);
                } else {
                    # older Math::BigInt versions don't have from_oct
                    my @dg = (split //, $value);
                    my $sg = '';
                    if ($dg[0] eq '-' || $dg[0] eq '+' || $dg[0] eq '0') {
                       my $c = shift @dg;
                       $sg = $c if $c eq '-';
                    }
                    $v = Math::BigInt->new(shift @dg);
                    while (@dg > 0) {
                       my $c = shift(@dg);
                       if ($c lt '0' || $c gt '7') {
                           $v->bnan();
                           last;
                       }
                       $v = $v * 8 + $c;
                    }
                    $v->bneg() if $sg eq '-';
                }
                if ($v->is_nan()) {
                    return undef;
                }
            } else {
                $v = Math::BigInt->new($value);
                if ($v->is_nan()) {
                    return undef;
                }
                if ($wantfloat && $v !~ /\./) {
                    $v = append_dot_zero($v);
                }
            }
            return $v;
        }
    }
    if ($value =~ /^[-+]?(?:\d+.?\d*|\.\d+)(?:[eE][+-]?\d+)?$/) {
        # floating point literal
        my $res = eval($value);
        if ($wantfloat && $res !~ /\./) {
            $res = append_dot_zero($res);
        }
        return $res;
    }

    if (isnode($value)) {
        # only const node allowed here
        return undef unless $value->[TYPE] == CONST;
        # constants may contain an expression which
        # max contain other constants
        my $t = root_type($value->[SUBORDINATES][0]);
        $wantfloat = ($t >= FLOAT && $t <= LONGDOUBLE);
        my $rhs_ref = $value->[SUBORDINATES][1];

        my $expr = "";
        foreach my $token (@$rhs_ref) {
            if ($token =~ /^[a-z]/i) {
                # hex value or constant
                my $v = get_numeric($tree, $token, $value->[SCOPEREF], $wantfloat);
                if (defined $v) {