samba-mirror/source4/build/pidl/util.pm

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

#####################################################################
# load a data structure from a file (as saved with SaveStructure)
sub LoadStructure($)
{
	my $f = shift;
	my $contents = FileLoad($f);
	defined $contents || return undef;
	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) { 
		    $v->[$i] = undef; 
		    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";
}

#####################################################################
# a dumper wrapper to prevent dependence on the Data::Dumper module
# unless we actually need it
sub MyDumper($)
{
	require Data::Dumper;
	my $s = shift;
	return Data::Dumper::Dumper($s);
}

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

#####################################################################
# find an interface in an array of interfaces
sub get_interface($$)
{
	my($if) = shift;
	my($n) = shift;

	foreach(@{$if}) {
		if($_->{NAME} eq $n) { return $_; }
	}
	
	return 0;
}

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

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

	return $e->{PROPERTIES}->{$p};
}


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

    if ($type =~ /^u?int\d+/) {
	    return 1;
    }
    if ($type =~ /char|short|long|NTTIME|
	time_t|error_status_t|boolean32|unsigned32|
	HYPER_T|wchar_t|DATA_BLOB/x) {
	    return 1;
    }

    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 4, if ($type eq "time_t");
    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 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 ($e->{TYPE} =~ "string") {
		return "";
	}

	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} =~ "string") {
		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;
}

1;