use a precompiled grammer in pidl. This speeds up pidl by about a

[Samba/gebeck_regimport.git] / source / build / pidl / util.pm

###################################################
# utility functions to support pidl
# Copyright tridge@samba.org 2000
# released under the GNU GPL
package util;

use Data::Dumper;

#####################################################################
# load a data structure from a file (as saved with SaveStructure)
sub LoadStructure($)
{
        my $f = shift;
        my $contents = FileLoad($f);
        return eval "$contents";
}

use strict;

#####################################################################
# flatten an array of arrays into a single array
sub FlattenArray2($) 
{ 
    my $a = shift;
    my @b;
    for my $d (@{$a}) {
        for my $d1 (@{$d}) {
            push(@b, $d1);
        }
    }
    return \@b;
}

#####################################################################
# flatten an array of arrays into a single array
sub FlattenArray($) 
{ 
    my $a = shift;
    my @b;
    for my $d (@{$a}) {
        for my $d1 (@{$d}) {
            push(@b, $d1);
        }
    }
    return \@b;
}

#####################################################################
# flatten an array of hashes into a single hash
sub FlattenHash($) 
{ 
    my $a = shift;
    my %b;
    for my $d (@{$a}) {
        for my $k (keys %{$d}) {
            $b{$k} = $d->{$k};
        }
    }
    return \%b;
}


#####################################################################
# traverse a perl data structure removing any empty arrays or
# hashes and any hash elements that map to undef
sub CleanData($)
{
    sub CleanData($);
    my($v) = shift;
    if (ref($v) eq "ARRAY") {
        foreach my $i (0 .. $#{$v}) {
            CleanData($v->[$i]);
            if (ref($v->[$i]) eq "ARRAY" && $#{$v->[$i]}==-1) { delete($v->[$i]); next; }
        }
        # this removes any undefined elements from the array
        @{$v} = grep { defined $_ } @{$v};
    } elsif (ref($v) eq "HASH") {
        foreach my $x (keys %{$v}) {
            CleanData($v->{$x});
            if (!defined $v->{$x}) { delete($v->{$x}); next; }
            if (ref($v->{$x}) eq "ARRAY" && $#{$v->{$x}}==-1) { delete($v->{$x}); next; }
        }
    }
}


#####################################################################
# return the modification time of a file
sub FileModtime($)
{
    my($filename) = shift;
    return (stat($filename))[9];
}


#####################################################################
# read a file into a string
sub FileLoad($)
{
    my($filename) = shift;
    local(*INPUTFILE);
    open(INPUTFILE, $filename) || return undef;
    my($saved_delim) = $/;
    undef $/;
    my($data) = <INPUTFILE>;
    close(INPUTFILE);
    $/ = $saved_delim;
    return $data;
}

#####################################################################
# write a string into a file
sub FileSave($$)
{
    my($filename) = shift;
    my($v) = shift;
    local(*FILE);
    open(FILE, ">$filename") || die "can't open $filename";    
    print FILE $v;
    close(FILE);
}

#####################################################################
# return a filename with a changed extension
sub ChangeExtension($$)
{
    my($fname) = shift;
    my($ext) = shift;
    if ($fname =~ /^(.*)\.(.*?)$/) {
        return "$1.$ext";
    }
    return "$fname.$ext";
}

#####################################################################
# save a data structure into a file
sub SaveStructure($$)
{
    my($filename) = shift;
    my($v) = shift;
    FileSave($filename, Dumper($v));
}

#####################################################################
# see if a pidl property list contains a give property
sub has_property($$)
{
        my($e) = shift;
        my($p) = shift;

        if (!defined $e->{PROPERTIES}) {
                return;
        }

        my($props) = $e->{PROPERTIES};

        foreach my $d (@{$props}) {
                if (ref($d) ne "HASH") {
                        if ($d eq $p) {
                                return 1;
                        }
                } else {
                        foreach my $k (keys %{$d}) {
                                if ($k eq $p) {
                                        return $d->{$k};
                                }
                        }
                }
        }

    return undef;
}


sub is_scalar_type($)
{
    my($type) = shift;

    return 1, if ($type eq "uint32");
    return 1, if ($type eq "long");
    return 1, if ($type eq "short");
    return 1, if ($type eq "char");
    return 1, if ($type eq "uint8");
    return 1, if ($type eq "uint16");
    return 1, if ($type eq "NTTIME");
    return 1, if ($type eq "HYPER_T");
    return 1, if ($type eq "wchar_t");
    return 1, if ($type eq "DATA_BLOB");

    return 0;
}

# return the NDR alignment for a type
sub type_align($)
{
    my($e) = shift;
    my $type = $e->{TYPE};

    if (need_wire_pointer($e)) {
            return 4;
    }

    return 4, if ($type eq "uint32");
    return 4, if ($type eq "long");
    return 2, if ($type eq "short");
    return 1, if ($type eq "char");
    return 1, if ($type eq "uint8");
    return 2, if ($type eq "uint16");
    return 4, if ($type eq "NTTIME");
    return 8, if ($type eq "HYPER_T");
    return 2, if ($type eq "wchar_t");
    return 4, if ($type eq "DATA_BLOB");

    # it must be an external type - all we can do is guess 
    return 4;
}

# this is used to determine if the ndr push/pull functions will need
# a ndr_flags field to split by buffers/scalars
sub is_builtin_type($)
{
    my($type) = shift;

    return 1, if (is_scalar_type($type));
    return 1, if ($type =~ "unistr.*");
    return 1, if ($type eq "policy_handle");

    return 0;
}

# determine if an element needs a reference pointer on the wire
# in its NDR representation
sub need_wire_pointer($)
{
        my $e = shift;
        if ($e->{POINTERS} && 
            !has_property($e, "ref")) {
                return $e->{POINTERS};
        }
        return undef;
}

# determine if an element is a pass-by-reference structure
sub is_ref_struct($)
{
        my $e = shift;
        if (!is_scalar_type($e->{TYPE}) &&
            has_property($e, "ref")) {
                return 1;
        }
        return 0;
}

# determine if an element is a pure scalar. pure scalars do not
# have a "buffers" section in NDR
sub is_pure_scalar($)
{
        my $e = shift;
        if (has_property($e, "ref")) {
                return 1;
        }
        if (is_scalar_type($e->{TYPE}) && 
            !$e->{POINTERS} && 
            !array_size($e)) {
                return 1;
        }
        return 0;
}

# determine the array size (size_is() or ARRAY_LEN)
sub array_size($)
{
        my $e = shift;
        my $size = has_property($e, "size_is");
        if ($size) {
                return $size;
        }
        $size = $e->{ARRAY_LEN};
        if ($size) {
                return $size;
        }
        return undef;
}

# see if a variable needs to be allocated by the NDR subsystem on pull
sub need_alloc($)
{
        my $e = shift;

        if (has_property($e, "ref")) {
                return 0;
        }

        if ($e->{POINTERS} || array_size($e)) {
                return 1;
        }

        return 0;
}

# determine the C prefix used to refer to a variable when passing to a push
# function. This will be '*' for pointers to scalar types, '' for scalar
# types and normal pointers and '&' for pass-by-reference structures
sub c_push_prefix($)
{
        my $e = shift;
        if (is_scalar_type($e->{TYPE}) &&
            $e->{POINTERS}) {
                return "*";
        }
        if (!is_scalar_type($e->{TYPE}) &&
            !$e->{POINTERS} &&
            !array_size($e)) {
                return "&";
        }
        return "";
}


# determine the C prefix used to refer to a variable when passing to a pull
# return '&' or ''
sub c_pull_prefix($)
{
        my $e = shift;

        if (!$e->{POINTERS} && !array_size($e)) {
                return "&";
        }

        if ($e->{TYPE} =~ "unistr.*" ||
            $e->{TYPE} =~ "nstring.*" ||
            $e->{TYPE} =~ "lstring.*") {
                return "&";
        }

        return "";
}

# determine if an element has a direct buffers component
sub has_direct_buffers($)
{
        my $e = shift;
        if ($e->{POINTERS} || array_size($e)) {
                return 1;
        }
        return 0;
}

# return 1 if the string is a C constant
sub is_constant($)
{
        my $s = shift;
        if ($s =~ /^\d/) {
                return 1;
        }
        return 0;
}

# return 1 if this is a fixed array
sub is_fixed_array($)
{
        my $e = shift;
        my $len = $e->{"ARRAY_LEN"};
        if (defined $len && is_constant($len)) {
                return 1;
        }
        return 0;
}

# return 1 if this is a inline array
sub is_inline_array($)
{
        my $e = shift;
        my $len = $e->{"ARRAY_LEN"};
        if (is_fixed_array($e) ||
            defined $len && $len ne "*") {
                return 1;
        }
        return 0;
}

sub dump($)
{
        print Dumper shift;
}

1;