#!/usr/bin/perl $VERSION = 'APRS-AzEl-Simulator-Generator version-0.0'; use POSIX; use Getopt::Long qw(:config no_ignore_case); use Geo::Inverse; use Geo::Forward; use Math::Trig qw(deg2rad rad2deg); my $self_coordinates; my $self_lat, $self_lon; my $aprs_server_url; my $ax25_port; my $target_filter_re; my $aprs_mycall; my $show_az; my $show_elevation; my $show_distance; my $show_speed; my $show_altitude; my $show_all, $verbose, $show_version, $show_help; my $logfile; my $simulator_source; my $APRSParser = new APRS::Parser; my $GeoInv = Geo::Inverse->new(); my $geo_a = 6378137.0*1.01; ## Semi-major axis of WGS-84 ellipsoid my $t = 36_000; # Simulator time base.. # $self_lat, $self_lon; my $self_alt = 0.0; my $theta = 130.0; my $delta_t = 1*60; my $h_speed = 10.0; my $v_speed = 3.0; my $top_alt = 30_000; # my $obj = Geo::Inverse->new(); # default "WGS84" # my ($lat1,$lon1,$lat2,$lon2)=(38.87, -77.05, 38.95, -77.23); # my ($faz, $baz, $dist)=$obj->inverse($lat1,$lon1,$lat2,$lon2); #array context # my $dist=$obj->inverse($lat1,$lon1,$lat2,$lon2); #scalar context # print "Input Lat: $lat1 Lon: $lon1\n"; # print "Input Lat: $lat2 Lon: $lon2\n"; # print "Output Distance: $dist\n"; # print "Output Forward Azimuth: $faz\n"; # print "Output Back Azimuth: $baz\n"; my $GeoFwd = Geo::Forward->new(); # my $obj = Geo::Forward->new(); # default "WGS84" # my ($lat1,$lon1,$faz,$dist)=(38.871022, -77.055874, 62.888507083, 4565.6854); # my ($lat2,$lon2,$baz) = $obj->forward($lat1,$lon1,$faz,$dist); # print "Input Lat: $lat1 Lon: $lon1\n"; # print "Input Forward Azimuth: $faz\n"; # print "Input Distance: $dist\n"; # print "Output Lat: $lat2 Lon: $lon2\n"; # print "Output Back Azimuth: $baz\n"; select STDOUT; $| = 1; $getoptresult = GetOptions ("coordinates|c=s" => \$self_coordinates, "server|s=s" => \$aprs_server_url, "port|p=s" => \$ax25_port, "target|t=s" => \$target_filter_re, "mycall|m=s" => \$aprs_mycall, "azimuth|z" => sub { $show_az = 1; }, "elevation|e" => sub { $show_elevation = 1; }, "distance|d" => sub { $show_distance = 'km'; }, "distance-miles" => sub { $show_distance = 'miles'; }, "distance-nautical" => sub { $show_distance = 'nautical'; }, "distance-attoparsecs" => sub { $show_distance = 'apcs'; }, "speed|g" => sub { $show_speed = 'kph'; }, "speed-mps" => sub { $show_speed = 'mps'; }, "speed-mph" => sub { $show_speed = 'mph'; }, "speed-knots" => sub { $show_speed = 'kts'; }, "altitude|a" => sub { $show_altitude = 'm' }, "altitude-km" => sub { $show_altitude = 'km' }, "altitude-feet" => sub { $show_altitude = 'ft' }, "altitude-miles" => sub { $show_altitude = 'miles' }, "altitude-attoparsecs" => sub { $show_altitude = 'apcs' }, "simulator=s" => \$simulator_source, "log=s" => \$logfile, "all|l" => sub { $show_az = 1; $show_elevation = 1; $show_distance = 'km'; $show_speed = 'kph'; $show_altitude = 'm'; }, "version|V" => sub { print $VERSION."\n"; exit 0; }, "verbose|v" => \$verbose, "help|h|?" => sub { usage(""); } ); # usage(); usage("Missing mandatory --coordinates [position] parameter") if (! defined($self_coordinates)); usage("Missing mandatory --server [URL] parameter") if (! defined($aprs_server_url)); usage("Missing mandatory --mycall [callsign] parameter") if (! defined($aprs_mycall)); usage("Missing mandatory --target [filter-RE] parameter") if (! defined($target_filter_re)); if ($logfile) { open LOG, ">>", $logfile || die "Can not append to log-file: $logfile, $!"; select LOG; $| = 1; select STDOUT; $| = 1; } my %self_coordinates = (); if ($APRSParser->normalpos_to_decimal($self_coordinates, $aprs_mycall, \%self_coordinates)) { $self_lat = $self_coordinates{latitude}; $self_lon = $self_coordinates{longitude}; } else { usage("--coordinates parameter value BAD"); } #undef %self_coordinates; printf "\naprsazel: "; printf " show_az=%s show_el=%s", $show_az, $show_elevation; printf " show_dist=%s", $show_distance; printf " show_speed=%s show_alt=%s\n", $show_speed, $show_altitude; printf " mycall='%s'", $aprs_mycall; printf " self_coord='%s' server_url='%s'\n", $self_coordinates, $aprs_server_url; printf " ax25_port='%s'", $ax25_port; printf " target_re='%s'\n", $target_filter_re; printf(" Self latitude=%.7f longitude=%.7f\n", $self_lat, $self_lon); printf "\n"; # Going up at steady h/v_speed rate my $i, $a; $a = $APRSParser->make_timestamp( $t, 1 ); while ($self_alt < $top_alt) { printf "%d\t",$t; # ... print APRS frame.. $a = $APRSParser->make_timestamp( $t, 1 ); $a .= $APRSParser->make_position( $self_lat, $self_lon, $h_speed * 3.6, # m/s -> km/h $theta, # movement azimuth, degrees $self_alt, # meters '/O', 0, 0 ); printf "%s>S1MULA:/%s", $aprs_mycall, $a; #printf "%8.5f N %8.5f E /A=%06d", $self_lat, $self_lon, $self_alt / 0.3048; printf "\n"; $t += $delta_t; my $baz; ($self_lat, $self_lon, $baz) = # Degrees,Degrees,Degrees $GeoFwd->forward( $self_lat, $self_lon, # Degrees,Degrees $theta, $delta_t * $h_speed ); # Degrees,Meters $self_alt += $delta_t * $v_speed; } # Hang up there for N position samples for ($i = 0; $i < 1; ++$i) { printf "%d\t",$t; # ... print APRS frame.. $a = $APRSParser->make_timestamp( $t, 1 ); $a .= $APRSParser->make_position( $self_lat, $self_lon, $h_speed * 3.6, # m/s -> km/h $theta, # movement azimuth, degrees $self_alt, # meters '/O', 0, 0, "" ); printf "%s>S1MULA:/%s", $aprs_mycall, $a; #printf "%8.5fN%8.5fE/A=%06d", $self_lat, $self_lon, $self_alt / 0.3048; printf "\n"; $t += $delta_t; my $baz; ($self_lat, $self_lon, $baz) = # Degrees,Degrees,Degrees $GeoFwd->forward( $self_lat, $self_lon, # Degrees,Degrees $theta, $delta_t * $h_speed ); # Degrees,Meters # $self_alt += $delta_t * $v_speed; } # Going down at steady h/v-speed rate.. while ($self_alt > 0) { printf "%d\t",$t; # ... print APRS frame.. $a = $APRSParser->make_timestamp( $t, 1 ); $a .= $APRSParser->make_position( $self_lat, $self_lon, $h_speed * 3.6, # m/s -> km/h $theta, # movement azimuth, degrees $self_alt, # meters '/O', 0, 0, "" ); printf "%s>S1MULA:/%s", $aprs_mycall, $a; # printf "%8.5fN%8.5fE/A=%06d", $self_lat, $self_lon, $self_alt * 0.3048; printf "\n"; $t += $delta_t; my $baz; ($self_lat, $self_lon, $baz) = $GeoFwd->forward( $self_lat, $self_lon, $theta, $delta_t * $h_speed ); $self_alt -= $delta_t * $v_speed; } exit 0; # ------------------------------------------------------------------------- sub usage { my ($fault) = @_; print ' aprsazel-simulator-generator -m mycall -c my/coords -s server_url -t target_filter_re [options..] '; printf "\n >>> %s\n", $fault if ($fault); print ' A utility to track azimuth/elevation/distance/speed/altitude of a moving APRS target. It prints the following information out separated by tabs: [timestamp][server/port][target call][azimuth][elevation][distance][speed][altitude] -c --coordinates [coord] WGS-84 coordinates of the observer in APRS format Like: "6044.04N/02612.93E/" (ddmm.mmN/ddmm.mmE/) (Example is for Viestikallio.) -s --server [name] APRS Internet Server and port, e.g. "aprs.sral.fi:2345", [[TODO: can also have an optional name, e.g. "aprs.sral.fi:2345 sral"]] -p --port [string] AX.25 port, e.g. "ax0" or "2m" -m --mycall [string] My callsign for connecting to APRS-IS server -t --target [re] Station to be followed, can be multiple stations, a perl-re is used for matching --log [file] Log all received APRS packets on [file] -z --azimuth Show azimuth of the target (degrees) -e --elevation Show elevation of the target (degrees) -d --distance Show distance of the target (kilometres) --distance-miles Show distance of the target in statute miles --distance-nautical Show distance of the target in nautical miles --distance-attoparsecs Show distance of the target in attoparsecs -g --speed Show speed of the target (kilometres per hour) --speed-mps Show speed of the target in meters per second --speed-mph Show speed of the target in miles per hour --speed-knots Show speed of the target in knots --speed-furlongs Show speed of the target in furlongs per fortnight -a --altitude Show altitude of the target (metres) --altitude-feet Show altitude of the target in feet --altitude-miles Show altitude of the target in miles --altitude-attoparsecs Show altitude of the target in attoparsecs -l --all Print all above parameters with default units (-zedga) -v --verbose Print some debug information -V --version Print aprsazel version --simulator [filename] Reads lines of timestamp TAB APRS-frame.. -h --help Prints this page '; exit 64; } # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- package APRS::IS; use 5.006; use strict; use warnings; use IO::Socket::INET; use IO::Select; sub aprspass { my ($a, $h) = (0, 0); map($h ^= ord(uc) << ($a^=8), pop =~ m/./g); return ($h ^ 29666); } sub new { my $that = shift; my $class = ref($that) || $that; # my %atts = @_; my ($url, $mycall, $target_filter_re) = @_; # Just one arg: APRS-IS URL (host:port) # Register the callers package. my $self = { caller_pkg => (caller)[0] }; bless ($self, $class); # parse attrs $self->{sock} = IO::Socket::INET->new($url); if (!defined($self->{sock})) { die(__PACKAGE__.": APRS::IS->new(".$url.") failure: ".$!."\n"); } $self->{select} = IO::Select->new( $self->{sock} ); $self->{aprsmycall} = uc( $mycall ); $self->{aprspass} = aprspass( $mycall ); $self->{filterre} = $target_filter_re; # printf ( "APRS::IS->new() mycall='%s' aprspass=%d filterre='%s'\n", # $self->{aprsmycall}, $self->{aprspass}, $self->{filterre} ); ## ## * Need to send on initial connect the following logon line: ## user callsign pass passcode vers appname versionnum rest_of_line ## ## callsign = login callsign-SSID ## passcode = login passcode per APRS-IS algorithm, -1 = read-only ## appname = application name (1 word) ## versionnum = application version number (no spaces) ## rest_of_line = server command if connecting to a port that supports commands (see Server Commands) ## ## (appname and versionnum should not exceed 15 characters) ## ## ## * Need to recognize both TCPIP and TCPXX as TCP/IP stations ## * Need to provide a means to perform the user validation. This can either be a user entered password, ## or a client program can automatically figure out the password given the callsign. ## If the later is used, it is the client programmer's responsibility to be certain that non-amateurs ## are not given registrations that can validate themselves in APRS-IS. ## * Probably a good idea to perform some feedback about the limitations of TCPIP without a registration number. ## $self->{sock}->blocking(1); $self->{sock}->printf( "user %s pass %s vers %s\n", $self->{aprsmycall}, $self->{aprspass}, # -- but we are read-only ! $main::VERSION ); $self->{sock}->flush; $self->{sock}->blocking(1); my $discard = $self->getline(); $self; } # ------------------------------------------------------------------------- # Get a line, or wait 1 sec sub getline { my $self = shift; my @ready; if (@ready = $self->{select}->can_read(1)) { # Wait at most 1.0 seconds # We have only one socket... return $self->{sock}->getline; } undef; } # ------------------------------------------------------------------------- # ------------------------------------------------------------------------- package APRS::Parser; ## NOT as separate package! use 5.006; use strict; use warnings; use Date::Calc qw(check_date Today Date_to_Time Add_Delta_YM Mktime); use Math::Trig; #require Exporter; #use AutoLoader qw(AUTOLOAD); #our @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use APRS::Parser ':all'; # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK # will save memory. ##our %EXPORT_TAGS = ( ## 'all' => [ qw( ## ## ) ], ##); # our @EXPORT_OK = ( # ## @{ $EXPORT_TAGS{'all'} }, # '&parseaprs', # '&kiss_to_tnc2', # '&tnc2_to_kiss', # '&aprs_duplicate_parts', # '&count_digihops', # '&check_ax25_call', # '&distance', # '&direction', # '&make_object', # '&make_timestamp', # '&make_position', # '&gettime', # '&mice_mbits_to_message', # ); ##our @EXPORT = qw( ## ##); our $VERSION = '0.01'; # Preloaded methods go here. # message bit types for mic-e # from left to right, bits a, b and c # standard one bit is 1, custom one bit is 2 our %mice_messagetypes = ( "111" => "off duty", "222" => "custom 0", "110" => "en route", "220" => "custom 1", "101" => "in service", "202" => "custom 2", "100" => "returning", "200" => "custom 3", "011" => "committed", "022" => "custom 4", "010" => "special", "020" => "custom 5", "001" => "priority", "002" => "custom 6", "000" => "emergency", ); # Convert mic-e message bits (three numbers 0-2) to a textual message. # Returns the message on success, undef on failure. sub mice_mbits_to_message() { my $self = shift; my $bits = shift @_; if ($bits =~ /^\s*([0-2]{3})\s*$/o) { $bits = $1; if (defined($mice_messagetypes{$bits})) { return $mice_messagetypes{$bits}; } else { return undef; } } else { return undef; } } # A list of mappings from GPSxyz (or SPCxyz) # to APRS symbols. Overlay characters (z) are # not handled here my %dstsymbol = ( "BB" => q(/!), "BC" => q(/"), "BD" => q(/#), "BE" => q(/$), "BF" => q(/%), "BG" => q(/&), "BH" => q(/'), "BI" => q!/(!, "BJ" => q!/)!, "BK" => q(/*), "BL" => q(/+), "BM" => q(/,), "BN" => q(/-), "BO" => q(/.), "BP" => q(//), "P0" => q(/0), "P1" => q(/1), "P2" => q(/2), "P3" => q(/3), "P4" => q(/4), "P5" => q(/5), "P6" => q(/6), "P7" => q(/7), "P8" => q(/8), "P9" => q(/9), "MR" => q(/:), "MS" => q(/;), "MT" => q(/<), "MU" => q(/=), "MV" => q(/>), "MW" => q(/?), "MX" => q(/@), "PA" => q(/A), "PB" => q(/B), "PC" => q(/C), "PD" => q(/D), "PE" => q(/E), "PF" => q(/F), "PG" => q(/G), "PH" => q(/H), "PI" => q(/I), "PJ" => q(/J), "PK" => q(/K), "PL" => q(/L), "PM" => q(/M), "PN" => q(/N), "PO" => q(/O), "PP" => q(/P), "PQ" => q(/Q), "PR" => q(/R), "PS" => q(/S), "PT" => q(/T), "PU" => q(/U), "PV" => q(/V), "PW" => q(/W), "PX" => q(/X), "PY" => q(/Y), "PZ" => q(/Z), "HS" => q(/[), "HT" => q(/\\), "HU" => q(/]), "HV" => q(/^), "HW" => q(/_), "HX" => q(/`), "LA" => q(/a), "LB" => q(/b), "LC" => q(/c), "LD" => q(/d), "LE" => q(/e), "LF" => q(/f), "LG" => q(/g), "LH" => q(/h), "LI" => q(/i), "LJ" => q(/j), "LK" => q(/k), "LL" => q(/l), "LM" => q(/m), "LN" => q(/n), "LO" => q(/o), "LP" => q(/p), "LQ" => q(/q), "LR" => q(/r), "LS" => q(/s), "LT" => q(/t), "LU" => q(/u), "LV" => q(/v), "LW" => q(/w), "LX" => q(/x), "LY" => q(/y), "LZ" => q(/z), "J1" => q(/{), "J2" => q(/|), "J3" => q(/}), "J4" => q(/~), "OB" => q(\\!), "OC" => q(\\"), "OD" => q(\\#), "OE" => q(\\$), "OF" => q(\\%), "OG" => q(\\&), "OH" => q(\\'), "OI" => q!\\(!, "OJ" => q!\\)!, "OK" => q(\\*), "OL" => q(\\+), "OM" => q(\\,), "ON" => q(\\-), "OO" => q(\\.), "OP" => q(\\/), "A0" => q(\\0), "A1" => q(\\1), "A2" => q(\\2), "A3" => q(\\3), "A4" => q(\\4), "A5" => q(\\5), "A6" => q(\\6), "A7" => q(\\7), "A8" => q(\\8), "A9" => q(\\9), "NR" => q(\\:), "NS" => q(\\;), "NT" => q(\\<), "NU" => q(\\=), "NV" => q(\\>), "NW" => q(\\?), "NX" => q(\\@), "AA" => q(\\A), "AB" => q(\\B), "AC" => q(\\C), "AD" => q(\\D), "AE" => q(\\E), "AF" => q(\\F), "AG" => q(\\G), "AH" => q(\\H), "AI" => q(\\I), "AJ" => q(\\J), "AK" => q(\\K), "AL" => q(\\L), "AM" => q(\\M), "AN" => q(\\N), "AO" => q(\\O), "AP" => q(\\P), "AQ" => q(\\Q), "AR" => q(\\R), "AS" => q(\\S), "AT" => q(\\T), "AU" => q(\\U), "AV" => q(\\V), "AW" => q(\\W), "AX" => q(\\X), "AY" => q(\\Y), "AZ" => q(\\Z), "DS" => q(\\[), "DT" => q(\\\\), "DU" => q(\\]), "DV" => q(\\^), "DW" => q(\\_), "DX" => q(\\`), "SA" => q(\\a), "SB" => q(\\b), "SC" => q(\\c), "SD" => q(\\d), "SE" => q(\\e), "SF" => q(\\f), "SG" => q(\\g), "SH" => q(\\h), "SI" => q(\\i), "SJ" => q(\\j), "SK" => q(\\k), "SL" => q(\\l), "SM" => q(\\m), "SN" => q(\\n), "SO" => q(\\o), "SP" => q(\\p), "SQ" => q(\\q), "SR" => q(\\r), "SS" => q(\\s), "ST" => q(\\t), "SU" => q(\\u), "SV" => q(\\v), "SW" => q(\\w), "SX" => q(\\x), "SY" => q(\\y), "SZ" => q(\\z), "Q1" => q(\\{), "Q2" => q(\\|), "Q3" => q(\\}), "Q4" => q(\\~), ); # set debugging on or off, default off sub debug() { my $self = shift; my $dval = shift @_; if ($dval == 1) { $self->{debug} = 1; } else { $self->{debug} = 0; } } # Make self-referencing data entity.. sub new { my $that = shift; my $class = ref($that) || $that; ## non-zero attrs # Register the callers package. my $self = { caller_pkg => (caller)[0] }; bless ($self, $class); # no debugging by default $self->{debug} = 0; $self; } # Return a human readable timestamp in UTC. # If no parameter is given, use current time, # else use the unix timestamp given in the parameter. sub gettime { my $self = shift; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday); if (scalar(@_) >= 1) { my $tstamp = shift @_; ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($tstamp); } else { ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(); } my $timestring = sprintf("%d-%02d-%02d %02d:%02d:%02d UTC", $year + 1900, $mon + 1, $mday, $hour, $min, $sec); return $timestring; } # # Return the distance in kilometers between two locations # # given in degrees. Arguments are given in order as # # lon0, lat0, lon1, lat1, east and north positive. # # The calculation uses the great circle distance, it # # is not too exact, but good enough for us. # sub distance($$$$$) { # my $lon0 = shift @_; # my $lat0 = shift @_; # my $lon1 = shift @_; # my $lat1 = shift @_; # # $lon0 = deg2rad($lon0); # $lon1 = deg2rad($lon1); # $lat0 = deg2rad($lat0); # $lat1 = deg2rad($lat1); # # Use the haversine formula for distance calculation # # http://mathforum.org/library/drmath/view/51879.html # my $dlon = $lon1 - $lon0; # my $dlat = $lat1 - $lat0; # my $a = (sin($dlat/2)) ** 2 + cos($lat0) * cos($lat1) * (sin($dlon/2)) ** 2; # my $c = 2 * atan2(sqrt($a), sqrt(1-$a)); # my $distance = $c * 6366.71; # in kilometers # # # the radius of earth is about 6378.137 km # ##my $distance = great_circle_distance( # # deg2rad($lon0), # # deg2rad(90 - $lat0), # # deg2rad($lon1), # # deg2rad(90 - $lat1), # # 6378.137); # # return $distance; # } # # # Return the direction in degrees from lat0/lon0 to # # lat1/lon1. # # Arguments are given in order as # # lon0, lat0, lon1, lat1, east and north positive. # sub direction($$$$) { # my $self = shift; # # my $lon0 = shift @_; # my $lat0 = shift @_; # my $lon1 = shift @_; # my $lat1 = shift @_; # # $lon0 = deg2rad($lon0); # $lon1 = deg2rad($lon1); # $lat0 = deg2rad($lat0); # $lat1 = deg2rad($lat1); # # # direction from Aviation Formulary V1.42 by Ed Williams # # by way of http://mathforum.org/library/drmath/view/55417.html # my $direction = atan2(sin($lon1-$lon0)*cos($lat1), # cos($lat0)*sin($lat1)-sin($lat0)*cos($lat1)*cos($lon1-$lon0)); # if ($direction < 0) { # # make direction positive # $direction += 2 * pi; # } # # return rad2deg($direction); # } # Count the number of digipeated hops in a (KISS) packet and # return it. Returns -1 in case of error. # The parameter is the full packet or just the header # in TNC2 format. sub count_digihops($) { my $self = shift; my $header = shift @_; # Do a rough check on the header syntax $header =~ tr/\r\n//d; $header = uc($header); if ($header =~ /^([^:]+):/o) { # remove data part of packet, if present $header = $1; } my $hops = undef; if ($header =~ /^([A-Z0-9-]+)\>([A-Z0-9-]+)$/o) { # check the callsigns for validity my $retval = check_ax25_call($self, $1); if (not(defined($retval))) { if ($self->{debug} > 0) { print STDERR "count_digihops: invalid source callsign ($1)\n"; } return -1; } $retval = check_ax25_call($self, $2); if (not(defined($retval))) { if ($self->{debug} > 0) { print STDERR "count_digihops: invalid destination callsign ($2)\n"; } return -1; } # no path at all, so zero hops return 0; } elsif ($header =~ /^([A-Z0-9-]+)\>([A-Z0-9-]+),([A-Z0-9,*-]+)$/o) { my $retval = check_ax25_call($self, $1); if (not(defined($retval))) { if ($self->{debug} > 0) { print STDERR "count_digihops: invalid source callsign ($1)\n"; } return -1; } $retval = check_ax25_call($self, $2); if (not(defined($retval))) { if ($self->{debug} > 0) { print STDERR "count_digihops: invalid destination callsign ($2)\n"; } return -1; } # some hops $hops = $3; } else { # invalid if ($self->{debug} > 0) { print STDERR "count_digihops: invalid packet header\n"; } return -1; } my $hopcount = 0; # split the path into parts my @parts = split(/,/, $hops); # now examine the parts one by one foreach my $piece (@parts) { # remove the possible "digistar" from the end of callsign # and take note of its existence my $wasdigied = 0; if ($piece =~ /^[A-Z0-9-]+\*$/o) { $wasdigied = 1; $piece =~ s/\*$//; } # check the callsign for validity and expand it my $call = check_ax25_call($self, $piece); if (not(defined($call))) { if ($self->{debug} > 0) { print STDERR "count_digihops: invalid callsign in path ($piece)\n"; } return -1; } # check special cases, wideN-N and traceN-N for now if ($call =~ /^WIDE([1-7])-([0-7])$/o) { my $difference = $1 - $2; if ($difference < 0) { # ignore reversed N-N if ($self->{debug} > 0) { print STDERR "count_digihops: reversed N-N in path ($call)\n"; } next; } $hopcount += $difference; } elsif ($call =~ /^TRACE([1-7])-([0-7])$/o) { # skip traceN-N because the hops are already individually shown # before this next; } else { # just a normal packet. if "digistar" is there, # increment the digicounter by one if ($wasdigied == 1) { $hopcount++; } } } return $hopcount; } # Return a unix timestamp based on an # APRS six character timestamp. If an invalid # timestamp is given, return 0. sub parse_timestamp($$) { my $self = shift; my $timestring = shift @_; # Check initial format my $stamp = undef; my $stamptype = undef; if ($timestring =~ /^(\d{6})(z|h|\/)$/o) { $stamp = $1; $stamptype = $2; } else { return 0; } if ($stamptype eq 'h') { # HMS format if ($stamp =~ /^(\d{2})(\d{2})(\d{2})$/io) { my $hour = $1; my $minute = $2; my $second = $3; # Check for invalid time if ($hour > 23 || $minute > 59 || $second > 59) { return 0; } # All calculations here are in UTC, but # if this is run under old MacOS, then # Date_to_Time could be in local time.. my $currenttime = time(); my ($cyear, $cmonth, $cday) = Today(1); my $tstamp = Date_to_Time($cyear, $cmonth, $cday, $hour, $minute, $second); # If the time is more than about one hour # into the future, roll the timestamp # one day backwards. if ($currenttime + 3900 < $tstamp) { $tstamp -= 86400; # If the time is more than about 23 hours # into the past, roll the timestamp one # day forwards. } elsif ($currenttime - 82500 > $tstamp) { $tstamp += 86400; } return $tstamp; } } elsif ($stamptype eq 'z' || $stamptype eq '/') { # Timestamp is DHM, UTC (z) or local (/). # Always intepret local to mean local # to this computer. if ($stamp =~ /^(\d{2})(\d{2})(\d{2})$/io) { my $day = $1; my $hour = $2; my $minute = $3; if ($day < 1 || $day > 31 || $hour > 23 || $minute > 59) { return 0; } # If time is under about 12 hours into # the future, go there. # Otherwise get the first matching # time in the past. my $currenttime = time(); my ($cyear, $cmonth, $cday); if ($stamptype eq 'z') { ($cyear, $cmonth, $cday) = Today(1); } else { ($cyear, $cmonth, $cday) = Today(0); } # Form the possible timestamps in # this, the next and the previous month my ($fwdyear, $fwdmonth) = (Add_Delta_YM($cyear, $cmonth, $cday, 0, 1))[0,1]; my ($backyear, $backmonth) = (Add_Delta_YM($cyear, $cmonth, $cday, 0, -1))[0,1]; my $fwdtstamp = undef; my $currtstamp = undef; my $backtstamp = undef; if (check_date($cyear, $cmonth, $day)) { if ($stamptype eq 'z') { $currtstamp = Date_to_Time($cyear, $cmonth, $day, $hour, $minute, 0); } else { $currtstamp = Mktime($cyear, $cmonth, $day, $hour, $minute, 0); } } if (check_date($fwdyear, $fwdmonth, $day)) { if ($stamptype eq 'z') { $fwdtstamp = Date_to_Time($fwdyear, $fwdmonth, $day, $hour, $minute, 0); } else { $fwdtstamp = Mktime($cyear, $cmonth, $day, $hour, $minute, 0); } } if (check_date($backyear, $backmonth, $day)) { if ($stamptype eq 'z') { $backtstamp = Date_to_Time($backyear, $backmonth, $day, $hour, $minute, 0); } else { $backtstamp = Mktime($cyear, $cmonth, $day, $hour, $minute, 0); } } # Select the timestamp to use. Pick the timestamp # that is largest, but under about 12 hours from # current time. if (defined($fwdtstamp) && ($fwdtstamp - $currenttime) < 43400) { return $fwdtstamp; } elsif (defined($currtstamp) && ($currtstamp - $currenttime) < 43400) { return $currtstamp; } elsif (defined($backtstamp)) { return $backtstamp; } } } # return failure if we haven't returned with # a success earlier return 0; } # return an NMEA latitude or longitude. # 1st parameter is the (dd)dmm.m(mmm..) string and # 2nd is the north/south or east/west indicator # returns undef on error. The returned value # is decimal degrees, north and east positive. sub nmea_getlatlon($$$) { my $self = shift; my $value = shift @_; my $sign = shift @_; # upcase the sign for compatibility $sign = uc($sign); # Be leninent on what to accept, anything # goes as long as degrees has 1-3 digits, # minutes has 2 digits and there is at least # one decimal minute. if ($value =~ /^\s*(\d{1,3})([0-5][0-9])\.(\d+)\s*$/o) { my $minutes = $2 . "." . $3; $value = $1 + ($minutes / 60); } else { if ($self->{debug} > 0) { print STDERR "Invalid coordinate value ($value) in NMEA sentence\n"; } return undef; } if ($sign =~ /^\s*[EW]\s*$/o) { # make sure the value is ok if ($value > 179.999999) { if ($self->{debug} > 0) { print STDERR "Too large value ($value) in NMEA sentence (east/west)\n"; } return undef; } # west negative if ($sign =~ /^\s*W\s*$/o) { $value *= -1; } } elsif ($sign =~ /^\s*[NS]\s*$/o) { # make sure the value is ok if ($value > 89.999999) { if ($self->{debug} > 0) { print STDERR "Too large value ($value) in NMEA sentence (north/south)\n"; } return undef; } # south negative if ($sign =~ /^\s*S\s*$/o) { $value *= -1; } } else { # incorrect sign if ($self->{debug} > 0) { print STDERR "Invalid lat/long sign in NMEA sentence ($sign)\n"; } return undef; } # all ok return $value; } # return a two element array, first containing # the symbol table id (or overlay) and second # containing symbol id. return undef in error sub get_symbol_fromdst($$) { my $self = shift; my $dstcallsign = shift @_; my $table = undef; my $code = undef; if ($dstcallsign =~ /^(GPS|SPC)([A-Z0-9]{2,3})/o) { my $leftoverstring = $2; my $type = substr($leftoverstring, 0, 1); my $sublength = length($leftoverstring); if ($sublength == 3) { if ($type eq "C" || $type eq "E") { my $numberid = substr($leftoverstring, 1, 2); if ($numberid =~ /^(\d{2})$/o && $numberid > 0 && $numberid < 95) { $code = chr($1 + 32); if ($type eq "C") { $table = "/"; } else { $table = "\\"; } return ($table, $code); } else { return undef; } } else { # secondary symbol table, with overlay # Check first that we really are in the # secondary symbol table my $dsttype = substr($leftoverstring, 0, 2); my $overlay = substr($leftoverstring, 2, 1); if (($type eq "O" || $type eq "A" || $type eq "N" || $type eq "D" || $type eq "S" || $type eq "Q") && $overlay =~ /^[A-Z0-9]$/o) { if (defined($dstsymbol{$dsttype})) { $code = substr($dstsymbol{$dsttype}, 1, 1); return ($overlay, $code); } else { return undef; } } else { return undef; } } } else { # primary or secondary symbol table, no overlay if (defined($dstsymbol{$leftoverstring})) { $table = substr($dstsymbol{$leftoverstring}, 0, 1); $code = substr($dstsymbol{$leftoverstring}, 1, 1); return ($table, $code); } else { return undef; } } } else { return undef; } # failsafe catch-all return undef; } # Parse an NMEA location sub nmea_to_decimal($$$$$) { my $self = shift; #(substr($body, 1), $srccallsign, $dstcallsign, \%poshash) my $body = shift @_; my $srccallsign = shift @_; my $dstcallsign = shift @_; my $rethash = shift @_; if ($self->{debug} > 1) { # print packet, after stripping control chars my $printbody = $body; $printbody =~ tr/[\x00-\x1f]//d; print "NMEA: from $srccallsign to $dstcallsign: $printbody\n"; } # verify checksum first, if it is provided $body =~ s/\s+$//; # remove possible white space from the end if ($body =~ /^([\x20-\x7e]+)\*([0-9A-F]{2})$/io) { my $checksumarea = $1; my $checksumgiven = hex($2); my $checksumcalculated = 0; for (my $i = 0; $i < length($checksumarea); $i++) { $checksumcalculated ^= ord(substr($checksumarea, $i, 1)); } if ($checksumgiven != $checksumcalculated) { # invalid checksum if ($self->{debug} > 0) { print STDERR "Invalid checksum in NMEA sentence\n"; } return 0; } # make a note of the existance of a checksum $rethash->{checksumok} = 1; } # checksum ok or not provided # use a dot as a default symbol if one is not defined in # the destination callsign my ($symtable, $symcode) = get_symbol_fromdst($self, $dstcallsign); if (not(defined($symtable)) || not(defined($symcode))) { $rethash->{symboltable} = "/"; $rethash->{symbolcode} = "/"; } else { $rethash->{symboltable} = $symtable; $rethash->{symbolcode} = $symcode; } # Split to NMEA fields $body =~ s/\*[0-9A-F]{2}$//; # remove checksum from body first my @nmeafields = split(/,/, $body); # Now check the sentence type and get as much info # as we can (want). if ($nmeafields[0] eq "GPRMC") { # we want at least 10 fields if (@nmeafields < 10) { if ($self->{debug} > 0) { print STDERR "Less than ten fields in GPRMC sentence (" . scalar(@nmeafields) . ")\n"; } return 0; } if ($nmeafields[2] ne "A") { # invalid position if ($self->{debug} > 0) { print STDERR "No GPS fix in GPRMC sentence\n"; } return 0; } # check and save the timestamp my ($hour, $minute, $second); if ($nmeafields[1] =~ /^\s*(\d{2})(\d{2})(\d{2})(|\.\d+)\s*$/o) { # if seconds has a decimal part, ignore it # leap seconds are not taken into account... if ($1 > 23 || $2 > 59 || $3 > 59) { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in GPRMC sentence ($nmeafields[1])\n"; } return 0; } $hour = $1 + 0; # force numeric $minute = $2 + 0; $second = $3 + 0; } else { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in GPRMC sentence\n"; } return 0; } my ($year, $month, $day); if ($nmeafields[9] =~ /^\s*(\d{2})(\d{2})(\d{2})\s*$/o) { # check the date for validity. Assume # years 0-69 are 21st century and years # 70-99 are 20th century $year = 2000 + $3; if ($3 >= 70) { $year = 1900 + $3; } # check for invalid date if (not(check_date($year, $2, $1))) { if ($self->{debug} > 0) { print STDERR "Invalid date in GPRMC sentence ($year $2 $1)\n"; } return 0; } $month = $2 + 0; # force numeric $day = $1 + 0; } else { if ($self->{debug} > 0) { print STDERR "Invalid date in GPRMC sentence\n"; } return 0; } # Date_to_Time() can only handle 32-bit unix timestamps, # so make sure it is not used for those years that # are outside that range. if ($year >= 2038 || $year < 1970) { $rethash->{timestamp} = 0; } else { $rethash->{timestamp} = Date_to_Time($year, $month, $day, $hour, $minute, $second); } # speed (knots) and course, make these optional # in the parsing sense (don't fail if speed/course # can't be decoded). if ($nmeafields[7] =~ /^\s*(\d+(|\.\d+))\s*$/o) { # convert to km/h $rethash->{speed} = $1 * 1.852; } if ($nmeafields[8] =~ /^\s*(\d+(|\.\d+))\s*$/o) { # round to nearest integer my $course = int($1 + 0.5); # if zero, set to 360 because in APRS # zero means invalid course... if ($course == 0) { $course = 360; } elsif ($course > 360) { $course = 0; # invalid } $rethash->{course} = $course; } else { $rethash->{course} = 0; # unknown } # latitude and longitude my $latitude = nmea_getlatlon($self, $nmeafields[3], $nmeafields[4]); if (not(defined($latitude))) { return 0; } $rethash->{latitude} = $latitude; my $longitude = nmea_getlatlon($self, $nmeafields[5], $nmeafields[6]); if (not(defined($longitude))) { return 0; } $rethash->{longitude} = $longitude; # we have everything we want, return return 1; } elsif ($nmeafields[0] eq "GPGGA") { # we want at least 11 fields if (@nmeafields < 11) { if ($self->{debug} > 0) { print STDERR "Less than 11 fields in GPGGA sentence (" . scalar(@nmeafields) . ")\n"; } return 0; } # check for position validity if ($nmeafields[6] =~ /^\s*(\d+)\s*$/o) { if ($1 < 1) { if ($self->{debug} > 0) { print STDERR "No GPS fix in GPGGA sentence ($1)\n"; } return 0; } } else { if ($self->{debug} > 0) { print STDERR "No GPS fix in GPGGA sentence\n"; } return 0; } # Use the APRS time parsing routines to check # the time and convert it to timestamp. # But before that, remove a possible decimal part $nmeafields[1] =~ s/\.\d+$//; $rethash->{timestamp} = parse_timestamp($self, $nmeafields[1] . "h"); if ($rethash->{timestamp} == 0) { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in GPGGA sentence\n"; } return 0; } # latitude and longitude my $latitude = nmea_getlatlon($self, $nmeafields[2], $nmeafields[3]); if (not(defined($latitude))) { return 0; } $rethash->{latitude} = $latitude; my $longitude = nmea_getlatlon($self, $nmeafields[4], $nmeafields[5]); if (not(defined($longitude))) { return 0; } $rethash->{longitude} = $longitude; # altitude, only meters are accepted if ($nmeafields[10] eq "M" && $nmeafields[9] =~ /^(-?\d+(|\.\d+))$/o) { # force numeric interpretation $rethash->{altitude} = $1 + 0; } # ok return 1; } elsif ($nmeafields[0] eq "GPGLL") { # we want at least 5 fields if (@nmeafields < 5) { if ($self->{debug} > 0) { print STDERR "Less than 5 fields in GPGLL sentence (" . scalar(@nmeafields) . ")\n"; } return 0; } # latitude and longitude my $latitude = nmea_getlatlon($self, $nmeafields[1], $nmeafields[2]); if (not(defined($latitude))) { return 0; } $rethash->{latitude} = $latitude; my $longitude = nmea_getlatlon($self, $nmeafields[3], $nmeafields[4]); if (not(defined($longitude))) { return 0; } $rethash->{longitude} = $longitude; # Use the APRS time parsing routines to check # the time and convert it to timestamp. # But before that, remove a possible decimal part if (@nmeafields >= 6) { $nmeafields[5] =~ s/\.\d+$//; $rethash->{timestamp} = parse_timestamp($self, $nmeafields[5] . "h"); if ($rethash->{timestamp} == 0) { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in GPGLL sentence\n"; } return 0; } } if (@nmeafields >= 7) { # GPS fix validity supplied if ($nmeafields[6] ne "A") { if ($self->{debug} > 0) { print STDERR "No GPS fix in GPGLL sentence\n"; } return 0; } } # ok return 1; ##} elsif ($nmeafields[0] eq "GPVTG") { ##} elsif ($nmeafields[0] eq "GPWPT") { } else { if ($self->{debug} > 0) { $nmeafields[0] =~ tr/[\x00-\x1f]//d; print STDERR "Unsupported NMEA sentence type: $nmeafields[0]\n"; } return 0; } return 0; } # Parse the possible APRS data extension # as well as comment sub comments_to_decimal($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # First check the possible APRS data extension, # immediately following the packet my $rest = $packet; if (length($rest) >= 7) { if ($rest =~ /^([0-9. ]{3})\/([0-9. ]{3})/o) { my $course = $1; my $speed = $2; if ($course =~ /^\d{3}$/o && $course <= 360 && $course >= 1) { # force numeric interpretation $course += 0; $rethash->{course} = $course; } else { # course is invalid, set it to zero $rethash->{course} = 0; } if ($speed =~ /^\d{3}$/o) { # force numeric interpretation # and convert to km/h $rethash->{speed} = $speed * 1.852; } else { # If speed is invalid, don't set it # (zero speed is a valid speed). } $rest = substr($rest, 7); } elsif ($rest =~ /^PHG(\d)([\x30-\x7e])(\d)(\d)/o) { # don't do anything fancy with PHG, just store it $rethash->{phg} = $1; $rest = substr($rest, 7); } elsif ($rest =~ /^RNG(\d{4})/o) { # radio range, in miles, so convert # to km $rethash->{radiorange} = $1 * 1.609344; $rest = substr($rest, 7); } } # Check for optional altitude anywhere in the comment, # take the first occurrence if ($rest =~ /^(.*?)\/A=(-\d{5}|\d{6})(.*)$/o) { # convert to meters as well $rethash->{altitude} = $2 * 0.3048; $rest = $1 . $3; } # Save the rest as a separate comment, if # anything is left (trim unprintable chars # out first and white space from both ends) $rest =~ tr/[\x20-\x7e\x80-\xfe]//cd; $rest =~ s/^\s+//; $rest =~ s/\s+$//; if (length($rest) > 0) { $rethash->{comment} = $rest; } # Always succeed as these are optional return 1; } # Parse an object sub object_to_decimal($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Minimum length for an object is 31 characters # (or 46 characters for non-compressed) if (length($packet) < 31) { if ($self->{debug} > 0) { print STDERR "Too short object from $srccallsign\n"; } return 0; } # Parse the object up to the location my $timestamp = undef; if ($packet =~ /^;([\x20-\x7e]{9})(\*|_)(\d{6})(z|h)/o) { # hash member 'objectname' signals an object $rethash->{objectname} = $1; if ($2 eq '*') { $rethash->{alive} = 1; } else { $rethash->{alive} = 0; } $timestamp = $3 . $4; } else { if ($self->{debug} > 0) { print STDERR "Invalid object from $srccallsign\n"; } return 0; } # Check the timestamp for validity and convert # to UNIX epoch. If the timestamp is invalid, set it # to zero. $rethash->{timestamp} = parse_timestamp($self, $timestamp); if ($rethash->{timestamp} == 0) { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in an object from $srccallsign\n"; } } # Forward the location parsing onwards my $locationoffset = 18; # object location always starts here my $locationchar = substr($packet, $locationoffset, 1); my $retval = undef; if ($locationchar =~ /^[\/\\A-Za-j]$/o) { # compressed $retval = compressed_to_decimal($self, substr($packet, $locationoffset, 13), $srccallsign, $rethash); $locationoffset += 13; # now points to APRS data extension/comment } elsif ($locationchar =~ /^\d$/io) { # normal $retval = normalpos_to_decimal($self, substr($packet, $locationoffset), $srccallsign, $rethash); $locationoffset += 19; # now points to APRS data extension/comment } else { # error if ($self->{debug} > 0) { print STDERR "Error in object location decoding from $srccallsign\n"; } return 0; } if ($retval != 1) { # error in location decoding if ($self->{debug} > 0) { print STDERR "Error in object location decoding from $srccallsign\n"; } return 0; } # Check the APRS data extension and possible comments, # unless it is a weather report (we don't want erroneus # course/speed figures and weather in the comments..) if ($rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($packet, $locationoffset), $srccallsign, $rethash); } return 1; } # Parse a status report. Only timestamps # and text report are supported. Maidenhead, # beam headings and symbols are not. sub status_parse($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Remove CRs, LFs and trailing spaces $packet =~ tr/\r\n//d; $packet =~ s/\s+$//; # Check for a timestamp if ($packet =~ /^(\d{6}z)/o) { $rethash->{timestamp} = parse_timestamp($self, $1); $packet = substr($packet, 7); } # Save the rest as the report $rethash->{status} = $packet; return 1; } # Parse a station capabilities packet sub capabilities_parse($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Remove CRs, LFs and trailing spaces $packet =~ tr/\r\n//d; $packet =~ s/\s+$//; # Then just split the packet, we aren't too picky about the format here. # Also duplicates and case changes are not handled in any way, # so the last part will override an earlier part and different # cases can be present. Just remove trailing/leading spaces. my @caps = split(/,/, $packet); my %caphash = (); foreach my $cap (@caps) { if ($cap =~ /^\s*([^=]+?)\s*=\s*(.*?)\s*$/o) { # TOKEN=VALUE $caphash{$1} = $2; } elsif ($cap =~ /^\s*([^=]+?)\s*$/o) { # just TOKEN $caphash{$1} = undef; } } my $keycount = keys(%caphash); if ($keycount > 0) { # store the capabilities in the return hash $rethash->{capabilities} = \%caphash; return 1; } else { # at least one capability has to be defined for a capability # packet to be counted as valid return 0; } } # Parse a message sub message_parse($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Check format if ($packet =~ /^:([A-Za-z0-9_ -]{9}):([\x20-\x7e\x80-\xfe]+)$/o) { my $destination = $1; my $message = $2; # remove trailing spaces from the recipient $destination =~ s/\s+$//; $rethash->{destination} = $destination; # check whether this is an ack if ($message =~ /^ack([A-Za-z0-9}]{1,5})\s*$/o) { # trailing spaces are allowed because some # broken software insert them.. $rethash->{messageack} = $1; return 1; } # separate message-id from the body, if present if ($message =~ /^([^{]*)\{([A-Za-z0-9}]{1,5})\s*$/o) { $rethash->{message} = $1; $rethash->{messageid} = $2; } else { $rethash->{message} = $message; } return 1; } return 0; } # Parse an item sub item_to_decimal($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Minimum length for an item is 18 characters # (or 24 characters for non-compressed) if (length($packet) < 18) { if ($self->{debug} > 0) { print STDERR "Too short item from $srccallsign\n"; } return 0; } # Parse the item up to the location if ($packet =~ /^\)([\x20\x22-\x5e\x60-\x7e]{3,9})(!|_)/o) { # hash member 'itemname' signals an item $rethash->{itemname} = $1; if ($2 eq '!') { $rethash->{alive} = 1; } else { $rethash->{alive} = 0; } } else { if ($self->{debug} > 0) { print STDERR "Invalid item from $srccallsign\n"; } return 0; } # Forward the location parsing onwards my $locationoffset = 2 + length($rethash->{itemname}); my $locationchar = substr($packet, $locationoffset, 1); my $retval = undef; if ($locationchar =~ /^[\/\\A-Za-j]$/o) { # compressed $retval = compressed_to_decimal($self, substr($packet, $locationoffset, 13), $srccallsign, $rethash); $locationoffset += 13; } elsif ($locationchar =~ /^\d$/io) { # normal $retval = normalpos_to_decimal($self, substr($packet, $locationoffset), $srccallsign, $rethash); $locationoffset += 19; } else { # error if ($self->{debug} > 0) { print STDERR "Error in item location decoding from $srccallsign\n"; } return 0; } if ($retval != 1) { # error in location decoding if ($self->{debug} > 0) { print STDERR "Error in item location decoding from $srccallsign\n"; } return 0; } # Check the APRS data extension and possible comments, # unless it is a weather report (we don't want erroneus # course/speed figures and weather in the comments..) if ($rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($packet, $locationoffset), $srccallsign, $rethash); } return 1; } # Parse a normal uncompressed location sub normalpos_to_decimal($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # Check the length if (length($packet) < 19) { if ($self->{debug} > 0) { print STDERR "too short location in packet from $srccallsign\n"; } return 0; } # Make a more detailed check on the format, but do the # actual value checks later my $lon_deg = undef; my $lat_deg = undef; my $lon_min = undef; my $lat_min = undef; my $issouth = 0; my $iswest = 0; if ($packet =~ /^(\d{2})([0-5 ][0-9 ]\.[0-9 ]{2})([NnSs])([\/\\A-Z0-9])(\d{3})([0-5 ][0-9 ]\.[0-9 ]{2})([EeWw])([\x21-\x7b\x7d])/o) { my $sind = uc($3); my $wind = uc($7); $rethash->{symboltable} = $4; $rethash->{symbolcode} = $8; if ($sind eq 'S') { $issouth = 1; } if ($wind eq 'W') { $iswest = 1; } $lat_deg = $1; $lat_min = $2; $lon_deg = $5; $lon_min = $6; } else { if ($self->{debug} > 0) { print STDERR "invalid location in packet from $srccallsign\n"; } return 0; } # Check the degree values if ($lat_deg > 89 || $lon_deg > 179) { if ($self->{debug} > 0) { print STDERR "Degree value too large from $srccallsign\n"; } return 0; } # Find out the amount of position ambiguity my $tmplat = $lat_min; $tmplat =~ s/\.//; # remove the period # Count the amount of spaces at the end if ($tmplat =~ /^(\d{0,4})( {0,4})$/io) { $rethash->{posambiguity} = length($2); } else { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in packet from $srccallsign\n"; } return 0; } my $latitude = undef; my $longitude = undef; if ($rethash->{posambiguity} == 0) { # No position ambiguity. Check longitude for invalid spaces if ($lon_min =~ / /io) { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in longitude from $srccallsign\n"; } return 0; } $latitude = $lat_deg + ($lat_min/60); $longitude = $lon_deg + ($lon_min/60); } elsif ($rethash->{posambiguity} == 4) { # disregard the minutes and add 0.5 to the degree values $latitude = $lat_deg + 0.5; $longitude = $lon_deg + 0.5; } elsif ($rethash->{posambiguity} == 1) { # the last digit is not used $lat_min = substr($lat_min, 0, 4); $lon_min = substr($lon_min, 0, 4); if ($lat_min =~ / /io || $lon_min =~ / /io) { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in lat/lon from $srccallsign\n"; } return 0; } $latitude = $lat_deg + (($lat_min + 0.05)/60); $longitude = $lon_deg + (($lon_min + 0.05)/60); } elsif ($rethash->{posambiguity} == 2) { # the minute decimals are not used $lat_min = substr($lat_min, 0, 2); $lon_min = substr($lon_min, 0, 2); if ($lat_min =~ / /io || $lon_min =~ / /io) { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in lat/lon from $srccallsign\n"; } return 0; } $latitude = $lat_deg + (($lat_min + 0.5)/60); $longitude = $lon_deg + (($lon_min + 0.5)/60); } elsif ($rethash->{posambiguity} == 3) { # the single minutes are not used $lat_min = substr($lat_min, 0, 1) . "5"; $lon_min = substr($lon_min, 0, 1) . "5"; if ($lat_min =~ / /io || $lon_min =~ / /io) { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in lat/lon from $srccallsign\n"; } return 0; } $latitude = $lat_deg + ($lat_min/60); $longitude = $lon_deg + ($lon_min/60); } else { if ($self->{debug} > 0) { print STDERR "Position ambiguity error in packet from $srccallsign\n"; } return 0; } # Finally apply south/west indicators if ($issouth == 1) { $latitude = 0 - $latitude; } if ($iswest == 1) { $longitude = 0 - $longitude; } # Store the locations $rethash->{latitude} = $latitude; $rethash->{longitude} = $longitude; # Parse possible APRS data extension # afterwards along with comments return 1; } # convert a mic-encoder packet sub mice_to_decimal($$$$$) { my $self = shift; my $packet = shift @_; my $dstcallsign = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # We only want the base callsign $dstcallsign =~ s/-\d+$//; # Check the format if (length($packet) < 8 || length($dstcallsign) != 6) { # too short packet to be mic-e if ($self->{debug} > 0) { print STDERR "too short to be mic-e from $srccallsign\n"; } return 0; } if (not($dstcallsign =~ /^[0-9A-LP-Z]{3}[0-9LP-Z]{3}$/io)) { # A-K characters are not used in the last 3 characters # and MNO are never used if ($self->{debug} > 0) { print STDERR "invalid characters in destination callsign (mic-e) from $srccallsign\n"; } return 0; } # check the information field (longitude, course, speed and # symbol table and code are checked). Not bullet proof.. if (not($packet =~ /^[\x26-\x7f][\x26-\x61][\x1c-\x7f]{2}[\x1c-\x7d][\x1c-\x7f][\x21-\x7b\x7d][\/\\A-Z0-9]/o)) { if ($self->{debug} > 0) { print STDERR "invalid characters in information field (mic-e) from $srccallsign\n"; } #for (my $i = 0; $i < length($packet); $i++) { # printf("%x ", ord(substr($packet, $i, 1))); #} return 0; } # First do the destination callsign # (latitude, message bits, N/S and W/E indicators and long. offset) # Translate the characters to get the latitude my $tmplat = $dstcallsign; $tmplat =~ tr/A-JP-YKLZ/0-90-9___/; # Find out the amount of position ambiguity if ($tmplat =~ /^(\d+)(_*)$/io) { my $amount = 6 - length($1); if ($amount > 4) { # only minutes and decimal minutes can # be masked out if ($self->{debug} > 0) { print STDERR "too much position ambiguity from $srccallsign\n"; } return 0; } $rethash->{posambiguity} = $amount; } else { # no digits in the beginning, baaad.. # or the ambiguity digits weren't continuous if ($self->{debug} > 0) { print STDERR "ambiguity decoding failure from $srccallsign\n"; } return 0; } # convert the latitude to the midvalue if position ambiguity # is used if ($rethash->{posambiguity} >= 4) { # the minute is between 0 and 60, so # the middle point is 30 $tmplat =~ s/_/3/; } else { $tmplat =~ s/_/5/; # the first is changed to digit 5 } $tmplat =~ s/_/0/g; # the rest are changed to digit 0 # get the degrees my $latitude = substr($tmplat, 0, 2); # the minutes my $latminutes = substr($tmplat, 2, 2) . "." . substr($tmplat, 4, 2); # convert the minutes to decimal degrees and combine $latitude += ($latminutes/60); # check the north/south direction and correct the latitude # if necessary my $nschar = ord(substr($dstcallsign, 3, 1)); if ($nschar <= 0x4c) { $latitude = 0 - $latitude; } # Latitude is finally complete, so store it $rethash->{latitude} = $latitude; # Get the message bits. 1 is standard one-bit and # 2 is custom one-bit. %mice_messagetypes provides # the mappings to message names my $mbitstring = substr($dstcallsign, 0, 3); $mbitstring =~ tr/0-9/0/; $mbitstring =~ tr/L/0/; $mbitstring =~ tr/P-Z/1/; $mbitstring =~ tr/A-K/2/; $rethash->{mbits} = $mbitstring; # Decode the longitude, the first three bytes of the # body after the data type indicator. # First longitude degrees, remember the longitude offset my $longitude = ord(substr($packet, 0, 1)) - 28; my $longoffsetchar = ord(substr($dstcallsign, 4, 1)); if ($longoffsetchar >= 0x50) { $longitude += 100; } if ($longitude >= 180 && $longitude <= 189) { $longitude -= 80; } elsif ($longitude >= 190 && $longitude <= 199) { $longitude -= 190; } # Decode the longitude minutes my $longminutes = ord(substr($packet, 1, 1)) - 28; if ($longminutes >= 60) { $longminutes -= 60; } # ... and minute decimals $longminutes = sprintf("%02d.%02d", $longminutes, ord(substr($packet, 2, 1)) - 28); # apply position ambiguity to longitude if ($rethash->{posambiguity} == 4) { # minute is unused -> add 0.5 degrees to longitude $longitude += 0.5; } elsif ($rethash->{posambiguity} == 3) { my $lontmp = substr($longminutes, 0, 1) . "5"; $longitude += ($lontmp/60); } elsif ($rethash->{posambiguity} == 2) { my $lontmp = substr($longminutes, 0, 2) . ".5"; $longitude += ($lontmp/60); } elsif ($rethash->{posambiguity} == 1) { my $lontmp = substr($longminutes, 0, 4) . "5"; $longitude += ($lontmp/60); } elsif ($rethash->{posambiguity} == 0) { $longitude += ($longminutes/60); } else { if ($self->{debug} > 0) { print STDERR "position ambiguity error from $srccallsign\n"; } return 0; } # check the longitude E/W sign my $ewchar = ord(substr($dstcallsign, 5, 1)); if ($ewchar >= 0x50) { $longitude = 0 - $longitude; } # Longitude is finally complete, so store it $rethash->{longitude} = $longitude; # Now onto speed and course my $speed = (ord(substr($packet, 3, 1)) - 28) * 10; my $coursespeed = ord(substr($packet, 4, 1)) - 28; my $coursespeedtmp = int($coursespeed / 10); $speed += $coursespeedtmp; $coursespeed -= $coursespeedtmp * 10; my $course = 100 * $coursespeed; $course += ord(substr($packet, 5, 1)) - 28; # do some important adjustements if ($speed >= 800) { $speed -= 800; } if ($course >= 400) { $course -= 400; } # convert speed to km/h and store $rethash->{speed} = $speed * 1.852; # also zero course is saved, which means unknown if ($course >= 0) { $rethash->{course} = $course; } # save the symbol table and code $rethash->{symbolcode} = substr($packet, 6, 1); $rethash->{symboltable} = substr($packet, 7, 1); # Check for possible altitude and comment data. # It is base-91 coded and in format "xxx}" where # x are the base-91 digits in meters, origin is 10000 meters # below sea. if (length($packet) > 8) { my $rest = substr($packet, 8); # check for altitude if ($rest =~ /^(.*?)([\x21-\x7b])([\x21-\x7b])([\x21-\x7b])\}(.*)$/o) { $rethash->{altitude} = ( (ord($2) - 33) * 91 ** 2 + (ord($3) - 33) * 91 + (ord($4) - 33)) - 10000; $rest = $1 . $5; } # If anything is left, store it as a comment # after removing non-printable ASCII # characters $rest =~ tr/[\x20-\x7e\x80-\xfe]//cd; $rest =~ s/^\s+//; $rest =~ s/\s+$//; if (length($rest) > 0) { $rethash->{comment} = $rest; } } return 1; } # convert a compressed position to decimal degrees sub compressed_to_decimal($$$$) { my $self = shift; my $packet = shift @_; my $srccallsign = shift @_; my $rethash = shift @_; # A compressed position is always 13 characters long. # Make sure we get at least 13 characters and that they are ok. # Also check the allowed base-91 characters at the same time. if (not($packet =~ /^[\/\\A-Za-j]{1}[\x21-\x7b]{8}[\x21-\x7b\x7d]{1}[\x20-\x7b]{3}/o)) { if ($self->{debug} > 0) { print STDERR "Invalid compressed position from $srccallsign\n"; } return 0; } my $symboltable = substr($packet, 0, 1); my $lat1 = ord(substr($packet, 1, 1)) - 33; my $lat2 = ord(substr($packet, 2, 1)) - 33; my $lat3 = ord(substr($packet, 3, 1)) - 33; my $lat4 = ord(substr($packet, 4, 1)) - 33; my $long1 = ord(substr($packet, 5, 1)) - 33; my $long2 = ord(substr($packet, 6, 1)) - 33; my $long3 = ord(substr($packet, 7, 1)) - 33; my $long4 = ord(substr($packet, 8, 1)) - 33; my $symbolcode = substr($packet, 9, 1); my $c1 = ord(substr($packet, 10, 1)) - 33; my $s1 = ord(substr($packet, 11, 1)) - 33; my $comptype = ord(substr($packet, 12, 1)) - 33; # save the symbol table and code $rethash->{symbolcode} = $symbolcode; # the symbol table values a..j are really 0..9 $symboltable =~ tr/a-j/0-9/; $rethash->{symboltable} = $symboltable; # calculate latitude and longitude $rethash->{latitude} = 90 - (($lat1 * 91 ** 3 + $lat2 * 91 ** 2 + $lat3 * 91 + $lat4) / 380926); $rethash->{longitude} = -180 + (($long1 * 91 ** 3 + $long2 * 91 ** 2 + $long3 * 91 + $long4) / 190463); # GPS fix status, only if csT is used if ($c1 != -1) { if (($comptype & 0x20) == 0x20) { $rethash->{gpsfixstatus} = 1; } else { $rethash->{gpsfixstatus} = 0; } } # check the compression type, if GPGGA, then # the cs bytes are altitude. Otherwise try # to decode it as course and speed. And # finally as radio range # if c is space, then csT is not used. # Also require that s is not a space. if ($c1 == -1 || $s1 == -1) { # csT not used } elsif (($comptype & 0x18) == 0x10) { # cs is altitude my $cs = $c1 * 91 + $s1; # convert directly to meters $rethash->{altitude} = (1.002 ** $cs) * 0.3048; } elsif ($c1 >= 0 && $c1 <= 89) { if ($c1 == 0) { # special case of north, APRS spec # uses zero for unknown and 360 for north. # so remember to convert north here. $rethash->{course} = 360; } else { $rethash->{course} = $c1 * 4; } # convert directly to km/h $rethash->{speed} = (1.08 ** $s1 - 1) * 1.852; } elsif ($c1 == 90) { # convert directly to km $rethash->{radiorange} = (2 * 1.08 ** $s1) * 1.609344; } return 1; } # Check the callsign given as parameter # for a valid AX.25 callsign format and # return cleaned up (OH2XYZ-0) callsign or # undef if the callsign is not a valid AX.25 address. sub check_ax25_call($$) { my $self = shift; my $call = shift @_; if ($call =~ m/^([A-Z0-9]{1,6})(-\d{1,2}|)$/o) { my $basecall = $1; my $ssid = $2; if (length($ssid) == 0) { return $basecall . "-0"; } else { # convert SSID to positive and numeric $ssid = 0 - $ssid; if ($ssid < 16) { # 15 is maximum in AX.25 return $basecall . "-" . $ssid; } } } # no successfull return yet, so error return undef; } # Parse an APRS packet given as a string, e.g. # "OH2XYZ>APRS,RELAY*,WIDE:!2345.56N/12345.67E-PHG0123 hi there" # Second parameter has to be a reference to a hash. That hash will # be filled with as much data as possible based on the packet # given as parameter. Returns 1 if the decoding was successfull, # returns 0 if not. In case zero is returned, the contents of # the parameter hash should be discarded. The third parameter # selects whether the packet should be examined in a form # that can exist on an AX.25 network (1) or whether the frame is # from the Internet (0). sub parseaprs($$$$) { my $self = shift; my $packet = shift @_; my $rethash = shift @_; my $isax25 = shift @_; # Remove characters that are never valid in APRS packets ## no sanitizing anymore.. ##$packet =~ tr/\x1c-\x7f//cd; if (not(defined($packet))) { if ($self->{debug} > 0) { print STDERR "No packet given? Can't parse something that doesn't exist\n"; } return 0; } if (length($packet) < 1) { if ($self->{debug} > 0) { print STDERR "Too short packet\n"; } return 0; } # Separate the header and packet body on the first # colon. my ($header, $body) = split(/:/, $packet, 2); # Don't upcase the header because we can't distinguish # the q-construct anymore ## $header = uc($header); # If no body, skip if (not(defined($body))) { if ($self->{debug} > 0) { print STDERR "No body in packet\n"; } return 0; } # Save all the parts of the packet $rethash->{origpacket} = $packet; $rethash->{header} = $header; $rethash->{body} = $body; # Source callsign, put the rest in $rest my $srccallsign = undef; my $rest = undef; if ($header =~ /^([A-Z0-9-]+)>(.*)$/o) { $rest = $2; $srccallsign = check_ax25_call($self, $1); if (not(defined($srccallsign))) { if ($self->{debug} > 0) { print STDERR "Invalid source callsign (1)\n;" } return 0; } } else { # can't be a valid amateur radio callsign if ($self->{debug} > 0) { print STDERR "Invalid source callsign (2)\n"; } return 0; } $rethash->{srccallsign} = $srccallsign; # Get the destination callsign and digipeaters. # Only TNC-2 format is supported, AEA (with digipeaters) is not. my $dstcallsign = undef; my @pathcomponents = split(/,/, $rest); # More than 9 (dst callsign + 8 digipeaters) path components # from AX.25 or less than 1 from anywhere is invalid. if ($isax25 == 1) { if (scalar(@pathcomponents) > 9) { # too many fields to be from AX.25 if ($self->{debug} > 0) { print STDERR "Too many path components to be ax.25\n"; } return 0; } } if (scalar(@pathcomponents) < 1) { # no destination field if ($self->{debug} > 0) { print STDERR "No destination field in packet\n"; } return 0; } # destination callsign $dstcallsign = check_ax25_call($self, shift(@pathcomponents)); if (not(defined($dstcallsign))) { if ($self->{debug} > 0) { print STDERR "Invalid destination callsign in packet\n"; } return 0; } $rethash->{dstcallsign} = $dstcallsign; # digipeaters my @digipeaters; foreach my $digi (@pathcomponents) { if ($isax25 == 1) { if ($digi =~ /^([A-Z0-9-]+)(\*|)$/o) { my $digitested = check_ax25_call($self, $1); if (not(defined($digitested))) { if ($self->{debug} > 0) { print STDERR "Invalid digipeater in packet (1)\n"; } return 0; } my $wasdigied = 0; if ($2 eq '*') { $wasdigied = 1; } # add it to the digipeater array push(@digipeaters, { call => $digitested, wasdigied => $wasdigied }); } else { if ($self->{debug} > 0) { print STDERR "Invalid digipeater in packet (2)\n"; } return 0; } } else { # From the internet. Just copy it on # for now, if ($digi =~ /^([a-zA-Z0-9-]+)(\*|)$/o) { my $call = $1; my $wasdigied = 0; if ($2 eq '*') { $wasdigied = 1; } push(@digipeaters, { call => $call, wasdigied => $wasdigied }); } else { if ($self->{debug} > 0) { print STDERR "Invalid digipeater in inet packet\n"; } return 0; } } } $rethash->{digipeaters} = \@digipeaters; # So now we have source and destination callsigns and # digipeaters parsed and ok. Move on to the body. # Check the first character of the packet # and determine the packet type my $retval = -1; my $packettype = substr($body, 0, 1); my $paclen = length($body); # Check the packet type and proceed depending on it # Mic-encoder packet if (ord($packettype) == 0x27 || ord($packettype) == 0x60) { # the following are obsolete mic-e types: 0x1c 0x1d # mic-encoder data # minimum body length 9 chars if ($paclen >= 9) { $retval = mice_to_decimal($self, substr($body, 1), $dstcallsign, $srccallsign, $rethash); $rethash->{type} = "location"; } # Normal or compressed location packet, with or without # timestamp, with or without messaging capability } elsif ($packettype eq '!' || $packettype eq '=' || $packettype eq '/' || $packettype eq '@') { # with or without messaging if ($packettype eq '!' || $packettype eq '/') { $rethash->{messaging} = 0; } else { $rethash->{messaging} = 1; } if ($paclen >= 14) { $rethash->{type} = "location"; if ($packettype eq '/' || $packettype eq '@') { # With a prepended timestamp, check it and jump over. # If the timestamp is invalid, it will be set to zero. $rethash->{timestamp} = parse_timestamp($self, substr($body, 1, 7)); if ($rethash->{timestamp} == 0) { if ($self->{debug} > 0) { print STDERR "Invalid timestamp in location from $srccallsign\n"; } } $body = substr($body, 7); } $body = substr($body, 1); # remove the first character my $poschar = substr($body, 0, 1); if ($poschar =~ /^[\/\\A-Za-j]$/o) { # compressed position if (length($body) >= 13) { $retval = compressed_to_decimal($self, substr($body, 0, 13), $srccallsign, $rethash); # continue parsing with possible comments, but only # if this is not a weather report (course/speed mixup, # weather as comment) # if the comments don't parse, don't raise an error if ($retval == 1 && $rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($body, 13), $srccallsign, $rethash); } } } elsif ($poschar =~ /^\d$/io) { # normal uncompressed position if (length($body) >= 19) { $retval = normalpos_to_decimal($self, $body, $srccallsign, $rethash); # continue parsing with possible comments, but only # if this is not a weather report (course/speed mixup, # weather as comment) # if the comments don't parse, don't raise an error if ($retval == 1 && $rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($body, 19), $srccallsign, $rethash); } } } elsif ($poschar ne '!') { # there are weather stations that begin packets # with '!!', ignore those if ($self->{debug} > 0) { print STDERR "Invalid packet from $srccallsign\n"; } $retval = 0; } } # NMEA data } elsif ($packettype eq '$') { # don't try to parse the weather stations, require "$GP" start if (substr($body, 0, 3) eq '$GP') { # dstcallsign can contain the APRS symbol to use, # so read that one too $retval = nmea_to_decimal($self, substr($body, 1), $srccallsign, $dstcallsign, $rethash); $rethash->{type} = "location"; } # Object } elsif ($packettype eq ';') { if ($paclen >= 31) { $rethash->{type} = "object"; $retval = object_to_decimal($self, $body, $srccallsign, $rethash); } # Item } elsif ($packettype eq ')') { if ($paclen >= 18) { $rethash->{type} = "item"; $retval = item_to_decimal($self, $body, $srccallsign, $rethash); } # Message, bulletin or an announcement } elsif ($packettype eq ':') { if ($paclen >= 11) { # all are labeled as messages for the time being $rethash->{type} = "message"; $retval = message_parse($self, $body, $srccallsign, $rethash); } # Station capabilities } elsif ($packettype eq '<') { # at least one other character besides '<' required if ($paclen >= 2) { $rethash->{type} = "capabilities"; $retval = capabilities_parse($self, substr($body, 1), $srccallsign, $rethash); } # Status reports } elsif ($packettype eq '>') { # we can live with empty status reports if ($paclen >= 1) { $rethash->{type} = "status"; $retval = status_parse($self, substr($body, 1), $srccallsign, $rethash); } # When all else fails, try to look for a !-position that can # occur anywhere within the 40 first characters according # to the spec. } else { my $pos = index($body, '!'); if ($pos >= 0 && $pos <= 39) { $rethash->{type} = "location"; my $pchar = substr($body, $pos + 1, 1); if ($pchar =~ /^[\/\\A-Za-j]$/o) { # compressed position if (length($body) >= $pos + 1 + 13) { $retval = compressed_to_decimal($self, substr($body, $pos + 1, 13), $srccallsign, $rethash); # check the APRS data extension and comment, # if not weather data if ($retval == 1 && $rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($body, 13), $srccallsign, $rethash); } } } elsif ($pchar =~ /^\d$/io) { # normal uncompressed position if (length($body) >= $pos + 1 + 19) { $retval = normalpos_to_decimal($self, substr($body, $pos + 1), $srccallsign, $rethash); # check the APRS data extension and comment, # if not weather data if ($retval == 1 && $rethash->{symbolcode} ne '_') { comments_to_decimal($self, substr($body, 19), $srccallsign, $rethash); } } } } } if ($self->{debug} > 0) { if ($retval == 1) { print "$srccallsign: "; if ($rethash->{type} eq "message") { if (defined($rethash->{destination})) { print "dest: $rethash->{destination} "; } if (defined($rethash->{messageid})) { print "msgid: $rethash->{messageid} "; } if (defined($rethash->{messageack})) { print "msgack: $rethash->{messageack} "; } if (defined($rethash->{message})) { print "msgtext: \"$rethash->{message}\" "; } } if (defined($rethash->{alive})) { if ($rethash->{alive} == 1) { print "alive "; } elsif ($rethash->{alive} == 0) { print "dead "; } else { print "internal error with alive/dead "; } if (defined($rethash->{objectname})) { print "object \"" . $rethash->{objectname} . "\" "; } elsif (defined($rethash->{itemname})) { print "item \"" . $rethash->{itemname} . "\" "; } else { print "internal error with object/item "; } } if (defined($rethash->{timestamp})) { if ($rethash->{timestamp} > 0) { print "timestamp " . gettime($self, $rethash->{timestamp}) . " "; } else { print "invalid timestamp "; } } if (defined($rethash->{latitude}) && defined($rethash->{longitude})) { printf("lat: %.6f, long: %.6f", $rethash->{latitude}, $rethash->{longitude}); } if (defined($rethash->{mbits})) { if (defined($mice_messagetypes{$rethash->{mbits}})) { print " message: $mice_messagetypes{$rethash->{mbits}}"; } else { print " message: unknown"; } } if (defined($rethash->{posambiguity})) { print " posambig: $rethash->{posambiguity}"; } if (defined($rethash->{gpsfixstatus})) { print " gps status: $rethash->{gpsfixstatus}"; } if (defined($rethash->{altitude})) { print " altitude: $rethash->{altitude} meters"; } if (defined($rethash->{course})) { if ($rethash->{course} == 0) { print " course: unknown" } else { print " course: $rethash->{course} deg"; } } if (defined($rethash->{speed})) { print " speed: $rethash->{speed} km/h"; } if (defined($rethash->{radiorange})) { print " radio range: $rethash->{radiorange} kilometers"; } if (defined($rethash->{symboltable}) && defined($rethash->{symbolcode})) { print " symbol: " . $rethash->{symboltable} . $rethash->{symbolcode}; } if (defined($rethash->{comment})) { print " comment: " . $rethash->{comment}; } print "\n"; } } # print all invalid/unknown packets through a filter if ($self->{debug} > 0) { if ($retval == 0) { $packet =~ tr/[\x00-\x1f]//d; print "prev packet was: $packet\n"; } elsif ($retval == -1) { $packet =~ tr/[\x00-\x1f]//d; print "unknown packet type: $packet\n"; } } # Return success for an ok packet if ($retval == 1) { return 1; } return 0; } # Checks a callsign for validity and strips # trailing spaces out and returns the string. # Returns undef on invalid callsign sub kiss_checkcallsign($$) { my $self = shift; my $callsign = shift @_; if ($callsign =~ /^([A-Z0-9]+)\s*(|-\d+)$/o) { if (length($2) > 0) { # check the SSID if given if ($2 < -15) { return undef; } } return $1 . $2; } # no match return undef; } # Convert a KISS-frame into a TNC-2 compatible UI-frame. # Non-UI and non-pid-F0 frames are dropped. The KISS-frame # to be decoded should not have FEND (0xC0) characters # in the beginning or in the end. Returns a string # containing the TNC-2 frame (no CR and/or LF) or undef on error. sub kiss_to_tnc2($$) { my $self = shift; my $kissframe = shift @_; my $asciiframe = ""; my $dstcallsign = ""; my $callsigntmp = ""; my $digipeatercount = 0; # max. 8 digipeaters # perform byte unstuffing for kiss first $kissframe =~ s/\xdb\xdc/\xc0/g; $kissframe =~ s/\xdb\xdd/\xdb/g; # length checking _after_ byte unstuffing if (length($kissframe) < 16) { if ($self->{debug} > 0) { print STDERR "too short frame to be valid kiss\n"; } return undef; } # the first byte has to be zero (kiss data) if (ord(substr($kissframe, 0, 1)) != 0) { if ($self->{debug} > 0) { print STDERR "not a kiss data frame\n"; } return undef; } my $addresspart = 0; my $addresscount = 0; while (length($kissframe) > 0) { # in the first run this removes the zero byte, # in subsequent runs this removes the previous byte $kissframe = substr($kissframe, 1); my $charri = substr($kissframe, 0, 1); if ($addresspart == 0) { $addresscount++; # we are in the address field, go on # decoding it # switch to numeric $charri = ord($charri); # check whether this is the last # (0-bit is one) if ($charri & 1) { if ($addresscount < 14 || ($addresscount % 7) != 0) { # addresses ended too soon or in the # wrong place if ($self->{debug} > 0) { print STDERR "addresses ended too soon or in the wrong place in kiss frame\n"; } return undef; } # move on to control field next time $addresspart = 1; } # check the complete callsign # (7 bytes) if (($addresscount % 7) == 0) { # this is SSID, get the number my $ssid = ($charri >> 1) & 0xf; if ($ssid != 0) { # don't print zero SSID $callsigntmp .= "-" . $ssid; } # check the callsign for validity my $chkcall = kiss_checkcallsign($self, $callsigntmp); if (not(defined($chkcall))) { if ($self->{debug} > 0) { print STDERR "Invalid callsign in kiss frame, discarding\n"; } return undef; } if ($addresscount == 7) { # we have a destination callsign $dstcallsign = $chkcall; $callsigntmp = ""; next; } elsif ($addresscount == 14) { # we have a source callsign, copy # it to the final frame directly $asciiframe = $chkcall . ">" . $dstcallsign; $callsigntmp = ""; } elsif ($addresscount > 14) { # get the H-bit as well if we # are in the path part $asciiframe .= $chkcall; $callsigntmp = ""; if ($charri & 0x80) { $asciiframe .= "*"; } $digipeatercount++; } else { if ($self->{debug} > 0) { print STDERR "Internal error 1 in kiss_to_tnc2()\n"; } return undef; } if ($addresspart == 0) { # more address fields will follow # check that there are a maximum # of eight digipeaters in the path if ($digipeatercount >= 8) { if ($self->{debug} > 0) { print STDERR "Too many digipeaters in kiss packet, discarding\n"; } return undef; } $asciiframe .= ","; } else { # end of address fields $asciiframe .= ":"; } next; } # shift one bit right to get the ascii # character $charri >>= 1; $callsigntmp .= chr($charri); } elsif ($addresspart == 1) { # control field. we are only interested in # UI frames, discard others $charri = ord($charri); if ($charri != 3) { if ($self->{debug} > 0) { print STDERR "not UI frame, skipping\n"; } return undef; } #print " control $charri"; $addresspart = 2; } elsif ($addresspart == 2) { # PID #printf(" PID %02x data: ", ord($charri)); # we want PID 0xFO $charri = ord($charri); if ($charri != 0xf0) { if ($self->{debug} > 0) { print STDERR "PID not 0xF0, skipping\n"; } return undef; } $addresspart = 3; } else { # body $asciiframe .= $charri; } } # Ok, return whole frame return $asciiframe; } # Convert a TNC-2 compatible UI-frame into a KISS data # frame (single port KISS TNC). The frame will be complete, # i.e. it has FEND (0xC0) characters on both ends. If # conversion fails, return undef. sub tnc2_to_kiss($$) { my $self = shift; my $gotframe = shift @_; my $kissframe = chr(0); # kiss frame starts with byte 0x00 my $body; my $header; # separate header and body if ($gotframe =~ /^([A-Z0-9,*>-]+):(.+)$/o) { $header = $1; $body = $2; } else { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): separation into header and body failed\n"; } return undef; } # separate the sender, recipient and digipeaters my $sender; my $sender_ssid; my $receiver; my $receiver_ssid; my $digipeaters; if ($header =~ /^([A-Z0-9]{1,6})(-\d+|)>([A-Z0-9]{1,6})(-\d+|)(|,.*)$/o) { $sender = $1; $sender_ssid = $2; $receiver = $3; $receiver_ssid = $4; $digipeaters = $5; } else { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): separation of sender and receiver from header failed\n"; } return undef; } # Check SSID format and convert to number if (length($sender_ssid) > 0) { $sender_ssid = 0 - $sender_ssid; if ($sender_ssid > 15) { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): sender SSID ($sender_ssid) is over 15\n"; } return undef; } } else { $sender_ssid = 0; } if (length($receiver_ssid) > 0) { $receiver_ssid = 0 - $receiver_ssid; if ($receiver_ssid > 15) { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): receiver SSID ($receiver_ssid) is over 15\n"; } return undef; } } else { $receiver_ssid = 0; } # pad callsigns to 6 characters with space $sender .= ' ' x (6 - length($sender)); $receiver .= ' ' x (6 - length($receiver)); # encode destination and source for (my $i = 0; $i < 6; $i++) { $kissframe .= chr(ord(substr($receiver, $i, 1)) << 1); } $kissframe .= chr(0xe0 | ($receiver_ssid << 1)); for (my $i = 0; $i < 6; $i++) { $kissframe .= chr(ord(substr($sender, $i, 1)) << 1); } if (length($digipeaters) > 0) { $kissframe .= chr(0x60 | ($sender_ssid << 1)); } else { $kissframe .= chr(0x61 | ($sender_ssid << 1)); } # if there are digipeaters, add them if (length($digipeaters) > 0) { $digipeaters =~ s/,//; # remove the first comma # split into parts my @digis = split(/,/, $digipeaters); my $digicount = scalar(@digis); if ($digicount > 8 || $digicount < 1) { # too many (or none?!?) digipeaters if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): too many (or zero) digipeaters: $digicount\n"; } return undef; } for (my $i = 0; $i < $digicount; $i++) { # split into callsign, SSID and h-bit if ($digis[$i] =~ /^([A-Z0-9]{1,6})(-\d+|)(\*|)$/o) { my $callsign = $1 . ' ' x (6 - length($1)); my $ssid = 0; my $hbit = 0x00; if (length($2) > 0) { $ssid = 0 - $2; if ($ssid > 15) { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): digipeater nr. $i SSID ($ssid) invalid\n"; } return undef; } } if ($3 eq '*') { $hbit = 0x80; } # add to kiss frame for (my $k = 0; $k < 6; $k++) { $kissframe .= chr(ord(substr($callsign, $k, 1)) << 1); } if ($i + 1 < $digicount) { # more digipeaters to follow $kissframe .= chr($hbit | 0x60 | ($ssid << 1)); } else { # last digipeater $kissframe .= chr($hbit | 0x61 | ($ssid << 1)); } } else { if ($self->{debug} > 0) { print STDERR "tnc2_to_kiss(): digipeater nr. $i parsing failed\n"; } return undef; } } } # add frame type (0x03) and PID (0xF0) $kissframe .= chr(0x03) . chr(0xf0); # add frame body $kissframe .= $body; # perform KISS byte stuffing $kissframe =~ s/\xdb/\xdb\xdd/g; $kissframe =~ s/\xc0/\xdb\xdc/g; # add FENDs $kissframe = chr(0xc0) . $kissframe . chr(0xc0); return $kissframe; } # Accepts a TNC-2 format frame and extracts the original # sender callsign, destination callsign (without ssid) and # payload data for duplicate detection. Returns # sender, receiver and body on success, undef on error. # In the case of third party packets, always gets this # information from the innermost data. Also removes # possible trailing spaces to improve detection # (e.g. aprsd replaces trailing CRs or LFs in a packet with a space). sub aprs_duplicate_parts($$) { my $self = shift; my $packet = shift @_; # If this is a third party packet format, # strip out the outer layer and focus on the inside. # Do this several times in a row if necessary while (1) { if ($packet =~ /^[^:]+:\}(.*)$/io) { $packet = $1; } else { last; } } if ($packet =~ /^([A-Z0-9]{1,6})(-\d{1,2}|)>([A-Z0-9]{1,6})(-\d{1,2}|)(:|,[^:]+:)(.*)$/io) { my $source; my $destination; my $body = $6; if ($2 eq "") { # ssid 0 $source = $1 . "-0"; } else { $source = $1 . $2; } # drop SSID for destination $destination = $3; # remove trailing spaces from body $body =~ s/\s+$//; return ($source, $destination, $body); } return undef; } # Create an APRS object # Parameters: # 0th: $self # 1st: object name, has to be valid APRS object name, does not need to be space-padded # 2nd: object timestamp as a unix timestamp, or zero to use current time # 3rd: object latitude, decimal degrees # 4th: object longitude, decimal degrees # 5th: object symbol table (or overlay) and symbol code, two bytes # if the given symbole length is zero (""), use point (//) # 6th: object speed, -1 if non-moving (km/h) # 7th: object course, -1 if non-moving # 8th: object altitude, -10000 or less if not used # 9th: alive or dead object (0 == dead, 1 == alive) # 10th: compressed (1) or uncompressed (0) # 11th: position ambiguity (0..4) # 12th: object comment text # # Returns a body of an APRS object, i.e. ";OBJECTNAM*DDHHMM/DDMM.hhN/DDDMM.hhW$CSE/SPDcomments..." # or undef on error. sub make_object($$$$$$$$$$$$$) { my $self = shift; # FIXME: course/speed/altitude/compression not implemented my $name = shift @_; my $tstamp = shift @_; my $lat = shift @_; my $lon = shift @_; my $symbols = shift @_; my $speed = shift @_; my $course = shift @_; my $altitude = shift @_; my $alive = shift @_; my $usecompression = shift @_; my $posambiguity = shift @_; my $comment = shift @_; my $packetbody = ";"; # name if ($name =~ /^([\x20-\x7e]{1,9})$/o) { # also pad with whitespace $packetbody .= $1 . " " x (9 - length($1)); } else { return undef; } # dead/alive if ($alive == 1) { $packetbody .= "*"; } elsif ($alive == 0) { $packetbody .= "_"; } else { return undef; } # timestamp, hardwired for DHM my $aptime = make_timestamp($self, $tstamp, 0); if (not(defined($aptime))) { return undef; } else { $packetbody .= $aptime; } # actual position my $posstring = make_position($self, $lat, $lon, $speed, $course, $altitude, $symbols, $usecompression, $posambiguity); if (not(defined($posstring))) { return undef; } else { $packetbody .= $posstring; } # add comments to the end $packetbody .= $comment; return $packetbody; } # Create an APRS (UTC) six digit (DHM or HMS) # timestamp from a unix timestamp. # The first parameter is the unix timestamp to use, or zero to use # current time. Second parameter should be one for # HMS format, zero for DHM format. # Returns a 7-character string (e.g. "291345z") # or undef on error. sub make_timestamp($$$) { my $self = shift; my $tstamp = shift @_; my $tformat = shift @_; if ($tstamp == 0) { $tstamp = time(); } my ($day, $hour, $minute, $sec) = (gmtime($tstamp))[3,2,1,0]; if (not(defined($day))) { return undef; } my $tstring = ""; if ($tformat == 0) { $tstring = sprintf("%02d%02d%02dz", $day, $hour, $minute); } elsif ($tformat == 1) { $tstring = sprintf("%02d%02d%02dh", $hour, $minute, $sec); } else { return undef; } return $tstring; } # Create an APRS position for position/object/item # 0th: $self # 1st: latitude in decimal degrees # 2nd: longitude in decimal degrees # 3rd: speed in km/h, -1 == don't include # 4th: course in degrees, -1 == don't include. zero == unknown course, 360 == north # 5th: altitude in meters above mean sea level, -10000 or under == don't use # 6th: aprs symbols to use, first table/overlay and then code (two bytes). # if string length is zero (""), then use default # 7th: use compression (1) or not (0) # 8th: use amount (0..4) of position ambiguity. Note that position # ambiguity and compression can't be used at the same time # Returns a string such as "1234.56N/12345.67E/CSD/SPD" or in # compressed form "F*-X;n_Rv&{-A" or undef on error. sub make_position($$$$$$$$$) { my $self = shift; # FIXME: course/speed/altitude are not supported yet, # neither is compressed format or position ambiguity my $lat = shift @_; my $lon = shift @_; my $speed = shift @_; my $course = shift @_; my $altitude = shift @_; my $symbols = shift @_; my $usecompression = shift @_; my $posambiguity = shift @_; if ($lat < -89.99999 || $lat > 89.99999 || $lon < -179.99999 || $lon > 179.99999) { # invalid location return undef; } my $symboltable = ""; my $symbolcode = ""; if (length($symbols) == 0) { $symboltable = "/"; $symbolcode = "/"; } elsif ($symbols =~ /^([\/\\A-Z0-9])([\x21-\x7b\x7d])$/o) { $symboltable = $1; $symbolcode = $2; } else { return undef; } if ($usecompression == 1) { my $latval = 380926 * (90 - $lat); my $lonval = 190463 * (180 + $lon); my $latstring = ""; my $lonstring = ""; for (my $i = 3; $i >= 0; $i--) { # latitude character my $value = int($latval / (91 ** $i)); $latval = $latval % (91 ** $i); $latstring .= chr($value + 33); # longitude character $value = int($lonval / (91 ** $i)); $lonval = $lonval % (91 ** $i); $lonstring .= chr($value + 33); } # encode overlay character if it is a number $symboltable =~ tr/0-9/a-j/; # FIXME: no speed/course/altitude/radiorange encoding my $retstring = $symboltable . $latstring . $lonstring . $symbolcode; if ($speed >= 0 && $course > 0 && $course <= 360) { # In APRS spec unknown course is zero normally (and north is 360), # but in compressed aprs north is zero and there is no unknown course. # So round course to nearest 4-degree section and remember # to do the 360 -> 0 degree transformation. my $cval = int(($course + 2) / 4); if ($cval > 89) { $cval = 0; } $retstring .= chr($cval + 33); # speed is in knots in compressed form. round to nearest integer my $speednum = int((log(($speed / 1.852) + 1) / log(1.08)) + 0.5); if ($speednum > 89) { # limit top speed $speednum = 89; } $retstring .= chr($speednum + 33) . "A"; } else { $retstring .= " A"; } return $retstring; # normal position format } else { # convert to degrees and minutes my $isnorth = 1; if ($lat < 0.0) { $lat = 0 - $lat; $isnorth = 0; } my $latdeg = int($lat); my $latmin = sprintf("%04d", ($lat - $latdeg) * 6000); my $latstring = sprintf("%02d%02d.%02d", $latdeg, substr($latmin, 0, 2), substr($latmin, 2, 2)); if ($posambiguity > 0 || $posambiguity <= 4) { # position ambiguity if ($posambiguity <= 2) { # only minute decimals are blanked $latstring = substr($latstring, 0, 7 - $posambiguity) . " " x $posambiguity; } elsif ($posambiguity == 3) { $latstring = substr($latstring, 0, 3) . " . "; } elsif ($posambiguity == 4) { $latstring = substr($latstring, 0, 2) . " . "; } } if ($isnorth == 1) { $latstring .= "N"; } else { $latstring .= "S"; } my $iseast = 1; if ($lon < 0.0) { $lon = 0 - $lon; $iseast = 0; } my $londeg = int($lon); my $lonmin = sprintf("%04d", ($lon - $londeg) * 6000); my $lonstring = sprintf("%03d%02d.%02d", $londeg, substr($lonmin, 0, 2), substr($lonmin, 2, 2)); if ($posambiguity > 0 || $posambiguity <= 4) { # position ambiguity if ($posambiguity <= 2) { # only minute decimals are blanked $lonstring = substr($lonstring, 0, 8 - $posambiguity) . " " x $posambiguity; } elsif ($posambiguity == 3) { $lonstring = substr($lonstring, 0, 4) . " . "; } elsif ($posambiguity == 4) { $lonstring = substr($lonstring, 0, 3) . " . "; } } if ($iseast == 1) { $lonstring .= "E"; } else { $lonstring .= "W"; } my $retstring = $latstring . $symboltable . $lonstring . $symbolcode; # add course/speed, if given if ($speed >= 0 && $course >= 0) { # convert speed to knots $speed = $speed / 1.852; if ($speed > 999) { $speed = 999; # maximum speed } if ($course > 360) { $course = 0; # unknown course } $retstring .= sprintf("%03d/%03d", $course, $speed); } if ($altitude > -10_000) { $retstring .= sprintf("/A=%06d", $self_alt / 0.3048) } return $retstring; } } # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ # Below is stub documentation for your module. You'd better edit it! =head1 NAME APRS::Parser - Perl extension for parsing APRS packets =head1 SYNOPSIS use APRS::Parser qw(parseaprs); my $AParser = new APRS::Parser; my $aprspacket = 'OH2RDP>BEACON,OH2RDG*,WIDE:!6028.51N/02505.68E#PHG7220/RELAY,WIDE, OH2AP Jarvenpaa'; my %packetdata; my $retval = $AParser->parseaprs($aprspacket, \%packetdata, 1); if ($retval == 1) { # decoding ok, do something with the data while (my ($key, $value) = each(%packetdata)) { ... } } =head1 ABSTRACT This module in an incomplete APRS parser. It parses normal, mic-e and compressed location packets, NMEA location packets, objects and items. =head1 DESCRIPTION This module in an incomplete APRS parser. It parses normal, mic-e and compressed location packets, NMEA location packets, objects and items. APRS features specifically NOT handled by this module: - messages, bulletins, announcements (partially) - weather reports - special objects (area, signpost, etc) - network tunneling/third party packets - direction finding - telemetry - station capability queries - status reports (partially) - user defined data formats This module is based (on those parts that are implemented) on APRS specification 1.0.1. This module requires a reasonably recent Date::Calc module. =head2 EXPORT None by default. =head1 SEE ALSO APRS specification 1.0.1, http://www.tapr.org/tapr/html/Faprswg.html =head1 AUTHOR Tapio Sokura, OH2KKU Etapio.sokura@iki.fiE =head1 COPYRIGHT AND LICENSE Copyright 2005 by Tapio Sokura This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut