view release on metacpan or  search on metacpan

t/04_fixedArray.t  view on Meta::CPAN

#!/usr/local/bin/perl

# test fixed-length array features of IPC::MMA

use strict;
use warnings;
use Test::More tests => 4750;
use IPC::MMA qw(:basic :array);

our @typeNames = ("MM_ARRAY", "MM_UINT_ARRAY", "MM_INT_ARRAY", "MM_DOUBLE_ARRAY");

# removed $entries 11/5/09
our ($array, $type, $option, $var_size_bytes, $cVexp_got);
our @checkArray;
our ($ALLOC_SIZE, $ALLOCBASE, $PSIZE, $IVSIZE, $NVSIZE, $DEFENTS);
our $isrand = open (RAND, "</dev/urandom");

sub randStr {
    my $len = shift;
    my $ret = '';
    my ($r, $le);
    if ($len) {
        if ($isrand) {sysread (RAND, $ret, $len)}
        else {
            while (($le = $len - length($ret)) > 0) {
                $r = pack 'L', int(rand(0xFFFFFFFF));
                $ret .= $le >= 4 ? $r : substr($r, 0, $le);
    }   }   }
    return $ret;
}

sub randVar {
    my ($x, $len);
    if ($type == MM_INT_ARRAY) {
        return unpack('i', randStr($IVSIZE));
    } elsif ($type == MM_UINT_ARRAY) {
        return unpack('I', randStr($IVSIZE));
    } elsif ($type == MM_DOUBLE_ARRAY) {
        # eliminate NaN's that random number generation will yield
        do {$x = unpack('d', randStr($NVSIZE))} until ($x == $x);
        return $x;
    } elsif ($option==MM_CSTRING) {
        # C string mode
        $len = int(rand $var_size_bytes+1);
        $x = '';
        while ($len--) {$x .= chr(int(rand 255)+1)} # no NULs
        return $x;
    } else {
        return randStr($var_size_bytes);
}   }

sub typeName {
    return ($type > 0) ? (($option==MM_CSTRING) ? "C string <= $type" : "fixed len $type")
                       : $typeNames[-$type];
}

sub makeZero {
    if ($type < MM_ARRAY) {return 0}
    if ($option == MM_CSTRING) {return ''}
    return (chr(0))x$var_size_bytes;
}

# check a returned value
# this needs to use the right kind of equality operator
#   (numeric == or string eq) because perl 5.6 has problems
#   with converting large UVs to strings
sub checkVal {
    my ($val, $ckval) = @_;
    my $ret = $type < 0 ? $val == $ckval
                        : $val eq $ckval;
    my $form = ($type == MM_DOUBLE_ARRAY) ? 'g'
                                          : ($type < 0) ? 'd'
                                                        : 's';
    $cVexp_got = $ret ? "" : sprintf(": expected %$form (len %d), got %$form (len %d)",
                                     $ckval, length($ckval), $val, length($val));
    return $ret;
}

# check the whole array
sub checkArray {
    my $testName = shift;
    my $size = mm_array_fetchsize($array);
    my $size2 = scalar @checkArray;
    is ($size, $size2,
        "$testName: size of test array and check array should match");
    if ($size2 < $size) {$size = $size2}
    for (my $i=0; $i < $size; $i++) {
        ok (checkVal(mm_array_fetch ($array, $i), $checkArray[$i]),
            "$testName: element $i$cVexp_got (type=" . typeName . ")");
}   }

# compare 2 arrays
sub compArray {
    my ($array1ref, $array2ref, $testName) = @_;
    my $size1 = scalar @$array1ref;
    my $size2 = scalar @$array2ref;
    is ($size1, $size2, "$testName: arrays should be same size");
    if ($size2 < $size1) {$size1 = $size2}
    for (my $i=0; $i <$size1; $i++) {