view release on metacpan or  search on metacpan

lib/Lab/Data/Analysis/WaveRunner.pm  view on Meta::CPAN

        $len = 8;
        my (@long) = unpack( '(LL)' . $ord, substr( $wdata, $p, $len ) );
        @long = reverse(@long) if $ord eq '<';

        #	print "ord: $ord\n";
        #	printf("Double in: MSB 0x%08x LSB %08x\n",@long);
        $a->{VALUE} = _double(@long);
    }
    elsif ( $a->{TYPE} eq 'time_stamp' ) {
        $len = 16;
        my ( $s1, $s2, $m, $h, $d, $mo, $y, $un )
            = unpack( '(LLccccss)' . $ord, substr( $wdata, $p, $len ) );
        ( $s1, $s2 ) = reverse( $s1, $s2 ) if $ord eq '<';
        my $sec = _double( $s1, $s2 );
        my $sstr = sprintf( '%.12f', $sec );
        $sstr = '0' . $sstr if $sec < 10;
        $a->{VALUE} = sprintf(
            '%04d-%02d-%02d %02d:%02d:%s',
            $y, $mo, $d, $h, $m, $sstr
        );
    }
    elsif ( $a->{TYPE} eq 'unit_definition' ) {
        $len = 48;
        $a->{VALUE} = _trimNul( substr( $wdata, $p, $len ) );
    }
    elsif ( $a->{TYPE} eq 'enum' ) {
        $len = 2;
        my $ne = sprintf(
            '%d',
            unpack( 'S' . $ord, substr( $wdata, $p, $len ) )
        );
        $a->{VALUE} = $a->{ENUM}->{$ne};
    }
    elsif ( $a->{TYPE} eq 'text' ) {
        $len = length($wdata);
        $a->{VALUE} = _trimNul( substr( $wdata, $p ) );
    }
    else {
        carp( "unknown waveform field type: " . $a->{TYPE} );
        return undef;
    }
    $a->{LENGTH} = $len;
    return $a;
}

# IEEE754 single precision  (binary32): assumes MSB data ('>')
sub _float {
    my $str = shift;
    my $s   = ( $str >> 31 ) & 0x0001;
    my $e   = ( $str >> 23 ) & 0x00FF;
    my $f   = $str & 0x007FFFFF;
    my $w   = ( 2**( $e - 127 ) ) * ( 1 + ( $f / 0x00800000 ) );
    $w = -$w if $s;
    return $w;
}

sub double_from_hex { unpack 'd', scalar reverse pack 'H*', $_[0] }

use constant POS_INF => double_from_hex '7FF0000000000000';
use constant NEG_INF => double_from_hex 'FFF0000000000000';
use constant NaN     => double_from_hex '7FF8000000000000';

sub _double    # assumes MSB data input
{
    #    my ($bytes) = @_;
    #    my ($bottom, $top) = unpack ("LL", $bytes);
    my ( $top, $bottom ) = @_;

    # Reference:
    # http://en.wikipedia.org/wiki/Double_precision_floating-point_format

    # Eight zero bytes represents 0.0.
    if ( $bottom == 0 ) {
        if ( $top == 0 ) {
            return 0;
        }
        elsif ( $top == 0x80000000 ) {
            return -0;
        }
        elsif ( $top == 0x7ff00000 ) {
            return POS_INF;
        }
        elsif ( $top == 0xfff00000 ) {
            return NEG_INF;
        }
    }
    elsif ( $top == 0x7ff00000 ) {
        return NaN;
    }
    my $sign = $top >> 31;

    #    print "sgn $sign\n";
    my $exponent = ( ( $top >> 20 ) & 0x7FF ) - 1023;

    #    print "e  = $exponent\n";
    my $e = ( $top >> 20 ) & 0x7FF;
    my $t = $top & 0xFFFFF;

    #    printf ("--> !%011b%020b \n--> %032b\n", $e, $t, $top);
    my $mantissa = ( $bottom + ( $t * ( 2**32 ) ) ) / 2**52 + 1;

    #    print "mant: $mantissa\n";
    my $double = (-1)**$sign * 2**$exponent * $mantissa;

    #    print "double result: $double\n";
    return $double;
}

# IEEE754 double precision (binary64)
#sub _Xdouble {
#    my $str = shift;
#    my $s = ($str >> 63) & 0x1;
#    my $e = ($str >> 52) & 0x7FF;
#    my $f = $str & 0x000FFFFFFFFFFFFF  ;
#    my $w = (2**($e-1023))*(1+$f/0x0010000000000000);
#    $w = -$w if $s;
#    return $w;
#}

sub _interpolate {
    my $h = shift;    # hash pointer to {CHAN}->{$ch}
    if ( ref($h) ne 'HASH' ) {
        carp("bad hash pointer for wfd interpolation");
        return undef;
    }
    my $x = shift;

    return undef if $x < $h->{XMIN} || $x > $h->{XMAX};

    my $nx  = ( $x - $h->{XMIN} ) / $h->{DX};
    my $nx0 = int($nx);
    my ( $y0, $y1, $ry0, $ry1 );
    if ( exists( $h->{Y} ) ) {
        $y0 = $h->{Y}->[$nx0];
        $y1 = $h->{Y}->[ $nx0 + 1 ];
        return $y0 + ( $y1 - $y0 ) * ( $nx - $nx0 );
    }
    else {
        $y0  = $h->{Y0}->[$nx0];
        $y1  = $h->{Y0}->[ $nx0 + 1 ];
        $ry0 = ( $y1 - $y0 ) * ( $nx - $nx0 );

        $y0  = $h->{Y1}->[$nx0];
        $y1  = $h->{Y1}->[ $nx0 + 1 ];
        $ry1 = ( $y1 - $y0 ) * ( $nx - $nx0 );
        return ( $ry0, $ry1 );
    }
}