use IO::Socket::INET; use Time::Local; use LWP::Simple; use Switch; use Net::FTP; our $MySocket = new IO::Socket::INET->new(LocalPort=>9871, Proto=>'udp'); # stuff for time conversion our @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); # --------------------------------------------------------------------------------------- # DXCC Script borrowed from YFK-Log sub wpx { my ($prefix,$a,$b,$c); # First check if the call is in the proper format, A/B/C where A and C # are optional (prefix of guest country and P, MM, AM etc) and B is the # callsign. Only letters, figures and "/" is accepted, no further check if the # callsign "makes sense". if ($_[0] =~ /^((\d|[A-Z])+\/)?((\d|[A-Z]){3,})(\/(\d|[A-Z])+)?$/) { # Now $1 holds A (incl /), $3 holds the callsign B and $5 has C # We save them to $a, $b and $c respectively to ensure they won't get # lost in further Regex evaluations. ($a, $b, $c) = ($1, $3, $5); if ($a) { chop $a }; # Remove the / at the end if ($c) { $c = substr($c,1,)}; # Remove the / at the beginning # In some cases when there is no part A but B and C, and C is longer than 2 # letters, it happens that $a and $b get the values that $b and $c should # have. This often happens with liddish callsign-additions like /QRP and # /LGT, but also with calls like DJ1YFK/KP5. ~/.yfklog has a line called # "lidadditions", which has QRP and LGT as defaults. This sorts out half of # the problem, but not calls like DJ1YFK/KH5. This is tested in a second # try: $a looks like a call (.\d[A-Z]) and $b doesn't (.\d), they are # swapped. This still does not properly handle calls like DJ1YFK/KH7K where # only the OP's experience says that it's DJ1YFK on KH7K. if (!$c && $a && $b) { # $a and $b exist, no $c if ($b =~ /$lidadditions/) { # check if $b is a lid-addition $b = $a; $a = undef; # $a goes to $b, delete lid-add } elsif (($a =~ /\d[A-Z]+$/) && ($b =~ /\d$/)) { # check for call in $a } } # *** Added later *** The check didn't make sure that the callsign # contains a letter. there are letter-only callsigns like RAEM, but not # figure-only calls. if ($b =~ /^[0-9]+$/) { # Callsign only consists of numbers. Bad! return undef; # exit, undef } # Depending on these values we have to determine the prefix. # Following cases are possible: # # 1. $a and $c undef --> only callsign, subcases # 1.1 $b contains a number -> everything from start to number # 1.2 $b contains no number -> first two letters plus 0 # 2. $a undef, subcases: # 2.1 $c is only a number -> $a with changed number # 2.2 $c is /P,/M,/MM,/AM -> 1. # 2.3 $c is something else and will be interpreted as a Prefix # 3. $a is defined, will be taken as PFX, regardless of $c if ((not defined $a) && (not defined $c)) { # Case 1 if ($b =~ /\d/) { # Case 1.1, contains number $b =~ /(.+\d)[A-Z]*/; # Prefix is all but the last $prefix = $1; # Letters } else { # Case 1.2, no number $prefix = substr($b,0,2) . "0"; # first two + 0 } } elsif ((not defined $a) && (defined $c)) { # Case 2, CALL/X if ($c =~ /^(\d)$/) { # Case 2.1, number $b =~ /(.+\d)[A-Z]*/; # regular Prefix in $1 # Here we need to find out how many digits there are in the # prefix, because for example A45XR/0 is A40. If there are 2 # numbers, the first is not deleted. If course in exotic cases # like N66A/7 -> N7 this brings the wrong result of N67, but I # think that's rather irrelevant cos such calls rarely appear # and if they do, it's very unlikely for them to have a number # attached. You can still edit it by hand anyway.. if ($1 =~ /^([A-Z]\d)\d$/) { # e.g. A45 $c = 0 $prefix = $1 . $c; # -> A40 } else { # Otherwise cut all numbers $1 =~ /(.*[A-Z])\d+/; # Prefix w/o number in $1 $prefix = $1 . $c;} # Add attached number } elsif ($c =~ /$csadditions/) { $b =~ /(.+\d)[A-Z]*/; # Known attachment -> like Case 1.1 $prefix = $1; } elsif ($c =~ /^\d\d+$/) { # more than 2 numbers -> ignore $b =~ /(.+\d)[A-Z]*/; # see above $prefix = $1; } else { # Must be a Prefix! if ($c =~ /\d$/) { # ends in number -> good prefix $prefix = $c; } else { # Add Zero at the end $prefix = $c . "0"; } } } elsif (defined $a) { # $a contains the prefix we want if ($a =~ /\d$/) { # ends in number -> good prefix $prefix = $a } else { # add zero if no number $prefix = $a . "0"; } } # In very rare cases (right now I can only think of KH5K and KH7K and FRxG/T # etc), the prefix is wrong, for example KH5K/DJ1YFK would be KH5K0. In this # case, the superfluous part will be cropped. Since this, however, changes the # DXCC of the prefix, this will NOT happen when invoked from with an # extra parameter $_[1]; this will happen when invoking it from &dxcc. if (($prefix =~ /(\w+\d)[A-Z]+\d/) && (not defined $_[1])) { $prefix = $1; } return $prefix; } else { return undef; } # no proper callsign received. } # wpx ends here ############################################################################## # # &dxcc determines the DXCC country of a given callsign using the cty.dat file # provided by K1EA at http://www.k1ea.com/cty/cty.dat . # An example entry of the file looks like this: # # Portugal: 14: 37: EU: 38.70: 9.20: 0.0: CT: # CQ,CR,CR5A,CR5EBD,CR6EDX,CR7A,CR8A,CR8BWW,CS,CS98,CT,CT98; # # The first line contains the name of the country, WAZ, ITU zones, continent, # latitude, longitude, UTC difference and main Prefix, the second line contains # possible Prefixes and/or whole callsigns that fit for the country, sometimes # followed by zones in brackets (WAZ in (), ITU in []). # # If this happens, the zone information is saved in the %zone hash (key = DXCC, # value = zones) and before the DXCC-Array is returned checked and (if a # different zone is stored) changed in the array. # # This sub checks the callsign against this list and the DXCC in which # the best match (most matching characters) appear. This is needed because for # example the CTY file specifies only "D" for Germany, "D4" for Cape Verde. # Also some "unusual" callsigns which appear to be in wrong DXCCs will be # assigned properly this way, for example Antarctic-Callsigns. # # The list is read into a hash table, the key contains the line with the # country-information, the value contains all possible prefixes and zone # information. # # Then the callsign (or what appears to be the part determining the DXCC if # there is a "/" in the callsign) will be checked against the list of prefixes # and the best matching one will be taken as DXCC. # # The return-value will be an array ("Country Name", "WAZ", "ITU", "Continent", # "latitude", "longitude", "UTC difference", "DXCC"). # ############################################################################### sub dxcc { # my %dxcc; # DXCC hash, key = country info, value = prefixes # NEW: %dxcc hash created at the start of program, no need to read it # again and again. my $bestmatch=""; # Best matching DXCC (~ Key) so far my $bestcount=0; # Number of characters that matched my @prefixes; # Prefixes for each DXCC will go here my $testpfx; # Prefix to test my $callsign; # this will be the callsign or part of it) to test my $zones; # temporary zones my %zones; # saves zones if differ from regular, key is DXCC string # will be used instead of regular zones at the end my @dxcc; # returned array with DXCC information # Now we check if the callsign includes a slash, because that could change the # DXCC. For example PA/DJ1YFK is not a problem, but DJ1YFK/TF is, so it neds to # be changed to the corresponding prefix, TF0 to get the DXCC. There is one # exception that I am aware of, which is OH/DJ1YFK which would be changed to # OH0 and get Aland islands which is wrong. Thus there is a small check for OH/ # and /OH[1-9]? first. # Also 3D2- and FO0-Calls are troublesome, because those are not always # unambiguosly assigned to a DXCC. When they match 3D2C or 3D2R or 3D2../R, # they will be assigned to a matching DXCC, if not, they'll be Fiji, unless # they apear as full calls in the list. # KH5K is also troublesome, so if a call contains it, no matter what else, it # will be assigned to Kingman Reef. Same with Kure KH7K. # Finally, FR-Calls can be from different DXCCs, depending on their first # letter of the suffix. cty.dat has this as FR/G, FR/T etc, which will be # changed to ^FR\dG, ^FR\dT etc. later during the check. #print "Sub value:\t" . $_[0] . "\n"; if ($_[0] =~ /(^OH\/)|(\/OH[1-9]?$)/) { # non-Aland prefix! $callsign = "OH"; # make callsign OH = finland } elsif ($_[0] =~ /(^3D2R)|(^3D2.+\/R)/) { # seems to be from Rotuma $callsign = "3D2RR"; # will match with Rotuma } elsif ($_[0] =~ /^3D2C/) { # seems to be from Conway Reef $callsign = "3D2CR"; # will match with Conway } elsif ($_[0] =~ /KH5K/) { # seems to be from Kingman Reef $callsign = "KH5K"; # will match with Kingman! } elsif ($_[0] =~ /KH7K/) { # seems to be from Kure $callsign = "KH7K"; # will match with Kure } elsif ($_[0] =~ /\//) { # check if the callsign has a "/" $callsign = &wpx($_[0],1); # use the wpx prefix instead, which may # intentionally be wrong, see &wpx! } else { # else: normal callsign $callsign = $_[0]; # use it for checking! } while (($key, $value) = each %dxcc) { # iterate through hash table if ($key && $value) { # valid key/value pair $value =~ s/\s//g; # remove whitespaces @prefixes = split(/[,;]/, $value); # split prefixes foreach $testpfx (@prefixes) { # iterate through prefixes $testpfx =~ s/^(\w+)([\[\(].+)/$1/g; # remove zones, if any undef $zones; # remove old zone info if (defined $2) { # When zones cropped $zones = $2; # remember zone } $testpfx =~ s/FR\/([A-Z])/FR\\d$1/g; # special FRs, see above if ($callsign =~ /^$testpfx/) { # if call matches a prefix if (length($&) > $bestcount) { # better than prev. match $zones{$key} = $zones if defined $zones; # save Z if differs $bestmatch = $key; # save best DXCC key $bestcount = length($&); # save how many matched } } } } } # while ends here, all DXCCs checked, best DXCC in $bestmatch # Possibly there was no DXCC matching at all, for example for a callsign like # QQ1ABC. In this case an array with questionmarks is returned unless ($bestmatch eq "") { @dxcc = split(/\s*:\s*/, $bestmatch); # Put the dxcc information into an # array by splitting, cut off white # space also if (defined $zones{$bestmatch}) { # there is a different zone saved $zones{$bestmatch} =~ /(\((\d+)\))?(\[(\d+)\])?/; # WAZ in $2, ITU in $4 $dxcc[1] = $2 if defined $2; $dxcc[2] = $4 if defined $4; } } else { # not a valid DXCC. return qw/? ? ? ? ? ? ? ?/; } # cty.dat has special entries for WAE countries which are not separate DXCC # countries. Those start with a "*", for example *TA1. Those have to be changed # to the proper DXCC. Since there are opnly a few of them, it is hardcoded in # here. if ($dxcc[7] =~ /^\*/) { # WAE country! if ($dxcc[7] eq '*TA1') { $dxcc[7] = "TA" } # Turkey if ($dxcc[7] eq '*4U1V') { $dxcc[7] = "OE" } # 4U1VIC is in OE.. if ($dxcc[7] eq '*GM/s') { $dxcc[7] = "GM" } # Shetlands if ($dxcc[7] eq '*IG9') { $dxcc[7] = "I" } # African Italy if ($dxcc[7] eq '*IT9') { $dxcc[7] = "I" } # Sicily if ($dxcc[7] eq '*JW/b') { $dxcc[7] = "JW" } # Bear Island } # CTY.dat uses "/" in some DXCC names, but I prefer to remove them, for example # VP8/s ==> VP8s etc. $dxcc[7] =~ s/\///g; return @dxcc; } # dxcc ends here open DXCC, "cty.dat" or die "Error reading cty.dat country file: $!"; our %dxcc; # DXCC hash my $key; # This will temporarily store the key my $value; # This will temporarily store the value while (my $line = ) { # Read line into $line if ($line =~ /^\w/) { # New country starts if ($key && $value) { # When old DXCC exists, $dxcc{$key} = $value; # save it to hash } $value = ""; # delete old value $key = $line; # New hash-key will be this line } else { # No new DXCC, but prefixes $value .= $line; # attach prefix-line to value } } # while ends here, all lines read and stored in hash print "\nDXCC table loaded...\n"; close DXCC; # good bye # --------------------------------------------------------------------------------------- sub getUDPData() { $MySocket->recv($packet,128); chomp ($packet); if ($packet =~ /^STATUS:/) { $mode = substr($packet,22,1); $band = substr($packet,20,1); $qrg = substr($packet,29,6); $qrg =~ s/ //g; if ($mode == 0) {$mode = "CW";} else {$mode = "SSB";} switch ($band) { case (1) {$band = "160m";} case (2) {$band = "80m";} case (3) {$band = "40m";} case (4) {$band = "30m";} case (5) {$band = "20m";} case (6) {$band = "17m";} case (7) {$band = "15m";} case (8) {$band = "12m";} case (9) {$band = "10m";} else {$band = "Unknown";} } $qrg = $qrg / 10000; print "\nSTATUS: Band: " . $band . " Mode: " . $mode . " QRG: " . $qrg . "MHz"; } elsif ($packet =~ /^ADDQSO/) { $packet =~ m/^(ADDQSO: \")(\w+)(\" \"\" )(\d+)( )(\d+)( )(\d+)( )(\d+)( )(\d+)( )(\d+)( )(\d+)( )(\d+)( \")([A-Z0-9\/]+)(\" \")(\d+)(\" \")(\d+)/; # Array values: # 0 - Raw data # 1 - Station name # 2 - Timestamp # 3 - Freq # 4 - Mode char # 5 - Band char # 6 - QSO Num # 7 - Callsign $qsoinfo[0] = $packet; $qsoinfo[1] = $2; $qsoinfo[2] = $4; $qsoinfo[3] = $6; $qsoinfo[4] = $8; $qsoinfo[5] = $10; $qsoinfo[6] = $18; $qsoinfo[7] = $20; $qsoinfo[8] = $22; $qsoinfo[9] = $24; $qsoinfo[3] = $qsoinfo[3] / 10000; if ($qsoinfo[4] == 0) {$qsoinfo[4] = "CW";} else {$qsoinfo[4] = "SSB";} ($second, $minute, $hour, $dayOfMonth, $month, $yearOffset, $dayOfWeek, $dayOfYear, $daylightSavings) = gmtime($qsoinfo[2]); $year = 1900 + $yearOffset; $theTime = "$dayOfMonth $months[$month] $year $hour:$minute:$second"; $thiscall = $qsoinfo[7]; @dxccresult = dxcc($thiscall); print "\nNEWQSO: " . $qsoinfo[6] . " Freq: " . $qsoinfo[3] . " " . $qsoinfo[4] . " Call: " . $qsoinfo[7] . " Time: " . $theTime; print " Country: " . $dxccresult[0]; } elsif ($packet =~ /^HELLO/) { $station = substr($packet,8,4); print "\n ---- " . $station . " has connected to the Win-Test network! ---- "; } else { print "\nOther: " . $packet; } ($second, $minute, $hour, $dayOfMonth, $month, $yearOffset, $dayOfWeek, $dayOfYear, $daylightSavings) = gmtime(); $timeNow = $dayOfMonth . " " . $months[$month] . " " . ($yearOffset+1900) . " $hour:$minute:$second UTC"; open XML, ">shacklive.xml" or die "Error writing to shacklive.xml file: $!"; print XML ""; print XML "\n"; print XML "\n"; print XML "\n" . $timeNow . ""; print XML "\n" . $qrg . ""; print XML "\n" . $mode . ""; print XML "\n"; print XML "\n"; print XML "\n"; print XML "\n" . $qsoinfo[3] . ""; print XML "\n" . $qsoinfo[4] . ""; print XML "\n" . $qsoinfo[7] . ""; print XML "\n" . $dxccresult[0] . ""; print XML "\n" . $theTime . ""; print XML "\n"; print XML "\n"; print XML "\n"; close(XML); ## ====================== Change host, port, user, password and path below as necessary ======================================== #Do FTP Upload $ftp = Net::FTP->new("[host]:[port]", Debug => 0) or die "Cannot connect to host: $@"; $ftp->login("[user]",'[password]') or die "Cannot login ", $ftp->message; $ftp->cwd("[path]"); $ftp->put("shacklive.xml"); $ftp->quit; getUDPData(); } print "Ready\n"; getUDPData();