yfklog/yfksubs.pl

#!/usr/bin/perl -w

# identation looks best with tw=4

# Several subroutines for yfklog, a amateur radio logbook software 
# 
# Copyright (C) 2005-2019  Fabian Kurz, DJ1YFK
#
# This program is free software; you can redistribute it and/or modify 
# it under the terms of the GNU General Public License as published by 
# the Free Software Foundation; either version 2 of the License, or 
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, 
# but WITHOUT ANY WARRANTY; without even the implied warranty of 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License 
# along with this program; if not, write to the 
# Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
# Boston, MA 02111-1307, USA. 

package yfksubs;

require Exporter;
@ISA = qw(Exporter);

@EXPORT = qw( wpx dxcc makewindow clearinputfields qsotofields saveqso readw
lastqsos callinfo getdate gettime splashscreen choseqso getqso chosepqso
entrymask fkeyline winfomask selectlist askbox toggleqsl onlinelog
preparelabels labeltex emptyqslqueue adifexport ftpupload adifimport getlogs
changemycall newlogtable oldlogtable choseeditqso geteditqso editw updateqso checkdate
awards statistics qslstatistics editdb editdbw savedbedit lotwimport
databaseupgrade xplanet queryrig tableexists changeconfig readsubconfig
connectdb connectrig jumpfield receive_qso tqslsign getlotwlocations 
getlotwstartdate downloadlotw redraw create_windows rundxc getch2 waitkey
senddxc);

use strict;
use POSIX;                # needed for acos in distance/direction calculation
use Curses;
use Net::FTP;
use IO::Socket;
use DBI;
use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_CREAT);
use LWP::UserAgent ();
use Net::Telnet ();

use threads;
use threads::shared;

my $havehamdb = eval "require Ham::Callsign::DB;";
my $hamdb;
if ($havehamdb) {
    require Ham::Callsign::DB;
    $hamdb = new Ham::Callsign::DB();
    $hamdb->initialize_dbs();
}


# We load the default values for some variables that can be changed in .yfklog

my $lidadditions="^QRP\$|^LGT\$";
my $csadditions="(^P\$)|(^M{1,2}\$)|(^AM\$)";
our $dbserver = '';                                # Standard MySQL server
our $dbport = 3306;                                # standard MySQL port    
our $dbuser = "";                                # DB username
our $dbpass = "";                                # DB password
our $dbname = "";                                # DB name
my $dbh;
our $onlinedata = "`CALL`, `DATE`, round(`BAND`,2), `MODE`";
                                                # Fields for online search log
our $ftpserver = "127.0.0.1";                    # ftp for online log / backup
my $ftpport   = "21";                            # ftp server port
my $ftpuser   = "";                                # ftp user
my $ftppass   = "";                                # ftp passwd
my $ftpdir    = "log/";                            # ftp directory
our $mycall    = "L1D";                            # too stupid to set it? :-))
our $dpwr      = "100";                            # default PWR
our $dqslsi    = "N";                            # def. QSL-s for import
our $dqsls    = "N";                            # def. QSL-s 
our $operator  = "";                                # default OP.
our $lat1      = "52";                            # Latitude of own station
our $lon1      = "-8";                            # Longitude of own station
our $bands = '160 80 40 30 20 17 15 12 10 2';    # bands for award purposes
our $modes = 'CW SSB';                            # modes for award purposes
our $screenlayout=0;                                # screen layout, 0 or 1
our $rigmodel = 0;                                # for hamlib
our $rigpath = '/dev/ttyS0';                        # for hamlib
my $rig=0;
my $dband = '80';
my $dmode = 'CW';
our $checklogs = '';                            # add. logs to chk fr prev QSOs
our $lotwdetails='0';                            # LOTW import details?
our $autoqueryrig='0';                            # Query rig at new QSO?
our $directory='/tmp/';                            # where to look for stuff
our $prefix="/usr";                                # may be changed by 'make'
my $db='';                                        # sqlite or mysql?
our $fieldorder=                                    # TAB/Field order.
'CALL DATE TON TOFF BAND MODE QTH NAME QSLS QSLR RSTS RSTR REM PWR';
my @fieldorder = split(/\s+/, $fieldorder);
our $usehamdb = 0;
our $askme=0;                        # ask before clearing QSOs etc
our $logsort="N";                                # Order of log display
our $prevsort="D";                                # Order of prev. QSOs
our $browser='dillo';
our $hamlibtcpport = 4532;
our $lotwlocation="";                 # LoTW station locations in format: CALL:location,CALL:location
our $lotwuser="";                     # Username for automatic LoTW download
our $lotwpass="";                     # Password for automatic LoTW download
our $dxchost="";                      # dx cluster host
our $dxcport=0;                       # dx cluster telnet port
our $dxccall="";                      # dx cluster login callsign
our $dxcmode="N";                     # dx cluster mode. N = normal, B = bandmap

my $db_keepalive = time;

my @dxspots;    # DX cluster thread -> main thread (DX spots)
my @dxlines;    # DX cluster thread -> main thread (raw lines)
my @dxinput;    # main thread -> DX cluster thread (keyboard input lines)
share(@dxspots);
share(@dxlines);
share(@dxinput);

sub redraw {
    endwin();
    initscr();
    getmaxyx($main::row, $main::col);
    $main::row-- if ($main::row % 2);

    &create_windows();
}

sub create_windows {

    my $row = $main::row;
    my $col = $main::col;

    # DX cluster window. only create this if we have enough space
    # (at least 80 + 25 columns for one bandmap column)
    if ($col >= 105) {
        $main::wdxc = &makewindow($row,$col-80,0,80,5);
    }

    # GENERAL WINDOWS, always visible
    $main::whead  = &makewindow(1,80,0,0,2);      # head window
    $main::whelp  = &makewindow(1,80,$row-1,0,2);     # help window

    # LOGGING MODE WINDOWS  ($status = 1)
    $main::winput = &makewindow(3,80,1,0,1);      # Input Window
    $main::winfo  = &makewindow(3,80,4,0,2);      # DXCC/Info Window

    # depending on $screenlayout, the windows for previous QSOs and the recent
    # logbook are either next to each other or on top of each other.
    if ($screenlayout==0) {                     # original YFKlog style
        $main::wlog   = &makewindow(16,30,7,0,3);     # Logbook
        $main::wqsos  = &makewindow(16,50,7,30,4);    # prev. QSOs window
    }
    elsif ($screenlayout==1) {                  # more info, smaller windows
        # 8 lines are used for other stuff, so we have ($row-8)/2 lines left for
        # each window
        $main::wlog   = &makewindow(($row-8)/2,80,7,0,3);     # Logbook
        $main::wqsos  = &makewindow(($row-8)/2,80,7+($row-8)/2,0,4);      # prev. QSOs window
    }

    # EDIT / SEARCH MODE WINDOWS ($status = 10)
    $main::wedit      = &makewindow(5,80,1,0,1);        # Edit Window
    $main::weditlog   = &makewindow(($row-7),80,6,0,4); # Search results

    $main::wmain = &makewindow($row-2,80,1,0,4);        # general purpose window

}

# connect to a DX cluster (if configured)
sub rundxc {
    my %bcfh = ();   # band-call-> freq hash
    my %bcth = ();   # band-call-> timestamp hash

    my $rows = $main::row;

    # each column in the bandmap requires 25 characters. from the total number
    # of available columns, 80 are already used by the logger, so we can
    # calculate the number of bandmap columns as follows: 
    my $dxccols = int(($main::col - 80) / 25);

    my $maxspots = $rows * $dxccols;

    # DX cluster not configured? Exit thread.
    unless ($dxchost =~ /\./ && $dxcport =~ /^\d+$/ && $dxccall ne "") {
        return;
    }

    while (1) {
        @dxspots = ();
        push @dxspots, " Connecting to '$dxchost:$dxcport'";
        push @dxspots, " with callsign '$dxccall'.";

        my $t = new Net::Telnet (Timeout => 600, Port => $dxcport, Prompt => '/./');
        $t->open($dxchost);
        $t->print("$dxccall\n");

        sleep(3);

        while (1) {

            # push keyboard input to cluster
            foreach my $l (@dxinput) {
                $t->print($l);
            }
            @dxinput = ();

            my $line = $t->getline();
            chomp($line);

            push @dxlines, $line;
            if ($#dxlines > $rows) { shift @dxlines; }

            if ($line =~ /CW/ and $line =~ /DX de .*:\s+([0-9.]+)\s+([A-Z0-9\/]+)/) {
                my $dxcall = $2;
                my $freq = $1;
                $freq =~ s/(\.\d)\d$/$1/g;
                my $dxband = &freq2band($freq);

                $bcfh{$dxband}{$dxcall} = $freq;
                $bcth{$dxband}{$dxcall} = time;

                # update the @dxspots array
                &updatedxc(\%bcfh, \%bcth, $maxspots);
            } 

        } # while 1 (when connected)
    } # while(1) outter loop
}

# push bandmap entries in shared array @dxspots. it will be 
# printed on screen by showdxc() from the main thread
sub updatedxc {
    my $fr = shift; # reference to %bcfh
    my $tr = shift; # reference to %bcth
    my $maxspots = shift;

    my $c = 0;
    my $timeout = 300;

    @dxspots = ();

    do {
        $c = 0;
        for my $band ( sort { $b <=> $a } keys %{ $tr } ) {
            if ($c) {
                push @dxspots, "";
                $c++;
            }
            for my $call ( sort { $fr->{$band}{$a} <=> $fr->{$band}{$b} } keys %{ $fr->{$band} } ) {
                push @dxspots, sprintf("%7.1f  %s", $fr->{$band}{$call}, $call);
                $c++;

                # remove spots that are older than 5 minutes
                if ((time - $tr->{$band}{$call}) > $timeout) {
                    delete($fr->{$band}{$call});
                    delete($tr->{$band}{$call});
                }
            }
        }

        # bandmap full? reduce timeout gradually until we have resolved
        # the overflow.
        $timeout -= 1;
    } while ($c >= $maxspots);

    $timeout = 300;
}

# print dx cluster output or bandmap in wdxc window. 
# this is called from the main thread (getch2, on keyboard timeout)

sub showdxc {
    my $win = $main::wdxc;
    my $rows = $main::row;

    return unless (defined($win));

    # each column in the bandmap requires 25 characters. from the total number
    # of available columns, 80 are already used by the logger, so we can
    # calculate the number of bandmap columns as follows: 
    my $dxccols = int(($main::col - 80) / 25);
    addstr($win, 0, 0, " "x($dxccols * 50 * $rows));

    # "normal" dx cluster mode
    if ($dxcmode eq "N") {
        my $row = 0;
        foreach my $line (@dxlines) {
            addstr($win, $row++ , 1, $line);
        }
    }
    elsif ($dxcmode eq "B") {
        my $c = 0;
        foreach my $line (@dxspots) {
            # we split into columns with a width of 25                    
            my $mrow = $c % $rows;
            my $mcol = int($c / $rows);
            next if ($mcol >= $dxccols); # don't swap into a non-existing column
            next if ($mrow == 0 && $line eq ""); # don't print empty line on top
            addstr($win, $mrow , 1 + $mcol*25, $line);
            $c++;
        }
    }

    refresh($win);

    # a little trick to get the cursor back to the entry field
    # where it was before: push a character into the keyboard
    # input queue that will be ignored 
    ungetchar("~");
}

sub senddxc {
    my $line = shift;
    push @dxinput, $line;
}


# We read the configuration file .yfklog.

sub readsubconfig {

unless (-e "$ENV{HOME}/.yfklog/config") { return 0 };

open CONFIG, "$ENV{HOME}/.yfklog/config" or die "Cannot open configuration file. Error: $!";

while (defined (my $line = <CONFIG>))   {            # Read line into $line
    if ($line =~ /^lidadditions=(.+)/) {            # We read the $lidadditions
        $lidadditions = $1;
    }
    elsif ($line =~ /^csadditions=(.+)/) {            # We read the $csadditions
        $csadditions = $1;
    }
    elsif ($line =~ /^dbserver=(.+)/) {                # We read the MySQL Server
            $dbserver= $1;
    }
    elsif ($line =~ /^dbport=(.+)/) {                # We read the Server's port
            $dbport = $1;
    }
    elsif ($line =~ /^mycall=(.+)/) {                # We read the own call
            $mycall = "\L$1";
    }
    elsif ($line =~ /^dbuser=(.+)/) {                # We read the db Username
            $dbuser = $1;
    }
    elsif ($line =~ /^dbpass=(.+)/) {                # We read the db passwd
            $dbpass = $1;
    }
    elsif ($line =~ /^dbname=(.+)/) {                # We read the db name
            $dbname= $1;
    }
    elsif ($line =~ /^onlinedata=(.+)/) {            # We read the columns for
            $onlinedata= $1;                        # the online logbook
    }
    elsif ($line =~ /^ftpserver=(.+)/) {            # We read the ftp server
            $ftpserver= $1;
    }
    elsif ($line =~ /^ftpport=(.+)/) {                # We read the ftp port
            $ftpport= $1;
    }
    elsif ($line =~ /^ftpuser=(.+)/) {                # We read the ftp username
            $ftpuser= $1;
    }
    elsif ($line =~ /^ftppass=(.+)/) {                # We read the ftp password
            $ftppass= $1;
    }
    elsif ($line =~ /^ftpdir=(.+)/) {                # We read the ftp directory 
            $ftpdir= $1;
    }
    elsif ($line =~ /^dpwr=(.+)/) {                    # We read the default PWR
            $dpwr = $1;
    }
    elsif ($line =~ /^dqslsi=(.+)/) {                # def. QSL-sent fr QSO imp.
            $dqslsi= $1;
    }
    elsif ($line =~ /^dqsls=(.+)/) {                # def. QSL-sent
            $dqsls= $1;
    }
    elsif ($line =~ /^lat=(.+)/) {                    # Own latitude
            $lat1= $1;
    }
    elsif ($line =~ /^lon=(.+)/) {                    # Own longitude
            $lon1= $1;
    }
    elsif ($line =~ /^awardbands=(.+)/) {            # bands for award purposes
            $bands= $1;
    }
    elsif ($line =~ /^awardmodes=(.+)/) {            # modes for award purposes
            $modes= $1;
    }
    elsif ($line =~ /^screenlayout=(.+)/) {            # screen layout, see doc.
            $screenlayout= $1;
    }
    elsif ($line =~ /^rigmodel=(.+)/) {
            $rigmodel= $1;
    }
    elsif ($line =~ /^rigpath=(.+)/) {
            $rigpath = $1;
    }
    elsif ($line =~ /^checklogs=(.+)/) {
            $checklogs = $1;
    }
    elsif ($line =~ /^lotwdetails=(.+)/) {
            $lotwdetails = $1;
    }
    elsif ($line =~ /^operator=(.+)/) {
            $operator = $1;
    }
    elsif ($line =~ /^autoqueryrig=(.+)/) {
            $autoqueryrig= $1;
    }
    elsif ($line =~ /^directory=(.+)/) {
            $directory = $1;
    }
    elsif ($line =~ /^fieldorder=(.+)/) {
            $fieldorder= $1;
            @fieldorder = split(/\s+/, $fieldorder);
    }
    elsif ($line =~ /^askme=(.+)/) {
            $askme = $1;
    }
    elsif ($line =~ /^logsort=(.+)/) {
            $logsort= $1;
    }
    elsif ($line =~ /^prevsort=(.+)/) {
            $prevsort = $1;
    }
    elsif ($line =~ /^browser=(.+)/) {
            $browser= $1;
    }
    elsif ($line =~ /^usehamdb=(.+)/) {
            $usehamdb= $1;
    }
    elsif ($line =~ /^lotwlocation=(.+)/) {
            $lotwlocation = $1;
    }
    elsif ($line =~ /^lotwuser=(.+)/) {
            $lotwuser= $1;
    }
    elsif ($line =~ /^lotwpass=(.+)/) {
            $lotwpass = $1;
    }
    elsif ($line =~ /^dxchost=(.+)/) {
            $dxchost = $1;
    }
    elsif ($line =~ /^dxcport=(.+)/) {
            $dxcport = $1;
    }
    elsif ($line =~ /^dxccall=(.+)/) {
            $dxccall = $1;
    }
    elsif ($line =~ /^dxcmode=(.+)/) {
            $dxcmode = $1;
    }
}
close CONFIG;    # Configuration read.

return 1;

} #readsubconfig

# Only open Database when config file was read.
if (&readsubconfig()) {
    &connectdb;
    &connectrig;
}

## We connect to the Database now...

sub connectdb {

if ($dbserver eq 'sqlite') {
    $db = 'sqlite';
    $dbh = DBI->connect("DBI:SQLite:dbname=$ENV{HOME}/.yfklog/$dbname", 
            $dbuser, $dbpass)
        or die "Could not connect to SQLite database: " . DBI->errstr;
}
else {    # MYSQL, only if defined.
    $db = 'mysql';
    $dbh = DBI->connect("DBI:mysql:$dbname;host=$dbserver",$dbuser,$dbpass)
        or die "Could not connect to MySQL database: " . DBI->errstr;
}
}


# Open Rig for Hamlib

sub connectrig {
    if ( $autoqueryrig eq 1) {
        if (-r '/usr/local/share/yfklog/rigctld.sh') {
            system('sh /usr/local/share/yfklog/rigctld.sh');
            sleep 1;                                            
        }
    }
}


# Now we read cty.dat or exit when it's not found.
my $ctydat = "$prefix/share/yfklog/cty.dat";
if (-R "./cty.dat") {
    $ctydat = "./cty.dat";
}

open CTY, "$ctydat" or die "$ctydat not found.".
            "Please download it from http://country-files.com/\n";

my %fullcalls;          # hash of full calls (=DL1XYZ)
my %prefixes;            # hash of arrays  main prefix -> (all, prefixes,..)
my %dxcc;                # hash of arrays  main prefix -> (CQZ, ITUZ, ...)
my $mainprefix;

while (my $line = <CTY>) {
    if (substr($line, 0, 1) ne ' ') {            # New DXCC
        $line =~ /\s+([*A-Za-z0-9\/]+):\s+$/;
        $mainprefix = $1;
        $line =~ s/\s{2,}//g;
        @{$dxcc{$mainprefix}} = split(/:/, $line);
    }
    else {                                        # prefix-line
        $line =~ s/\s+//g;

        # read full calls into separate hash. this hash only
        # contains the information that this is a full call and
        # therefore doesn't need to be handled by &wpx even if
        # it contains a slash

        if ($line =~ /=/) {
            my @matches = ($line =~ /=([A-Z0-9\/]+)(\(\d+\))?(\[\d+\])?[,;]/g);
            foreach (@matches) {
                $fullcalls{$_} = 1 if $_;
            }
        }

        # Continue with everything else. Including full calls, which will
        # be read as normal prefixes.

        $line =~ s/=//g;

        # handle "normal" prefixes
        unless (defined($prefixes{$mainprefix}[0])) {
            @{$prefixes{$mainprefix}} = split(/,|;/, $line);
        }
        else {
            push(@{$prefixes{$mainprefix}}, split(/,|;/, $line));
        }
    }
}

close CTY;


###############################################################################
#
# &wpx derives the Prefix following WPX rules from a call. These can be found
# at: http://www.cq-amateur-radio.com/wpxrules.html
#  e.g. DJ1YFK/TF3  can be counted as both DJ1 or TF3, but this sub does 
# not ask for that, always TF3 (= the attached prefix) is returned. If that is 
# not want the OP wanted, it can still be modified manually.
#
###############################################################################
 
sub wpx {
  my ($call, $prefix,$a,$b,$c);
  $call = uc(shift);
  
  # 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".
  # 23.Apr.06: Added another "/X" to the regex, for calls like RV0AL/0/P
  # as used by RDA-DXpeditions....
    
if ($call =~ 
    /^((\d|[A-Z])+\/)?((\d|[A-Z]){3,})(\/(\d|[A-Z])+)?(\/(\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 AD1C at https://www.country-files.com/
# An example entry of the file looks like this:
#
# Portugal:                 14:  37:  EU:   39.50:     8.00:     0.0:  CT:
#     CQ,CR,CS,CT,=CR5FB/LH,=CS2HNI/LH,=CS5E/LH,=CT/DJ5AA/LH,=CT1BWW/LH,=CT1GFK/LH,=CT1GPQ/LGT,
#     =CT7/ON4LO/LH,=CT7/ON7RU/LH;
#
# 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 []).
#
# 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.
# 
# 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 $testcall = shift;
    my $matchchars=0;
    my $matchprefix='';
    my $test;
    my $zones = '';                 # annoying zone exceptions
    my $goodzone;
    my $letter='';


if ($fullcalls{$testcall}) {            # direct match with "="
    # do nothing! don't try to resolve WPX, it's a full
    # call and will match correctly even if it contains a /
}
elsif ($testcall =~ /(^OH\/)|(\/OH[1-9]?$)/) {    # non-Aland prefix!
    $testcall = "OH";                      # make callsign OH = finland
}
elsif ($testcall =~ /(^3D2R)|(^3D2.+\/R)/) { # seems to be from Rotuma
    $testcall = "3D2RR";                 # will match with Rotuma
}
elsif ($testcall =~ /^3D2C/) {               # seems to be from Conway Reef
    $testcall = "3D2CR";                 # will match with Conway
}
elsif ($testcall =~ /(^LZ\/)|(\/LZ[1-9]?$)/) {  # LZ/ is LZ0 by DXCC but this is VP8h
    $testcall = "LZ";
}
elsif ($testcall =~ /\//) {                  # check if the callsign has a "/"
    my $prfx = &wpx($testcall,1);
    unless (defined($prfx)) {
        $prfx = "QQ";                        # invalid
    }
    $testcall = $prfx."AA";                # use the wpx prefix instead, which may
                                         # intentionally be wrong, see &wpx!
}

$letter = substr($testcall, 0,1);

foreach $mainprefix (keys %prefixes) {

    foreach $test (@{$prefixes{$mainprefix}}) {
        my $len = length($test);

        if ($letter ne substr($test,0,1)) {            # gains 20% speed
            next;
        }

        $zones = '';

        if (($len > 5) && ((index($test, '(') > -1)            # extra zones
                        || (index($test, '[') > -1))) {
                $test =~ /^([A-Z0-9\/]+)([\[\(].+)/;
                $zones .= $2 if defined $2;
                $len = length($1);
        }

        if ((substr($testcall, 0, $len) eq substr($test,0,$len)) &&
                                ($matchchars <= $len))    {
            $matchchars = $len;
            $matchprefix = $mainprefix;
            $goodzone = $zones;
        }
    }
}

my @mydxcc;                                        # save typing work

if (defined($dxcc{$matchprefix})) {
    @mydxcc = @{$dxcc{$matchprefix}};
}
else {
    @mydxcc = qw/Unknown 0 0 0 0 0 0 ?/;
}

# Different zones?

if ($goodzone) {
    if ($goodzone =~ /\((\d+)\)/) {                # CQ-Zone in ()
        $mydxcc[1] = $1;
    }
    if ($goodzone =~ /\[(\d+)\]/) {                # ITU-Zone in []
        $mydxcc[2] = $1;
    }
}

# 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 ($mydxcc[7] =~ /^\*/) {                            # WAE country!
    if ($mydxcc[7] eq '*TA1') { $mydxcc[7] = "TA" }        # Turkey
    if ($mydxcc[7] eq '*4U1V') { $mydxcc[7] = "OE" }    # 4U1VIC is in OE..
    if ($mydxcc[7] eq '*GM/s') { $mydxcc[7] = "GM" }    # Shetlands
    if ($mydxcc[7] eq '*IG9') { $mydxcc[7] = "I" }        # African Italy
    if ($mydxcc[7] eq '*IT9') { $mydxcc[7] = "I" }        # Sicily
    if ($mydxcc[7] eq '*JW/b') { $mydxcc[7] = "JW" }    # Bear Island

}

# CTY.dat uses "/" in some DXCC names, but I prefer to remove them, for example
# VP8/s ==> VP8s etc.

$mydxcc[7] =~ s/\///g;

return @mydxcc; 

} # dxcc ends here 

###############################################################################
# &makewindow  Creates and refreshes a window with given name and color
# parameters.
# Since a newly initialized window's background color is at the
# default, not at the color specified with attron($win, COLOR_PAIR()) (or I am
# just too stupid to find out how to do it properly), this sub fills the window
# with whitespaces, so it will have the color which was specified with attron.
#
# usage: &makewindow($height, $width, $ypos, $xpos, $color pair);
###############################################################################

sub makewindow {
    my $wind = newwin($_[0], $_[1], $_[2], $_[3]);        # create window
    attron($wind, COLOR_PAIR($_[4]));                    # set colors
    addstr($wind, 0,0, " " x ($_[0]*$_[1]));            # print x*y whitespaces
    move($wind, 0,0);                                    # cursor back to start
    return $wind;                                        # return window
}

###########################################################################
# clearinputfields  fills inputfields with spaces.
# $_[0] -> window array
# $_[1] -> when 1, clear windows 0..13, when 2 clear windows 0..25
# This is needed because in LOGGING mode only the first 14 windows are used
##########################################################################

sub clearinputfields {
    my @wi = @{$_[0]};                  # Input windows
    my $num;                            # number of QSOs to delete..
    
    if ($_[1] == 1) { $num = 14 }
    else { $num = 26 }

    for (my $a=0;$a < $num;$a++) {        # go through all fields
        attron($wi[$a], COLOR_PAIR(5));    # input fields fg white, bg black
        addstr($wi[$a], 0,0, " " x 80);    # lots of spaces to fill the window
        move($wi[$a], 0,0);                # move cursor home
        refresh($wi[$a]);                # refresh
    }
}


###########################################################################
# qsotofields puts the content of the qso array (referenced by $qso, $_[0])
# into the input windows $wi, referenced by $_[1]
# When $_[2] is 1, it will update windows 0..13 for Logging mode
# When $_[2] is 2, it will update windows 0..17 for Edit mode
##########################################################################

sub qsotofields {
    my @qso= @{$_[0]};          # reference to QSO
    my @wi = @{$_[1]};          # reference to input-windows
    my $num;                    # number of windows to paint

    if ($_[2] == 1) { $num = 14 }
    else { $num = 26 }

    for (my $a=0;$a < $num;$a++) {        # go through all fields in range
        attron($wi[$a], COLOR_PAIR(5));    # input fields fg white, bg black
        addstr($wi[$a], 0,0, $qso[$a]. " " x 80);    # put QSO value + spaces    
        move($wi[$a], 0,0);                # move cursor home
        refresh($wi[$a]);                    # refresh
    }
}

##############################################################################
# &saveqso  Saves the passed array into the table log_$mycall, also adds
# DXCC, Prefix, Continent and QSL-Info fields. 
# The QSL-Info is taken from the REMarks field, if it contains "via:<sth>".
# the same applies for ITU, CQZ and IOTA, OPERATOR. Those can be entered in
# the REMarks
# field like OPERATOR:DL1LID ITU:34 CQZ:33 IOTA:EU-038  (with hyphen!).
# These parts will be cut
# out of the field if they represent a valid ITUZ, CQZ or IOTA nr. 
# The database is specified in the configfile and so are the server and the
# port of the server.
# If there is another parameter after the QSO-array, it is the number of the
# QSO which is edited. This QSO has to be changed in the database then
##############################################################################

sub saveqso {
    my $qslinfo = "";        # QSLinfo, IOTA and STATE will be read from the
    my $iota= "";            # remarks field, if available.