File Coverage

blib/lib/Astro/UTDF.pm

Criterion	Covered	Total	%
statement	277	279	99.2
branch	102	116	87.9
condition	15	21	71.4
subroutine	61	61	100.0
pod	37	37	100.0
total	492	514	95.7

package Astro::UTDF;

use 5.006002;

use strict;
use warnings;

use Carp;
use IO::File ();
use POSIX qw{ floor };
use Scalar::Util qw{ blessed openhandle };
use Time::Local;

use constant FULL_CIRCLE => 4294967296;	# 2 ** 32;
use constant PI => atan2( 0, -1 );
use constant TWO_PI => 2 * PI;
use constant SPEED_OF_LIGHT => 299792.458;	# Km/sec, per U.S. NIST

use constant ARRAY_REF	=> ref [];
use constant CODE_REF	=> ref sub {};

our $VERSION = '0.011_01';

sub new {
    my $class = shift;
    unshift @_, ref $class || $class;
    goto &clone;
}

sub azimuth {
    splice @_, 1, 0, azimuth => TWO_PI;
    goto &_bash_angle;
}

sub clone {
    my ( $self, @args ) = @_;
    my ( $class, $clone );
    if ( $class = ref $self ) {
	$clone = {};
	while ( my ( $name, $value ) = each %{ $self } ) {
	    $clone->{$name} = $value;
	}
    } else {
	$clone = { _static() };
	$class = $self;
    }
    bless $clone, $class;
    while ( @args ) {
	my ( $name, $value ) = splice @args, 0, 2;
	my $code = $clone->can( $name )
	    or croak "Method $name() not found";
	$code->( $clone, $value );
    }
    return $clone;
}

sub data_interval {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $interval = $args[0];
	if ( $interval <= 0 ) {
	    croak "Negative data interval invalid";
	} elsif ( $interval < 1 ) {
	    $interval = 1 / $interval;
	    $interval = ( ~ $interval & 0x07ff ) + 1;
	}
	$self->{tracker_type_and_data_rate} &= ~ 0x7ff;
	$self->{tracker_type_and_data_rate} |= $interval & 0x07ff;
	return $self;
    } else {
	my $interval = $self->{tracker_type_and_data_rate} & 0x07ff;
	$interval & 0x0400 or return $interval;
	$interval = ( ~ $interval & 0x07ff ) + 1;
	return 1 / $interval;
    }
}

{

    my @antenna_diameter = (
	'less than 1 meter',
	 '3.9 meters',
	 '4.3 meters',
	 '9 meters',
	 '12 meters',
	 '26 meters',
	 'TDRSS ground antenna',
	 '6 meters',
	 '7.3 meters',
	 '8 meters',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
    );
    my @antenna_geometry = (
	'az-el',
	'X-Y (+X south)',
	'X-Y (+X east)',
	'RA-DEC',
	'HR-DEC',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
	 'unused',
    );

    my $hexify = sub {
	my ( $self, $method ) = @_;
	return unpack 'H*', $self->$method();
    };

    my %decoder = (
	data_validity => '0x%02x',
	frequency_band => [
	    'unspecified',
	    'VHF',
	    'UHF',
	    'S-band',
	    'C-band',
	    'X-band',
	    'Ku-band',
	    'visible',
	    'S-band uplink/Ku-band downlink',
	    'unknown code 9',
	    'unknown code 10',
	    'unknown code 11',
	    'unknown code 12',
	    'unknown code 13',
	    'unknown code 14',
	    'unknown code 15',
	],
	frequency_band_and_transmission_type => '0x%02x',
	front => $hexify,
	measurement_time => sub {
	    # Note that perldoc -f localtime says that the string
	    # returned in scalar context is _not_ locale-dependant.
	    return scalar gmtime $_[0]->measurement_time();
	},
	mode => '0x%04x',
	raw_record => $hexify,
	rear => $hexify,
	receive_antenna_diameter_code => \@antenna_diameter,
	receive_antenna_geometry_code => \@antenna_geometry,
	tdrss_only => $hexify,
	tracking_mode => [
	    'autotrack',
	    'program track',
	    'manual',
	    'slaved',
	],
	transmission_type => [
	    'test',
	    'unused',
	    'simulated',
	    'resubmit',
	    'RT (real time)',
	    'PB (playback)',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	    'unused',
	],
	transmit_antenna_diameter_code => \@antenna_diameter,
	transmit_antenna_geometry_code => \@antenna_geometry,
    );

    sub decode {
	my ( $self, $method, @args ) = @_;
	my $dcdr = $decoder{$method}
	    or return $self->$method( @args );
	my $type = ref $dcdr
	    or return sprintf $dcdr, $self->$method( @args );
	ARRAY_REF eq $type
	    and return $dcdr->[ $self->$method( @args ) ];
	CODE_REF eq $type
	    and return $dcdr->( $self, $method, @args );
	confess "Programming error -- decoder for $method is $type";
    }
}

sub doppler_count {
    splice @_, 1, 0, doppler_count => 1, 'is_doppler_valid';
    goto &_bash_6_bytes;
}

sub doppler_shift {
    my ( $self, @args ) = @_;
    @args and croak "doppler_shift() may not be used as a mutator";
    # Note that this can never be a mutator, because it uses data from
    # more than one record.
    defined( my $prior = $self->prior_record() )
	# If I simply returned as PBP would have me do, this method
	# would behave differently in list context depending on whether
	# prior_record() returned a defined value.
	or return undef;	## no critic (ProhibitExplicitReturnUndef)
    $self->enforce_validity()
	and not ( $self->is_doppler_valid() &&
	    $prior->is_doppler_valid() )
	and return undef;	## no critic (ProhibitExplicitReturnUndef)
    my $count = $self->doppler_count() - $prior->doppler_count();
    my $deltat = $self->measurement_time() - $prior->measurement_time();
    if ( $deltat < 0 ) {
	$deltat = - $deltat;
	$count = - $count;
    }
    $count < 0 and $count += 2 << 48;
    return ( $count / $deltat - 240_000_000 ) / $self->factor_M();
}

sub elevation {
    splice @_, 1, 0, elevation => PI;
    goto &_bash_angle;
}

sub enforce_validity {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->{enforce_validity} = shift @args;
	return $self;
    } else {
	return $self->{enforce_validity};
    }
}

# Return the factor K, which is documented as 240/221 for S-band or 1
# for VHF. Since we know we can't count on the frequency_band, we
# compute this ourselves, making the break at the bottom of the S band.

sub factor_K {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->{factor_K} = $args[0];
	return $self;
    } else {
	return ( defined $self->{factor_K} ? $self->{factor_K} :
	    ( $self->{factor_K} =
		$self->transmit_frequency() >= 2_000_000_000 ?
		240 / 221 : 1 ) );
    }
}

# Return the factor M, which is documented as 1000 for S-band or 100 for
# K-band. Since we know we can't count on the frequency_band, we
# compute this ourselves, making the break at the bottom of the Ku band.

sub factor_M {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->{factor_M} = $args[0];
	return $self;
    } else {
	return ( defined $self->{factor_M} ? $self->{factor_M} :
	    ( $self->{factor_M} =
		$self->transmit_frequency() >= 12_000_000_000 ?
		100 : 1000 ) );
    }
}

sub frequency_band {
    splice @_, 1, 0, frequency_band_and_transmission_type => 1;
    goto &_bash_nybble;
}

sub hex_record {
    my ( $self, @args ) = @_;
    if ( @args ) {
	return $self->raw_record( pack 'H*', $args[0] );
    } else {
	return unpack 'H*', $self->raw_record();
    }
}

sub is_angle_corrected_for_misalignment {
    splice @_, 1, 0, data_validity => 3;
    goto &_bash_bit;
}

sub is_angle_corrected_for_refraction {
    splice @_, 1, 0, data_validity => 4;
    goto &_bash_bit;
}

sub is_angle_valid {
    splice @_, 1, 0, data_validity => 2;
    goto &_bash_bit;
}

sub is_destruct_doppler {
    splice @_, 1, 0, data_validity => 6;
    goto &_bash_bit;
}

sub is_doppler_valid {
    splice @_, 1, 0, data_validity => 1;
    goto &_bash_bit;
}

sub is_range_valid {
    splice @_, 1, 0, data_validity => 0;
    goto &_bash_bit;
}

sub is_range_corrected_for_refraction {
    splice @_, 1, 0, data_validity => 5;
    goto &_bash_bit;
}

sub is_side_lobe {
    splice @_, 1, 0, data_validity => 7;
    goto &_bash_bit;
}

sub is_last_frame {
    splice @_, 1, 0, tracker_type_and_data_rate => 11;
    goto &_bash_bit;
}

sub measurement_time {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $time = floor( $args[0] );
	my $microseconds = floor( ( $args[0] - $time ) * 1_000_000 + 0.5);
	my @cald = gmtime $time;
	my $year = $cald[5] % 100;
	my $seconds = $time - timegm( 0, 0, 0, 1, 0, $cald[5] );
	return $self->year( $year )->seconds_of_year( $seconds
	    )->microseconds_of_year( $microseconds );
    } else {
	my $yr = $self->year();
	$yr < 70 and $yr += 100;
	return timegm( 0, 0, 0, 1, 0, $yr ) + $self->seconds_of_year() +
	    $self->microseconds_of_year() / 1_000_000;
    }
}

sub prior_record {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $prior = shift @args;
	defined $prior and not __PACKAGE__->_instance( $prior )
	    and croak 'Prior record must be undef or an ', __PACKAGE__,
		' object';
	$self->{prior_record} = $prior;
	return $self;
    } else {
	return $self->{prior_record};
    }
}

sub range {
    my ( $self, @args ) = @_;
    if ( @args ) {
	croak "range() may not be used as a mutator";
    } else {
	defined( my $range_delay = $self->range_delay() )
	    or return undef;	## no critic (ProhibitExplicitReturnUndef)
	return ( ( $range_delay - $self->transponder_latency() ) *
	    SPEED_OF_LIGHT / 2_000_000_000 );
    }
}

sub range_delay {
    splice @_, 1, 0, range_delay => 256, 'is_range_valid';
    goto &_bash_6_bytes;
}

sub range_rate {
    my ( $self, @args ) = @_;
    @args and croak "range_rate() may not be used as a mutator";
    # Note that this can never be a mutator because it uses
    # doppler_shift() (q.v.)
    if ( defined ( my $shift = $self->doppler_shift() ) ) {
	return (
	    - SPEED_OF_LIGHT / ( 2 * $self->transmit_frequency() *
		$self->factor_K() ) * $shift
	);
    } else {
	# If I simply returned as PBP would have me do, this method
	# would behave differently in list context depending on whether
	# doppler_shift() returned a defined value.
	return undef;	## no critic (ProhibitExplicitReturnUndef)
    }
}

{

    my $utdf_template = 'a3A2CnnNNNNNnNnnNCCCCnCCna18a3';
    my @utdf_fields = qw{
	front router year sic vid seconds_of_year
	microseconds_of_year azimuth elevation
	range_delay_hi range_delay_lo
	doppler_count_hi doppler_count_lo
	agc
	transmit_frequency
	transmit_antenna_type
	transmit_antenna_padid
	receive_antenna_type
	receive_antenna_padid
	mode
	data_validity
	frequency_band_and_transmission_type
	tracker_type_and_data_rate
	tdrss_only
	rear
    };

    sub raw_record {
	my ( $self, @args ) = @_;
	if ( @args ) {
	    my $raw_record = shift @args;
	    length $raw_record == 75
		or croak "Invalid raw record: length not 75 bytes";
	    use bytes;
	    @$self{ @utdf_fields } = unpack $utdf_template, $raw_record;
	    return $self;
	} else {
	    use bytes;
	    return pack $utdf_template, @$self{ @utdf_fields };
	}
    }

    my $static = {};
    @$static{ @utdf_fields } = ( 0 ) x scalar @utdf_fields;
    $static->{front} = pack 'H*', '0d0a01';
    $static->{router} = ' ';
    $static->{tdrss_only} = pack( 'H*', '00' ) x 18;
    $static->{rear} = pack 'H*', '040f0f';
    $static->{transponder_latency} = 0;
    bless $static, __PACKAGE__;

    sub _static {
	return wantarray ? %{ $static } : $static;
    }
}

sub receive_antenna_diameter_code {
    splice @_, 1, 0, receive_antenna_type => 1;
    goto &_bash_nybble;
}

sub receive_antenna_geometry_code {
    splice @_, 1, 0, receive_antenna_type => 0;
    goto &_bash_nybble;
}

{

    my %my_arg = map { $_ => 1 } qw{ file };

    sub slurp {
	my ( undef, @in_args ) = @_;		# Invocant unused

	@in_args % 2 and unshift @in_args, 'file';
	my ( %arg, @attrib );
	while ( @in_args ) {
	    my ( $name, $value ) = splice @in_args, 0, 2;
	    if ( $my_arg{$name} ) {
		$arg{$name} = $value;
	    } else {
		push @attrib, $name, $value;
	    }
	}
	$arg{file} or croak "File not specified";

	my $fh = $arg{file};
	my $fn;
	if ( ! openhandle( $fh ) ) {
	    $fn = $fh;
	    -e $fn or croak "$fn not found";
	    -f _ or croak "$fn not a normal file";
	    $fh = IO::File->new( $fn, '<' )
		or croak "Unable to open $fn: $!";
	}
	binmode $fh;

	my @rslt;
	my ( $buffer, $count );
	while ( $count = read $fh, $buffer, 75 ) {
	    push @rslt, __PACKAGE__->new(
		raw_record => $buffer,
		prior_record => ( @rslt ? $rslt[-1] : undef ),
		@attrib,
	    );
	}
	close $fh;
	return @rslt;
    }

}

sub tracker_type {
    splice @_, 1, 0, tracker_type_and_data_rate => 3;
    goto &_bash_nybble;
}

sub tracking_mode {
    my ( $self, @args ) = @_;
    # This would be a delegation to _bash_quarter if there were more
    # than one two-bit field.
    my $attr = 'mode';
    my $shift = 2;
    my $mask = 0x03 << $shift;
    if ( @args ) {
	$self->{$attr} &= ~ $mask;
	$self->{$attr} |= ( $args[0] & 0x03 ) << $shift;
	return $self;
    } else {
	return ( $self->{mode} & $mask ) >> $shift;
    }
}

sub transmission_type {
    splice @_, 1, 0, frequency_band_and_transmission_type => 0;
    goto &_bash_nybble;
}

sub transmit_antenna_diameter_code {
    splice @_, 1, 0, transmit_antenna_type => 1;
    goto &_bash_nybble;
}

sub transmit_antenna_geometry_code {
    splice @_, 1, 0, transmit_antenna_type => 0;
    goto &_bash_nybble;
}

sub transmit_frequency {
    my ( $self, @args ) = @_;
    if ( @args ) {
	$self->{transmit_frequency} = floor( ( $args[0] + 5 ) / 10 );
	return $self;
    } else {
	return $self->{transmit_frequency} * 10;
    }
}

# Generate all the simple accessors. These just return the value of
# the correspondingly-named attribute, which is assumed to exist.

foreach my $attribute ( qw{
    front router year sic vid seconds_of_year
    microseconds_of_year
    agc
    transmit_antenna_type
    transmit_antenna_padid
    receive_antenna_type
    receive_antenna_padid
    mode
    data_validity
    frequency_band_and_transmission_type
    tracker_type_and_data_rate
    tdrss_only
    rear

    transponder_latency
} ) {
    no strict qw{ refs };
    *$attribute = sub {
	my ( $self, @args ) = @_;
	if ( @args ) {
	    $self->{$attribute} = shift @args;
	    return $self;
	} else {
	    return $self->{$attribute};
	}
    };
}

# Generic accessor/mutator for 6 byte values. The specific
# accessor/mutator splices the constant part of the attribute name (the
# part before '_hi' or '_lo', the factor (to multiply by for the
# mutator, or divide by for the accessor), and the name of the valid-bit
# routine (or undef if none) into the argument list right after the
# object, and co-routines to this.
sub _bash_6_bytes {
    my ( $self, $attr, $factor, $validator, @args ) = @_;
    if ( @args ) {
	my $value = $factor * shift @args;
	my $value_hi = floor( $value / 65536 );
	my $value_lo = $value - $value_hi * 65536;
	$self->{ $attr . '_hi' } = $value_hi | 0;	# Force integer
	$self->{ $attr . '_lo' } = $value_lo | 0;	# Force integer
	return $self;
    } else {
	$validator
	    and $self->enforce_validity()
	    and not $self->$validator()
	    and return undef;	## no critic (ProhibitExplicitReturnUndef)
	return ( $self->{ $attr . '_hi' } * 65536 +
	    $self->{ $attr . '_lo' } ) / $factor;
    }
}

# Generic accessor/mutator for angles. The specific accessor/mutator
# splices the attribute name and the upper limit in radians onto the
# argument list after the object, and co-routines to this (or calls it
# returning whatever it returns). Note that the upper limit is used only
# to normalize the angle for the accessor; all angles are stored as
# positive fractions of a circle.
# WE ASSUME ANYTHING THAT GOES THROUGH THIS CODE IS SUBJECT TO
# is_angle_valid().
sub _bash_angle {
    my ( $self, $attr, $upper, @args ) = @_;
    if ( @args ) {
	my $angle = $args[0] / TWO_PI;
	$angle -= floor( $angle );
	$self->{$attr} = floor( $angle * FULL_CIRCLE + 0.5 );
	return $self;
    } else {
	$self->enforce_validity()
	    and not $self->is_angle_valid()
	    and return undef;	## no critic (ProhibitExplicitReturnUndef)
	my $angle = $self->{$attr} / FULL_CIRCLE * TWO_PI;
	$angle >= $upper and $angle -= TWO_PI;
	return $angle;
    }
}

# Generic accessor/mutator for single bits. The specific
# accessor/mutator splices the attribute name and the bit number into
# the argument list after the object, and co-routines to this (or calls
# it returning whatever it returns). NOTE: I would love to use vec()
# here, but that works on strings.
sub _bash_bit {
    my ( $self, $attr, $bit, @args ) = @_;
    my $mask = 0x01 << $bit;
    if ( @args ) {
	if ( $args[0] ) {
	    $self->{$attr} |= $mask;
	} else {
	    $self->{$attr} &= ~ $mask;
	}
	return $self;
    } else {
	return $self->{$attr} & $mask ? 1 : 0;
    }
}

# Generic accessor/mutator for nybbles. The specific accessor/mutator
# splices the attribute name and the nybble number into the argument
# list after the object, and co-routines to this (or calls it returning
# whatever it returns). NOTE: I would love to use vec() here, but that
# works on strings.
sub _bash_nybble {
    my ( $self, $attr, $bit, @args ) = @_;
    my $shift = 4 * $bit;
    my $mask = 0x0f << $shift;
    if ( @args ) {
	$self->{$attr} &= ~ $mask;
	$self->{$attr} |= ( $args[0] & 0x0f ) << $shift;
	return $self;
    } else {
	return ( $self->{$attr} & $mask ) >> $shift;
    }
}

# $class->_instance( $obj )
# returns the class name of the invocant if the argument is an instance
# of the invocant's class, or one of its subclasses. Otherwise simply
# returns. Can be called as a static method.
sub _instance {
    my ( $class, $obj ) = @_;
    ref $class
	and $class = ref $class;
    ref $obj
	or return;
    blessed( $obj )
	or return;
    $obj->isa( $class )
	or return;
    return $class;
}

1;

__END__