dj1yfk
/
yfklog
2
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity
YFKlog Perl Ham Radio logger: https://fkurz.net/ham/yfklog.html
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
102 Commits
2 Branches
0 Tags
8.5 MiB
 
 
 
 
 
Tree: 0f69975d72
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '0f69975d72'
${ noResults }
yfklog/yfksubs.pl

6488 lines
244 KiB
Raw Blame History

#!/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 jumpfield receive_qso tqslsign getlotwlocations
getlotwstartdate downloadlotw redraw create_windows rundxc getch2 waitkey
senddxc mycurs_set gridinfo);
use strict;
use POSIX; # needed for acos in distance/direction calculation
use Curses;
use Net::FTP;
use IO::Socket::Timeout;
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();
}
my $haveqrz = eval "require Ham::Reference::QRZ;";
# 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 $hamlibport = 4532;
our $hamlibaddr = '127.0.0.1';
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)
my %wkdcalls = (); # worked calls - those will not be highlighted on the bandmap
our $cursoron = 1; # show cursor all the time? (makes things easy for people with a screen reader)
our $qrzuser = ""; # QRZ.com username for querying data from QRZ.com
our $qrzpass = ""; # QRZ.com password (NOT the API key)
share(@dxspots);
share(@dxlines);
share(@dxinput);
share(%wkdcalls);
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(($row-8),30,7,0,3); # Logbook
$main::wqsos = &makewindow(($row-8),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} } ) {
my $age = int((time - $tr->{$band}{$call})/60);
my $flag = defined($wkdcalls{$call}) ? 1 : 0;
push @dxspots, sprintf("$age$flag%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));
# fill array of worked calls
unless (keys %wkdcalls) {
my $q = $dbh->prepare("SELECT distinct `call` FROM log_$mycall;");
$q->execute();
while (my @r = $q->fetchrow_array()) {
$wkdcalls{$r[0]} = 1;
}
}
# 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
# extract age/flag from spot
my $age = substr($line, 0, 1);
my $flag = substr($line, 1, 1);
if ($age < 1) {
attron($win, A_BOLD);
}
if ($flag ne "1") {
attron($win, COLOR_PAIR(8));
}
addstr($win, $mrow , 1 + $mcol*25, substr($line, 2));
attroff($win, A_BOLD);
attron($win, COLOR_PAIR(5));
$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 =~ /^hamlibaddr=(.+)/) {
$hamlibaddr= $1;
}
elsif ($line =~ /^hamlibport=(.+)/) {
$hamlibport= $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;
}
elsif ($line =~ /^cursoron=(.+)/) {
$cursoron = $1;
}
elsif ($line =~ /^qrzuser=(.+)/) {
$qrzuser = $1;
}
elsif ($line =~ /^qrzpass=(.+)/) {
$qrzpass = $1;
}
}
close CONFIG; # Configuration read.
return 1;
} #readsubconfig
# Only open Database when config file was read.
if (&readsubconfig()) {
&connectdb;
}
## 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;
}
}
# 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 {
%wkdcalls = (); # bandmap
my $qslinfo = ""; # QSLinfo, IOTA and STATE will be read from the
my $iota= ""; # remarks field, if available.
my $state = "";
my $grid= "";
my @qso = (shift,shift,shift,shift,shift,shift,shift,shift,shift,shift,
shift,shift,shift,shift); # get the @qso array
my $editnr = shift; # QSO we edit
if ($editnr) { # if existing QSO try get qslinfo
my $n = $dbh->prepare("SELECT `QSLINFO` FROM log_$mycall
WHERE `NR`='$editnr';");
$n->execute();
my @qslinfo = $n->fetchrow_array(); # local variable for info array
$qslinfo = $qslinfo[0];
}
# Cute date/times, just in case.
$qso[1] = substr($qso[1],0,8);
$qso[2] = substr($qso[2],0,4);
$qso[3] = substr($qso[3],0,4);
# Now we have to check if it is a valid entry
if ((my $pfx = &wpx($qso[0]) ) && # check for a callsign, return PFX
(length($qso[1]) == 8) && # check if date has proper length
(substr($qso[1],0,2) < 32) && # sane day (of course not in all months)
(substr($qso[1],2,2) < 13) && # valid month
(substr($qso[1],4,) > 1900) && # :-)
(length($qso[2]) == 4) && # check length of time on
(substr($qso[2],0,2) < 24) && # valid hour in Time on
(substr($qso[2],3,2) < 60) && # valid minute Time on
($qso[4] ne "") && # band has some info
($qso[5] ne "") && # mode has some info
($qso[8] ne "") && # QSL sent
($qso[9] ne "") # QSL rxed
# RST, PWR not checked, will be 599 / 0 by default in the database,
# Time-OFF can be "", if so, it will be replaced with current time
) { # VALID ENTRY! put into database
# unless we have a valid time off ...
unless ((length($qso[3]) == 4) && # check length of time off
(substr($qso[3],0,2) < 24) && # valid hour in Time on
(substr($qso[3],2,2) < 60)){ # valid minute Time on
$qso[3] = &gettime; # time off = current time
} # Time off ready
$qso[1] = # make date in YYYY-MM-DD format
substr($qso[1],4,)."-".substr($qso[1],2,2)."-".substr($qso[1],0,2);
$qso[2] = substr($qso[2],0,2).":".substr($qso[2],2,2).":00";# add seconds, :
$qso[3] = substr($qso[3],0,2).":".substr($qso[3],2,2).":00";# add seconds, :
my @dxcc = &dxcc($qso[0]); # get DXCC-array
my $dxcc = $dxcc[7]; # dxcc prefix
my $cont = $dxcc[3]; # dxcc continent
my $ituz = $dxcc[2]; # dxcc itu zone
my $cqz = $dxcc[1]; # dxcc CQ zone
# searching for QSL-INFO in remarks-field:
if ($qso[12] =~ /(.*)via:(\w+)(.*)/){ # QSL info in remarks field
$qslinfo = $2; # save QSL-info
$qso[12] = $1." ".$3; # cut qsl-info from remarks field
$qslinfo =~ tr/[a-z]/[A-Z]/; # make qsl-info uppercase
}
# searching for different ITUZ in remarks-field:
# Note: ITU-Zone should be entered as "3" and not "03" e.g.!!
if ($qso[12] =~ /(.*)ITUZ:(\w+)(.*)/){
my ($a, $b, $c) = ($1, $2, $3); # save regex results
# A valid ITU Zone is 01..90
if (($b =~ /^\d\d$/) && ($b > 0) && ($b < 91)) {
$ituz = $b;
$qso[12] = $a." ".$c;
}
}
# searching for different CQZ in remarks-field:
if ($qso[12] =~ /(.*)CQZ:(\w+)(.*)/){
my ($a, $b, $c) = ($1, $2, $3); # save regex results
# A valid CQ Zone is 01..40
if (($b =~ /^\d\d$/) && ($b > 0) && ($b < 41)) {
$cqz = $b;
$qso[12] = $a." ".$c;
}
}
# searching for a STATE in remarks-field:
if ($qso[12] =~ /(.*)STATE:(\w\w)(.*)/){
$state = $2;
$qso[12] = $1." ".$3;
}
# searching for a IOTA Nr in remarks-field:
if ($qso[12] =~ /(.*)IOTA:(\w\w-\d\d\d)(.*)/){
my ($a, $b, $c) = ($1, $2, $3); # save regex results
# A valid IOTA NR starts with a continent. Check this:
if (substr($b,0,2) =~ /(EU|AF|AS|OC|NA|SA|AN)/) {
$iota =$b;
$qso[12] = $a." ".$c;
}
}
# searching for an OPERATOR in remarks-field:
if ($qso[12] =~ /(.*)OPERATOR:(\w+)(.*)/){
$operator = $2;
$qso[12] = $1." ".$3;
}
# searching for a GRID in remarks-field. 4 or 6 letters
if ($qso[12] =~
/(.*)GRID:([A-Z]{2}[0-9]{2}[A-Z]{2}|[A-Z]{2}[0-9]{2})(.*)/){
$grid = $2;
$qso[12] = $1." ".$3;
}
# searching for a GRID in the QTH field
if ($qso[6] =~ /^([A-Z]{2}[0-9]{2}[A-Z]{2}|[A-Z]{2}[0-9]{2})$/i){
$grid = uc($1);
$qso[6] = uc($1);
}
# trim remark
$qso[12] =~ s/\s*$//;
# we are now ready to save the QSO, but we have to check if it's a
# new QSO or if we are changing an existing QSO.
if ($editnr) { # we change an existing QSO
$dbh->do("UPDATE log_$mycall SET `CALL`='$qso[0]',
`DATE`='$qso[1]',
`T_ON`='$qso[2]', `T_OFF`='$qso[3]', `BAND`='$qso[4]',
`MODE`='$qso[5]', `QTH`=".$dbh->quote($qso[6]).", `NAME`=".$dbh->quote($qso[7]).",
`QSLS`='$qso[8]', `QSLR`='$qso[9]', `RSTS`='$qso[10]',
`RSTR`='$qso[11]', `REM`=".$dbh->quote($qso[12]).", `PWR`='$qso[13]',
`QSLINFO`='$qslinfo' WHERE NR='$editnr';");
}
else { # new QSO
$dbh->do("INSERT INTO log_$mycall
(`CALL`, `DATE`, `T_ON`, `T_OFF`, `BAND`, `MODE`, `QTH`,
`NAME`, `QSLS`, `QSLR`, `RSTS`, `RSTR`, `REM`, `PWR`,
`DXCC`, `PFX`, `CONT`, `QSLINFO`,
`ITUZ`, `CQZ`, `IOTA`, `STATE`, `QSLRL`, `OPERATOR`, `GRID`)
VALUES ('$qso[0]', '$qso[1]', '$qso[2]', '$qso[3]',
'$qso[4]', '$qso[5]', ".$dbh->quote($qso[6]).", ".$dbh->quote($qso[7]).",
'$qso[8]', '$qso[9]', '$qso[10]', '$qso[11]',
".$dbh->quote($qso[12]).", '$qso[13]', '$dxcc', '$pfx',
'$cont', '$qslinfo', '$ituz', '$cqz', '$iota',
'$state', 'N', '$operator', '$grid');");
}
# voila, we have saved the QSO. Now we check if the callsign's name
# and QTH info is already contained in the "calls"-table; if not,
# we save it there. first we cut the callsign down to the homecall
# only, by splitting it up at every /, then taking the longest
# part.
#
my $call=$qso[0]; # will be the homecall
my @call = split(/\//, $call); # split at every /
my $length=0; # length of splitted part
foreach(@call) { # chose longest part
if (length($_) >= $length) {
$length = length($_);
$call = $_;
}
}
my $sth = $dbh->prepare("SELECT `CALL` FROM calls WHERE
`CALL`='$call';");
$sth->execute();
unless ($sth->fetch()) { # check if callsign not in DB
if (($qso[7] ne "") || ($qso[6] ne "")) { # new things to add
$dbh->do("INSERT INTO `calls` (`CALL`, `NAME`, `QTH`) VALUES
('$call', ".$dbh->quote($qso[7]).", ".$dbh->quote($qso[6]).");");
}
}
# until now this only inserts, when both Name and QTH are unknown;
# it doesn't update when only one part is unknown. needed?
return 1; # successfully saved
}
else { # QSO invalid. Check what is wrong, make error msg
&finderror(@qso);
return 0;
}
}
##############################################################################
# readw reads what the user types into a window, depending on $_[1],
# only numbers, callsign-characters, only letters or (almost) everything
# is allowed. added 0.2.1: new mode for [0-9.] added (for bands).
# $_[2] contains the windownumber, $_[3] the reference to the
# QSO-array and $_[0] the reference to the Input-window-Array.
#
# $_[4] is the reference to $wlog
#
# $_[5] either contains 0 (normal) or a QSO number. If it's a number, it means
# that we are editing an existing QSO, meaning that we have to call &saveqso
# with the number as additional argument, so it will not save it as a new QSO.
# The variable will be called $editnr.
#
# $_[6] means overwrite mode if nonzero.
#
# $_[7] is the maximum length of the field.
#
# The things you enter via the keyboard will be checked and if they are
# matching the criterias of $_[1], it will be printed into the window and saved
# in @qso. Editing is possible with arrow keys, delete and backspace.
#
# If an F-Key is pressed, following things can happen:
# 1. F2 --> Current QSO is saved into the database,
# read last 16 QSOs from database, write them into $wlog.
# delete @qso and the content of all inputfields.
# return 4. When this is detected, the while-loop where the
# inputs are taken (while ($aw == 1)) will be exited and then entered
# again because $aw is still 1, but then it starts at the callsign
# field again.
# 2. F3 --> clears out the current QSO.
# 3. F4 --> updates date and start time in current QSO
# 4. F5 --> Reads frequency and mode from the rig
# 5. F9 --> return 2 as next active window $aw. --> $wlog.
# 6. F10 --> returns 3 as next active window --> $wqsos
#
# If a regular entry was made, the return value is 1, because we stay in active
# window 1
##############################################################################
sub readw {
my $ch; # the getchar() we read
my $win = ${$_[0]}[$_[2]]; # get window to modify
my $input = ${$_[3]}[$_[2]]; # stores what the user entered,
# init from @qso.
my $match = "[a-zA-Z0-9\/]"; # default match expression
my $pos = 0; # cursor position in the field
my $strpos = $pos; # cursor position in the string
my $wlog = ${$_[4]}; # reference to log-windw
my $editnr = ${$_[5]}; # reference to editnr
my $debug=0;
my $ovr = $_[6]; # overwrite
my $width = $_[7]; # width is fixed
# The string length $strlen is used to have entries larger than the width,
# $_[2] is inspected to set the length according to SQL field length.
my $strlen = $width;
if ($_[2] == 0) { $strlen = 15; } # Call
elsif ($_[2] == 5) { $strlen = 6; } # Mode
elsif ($_[2] == 6) { $strlen = 15; } # QTH
elsif ($_[2] == 7) { $strlen = 15; } # Name
elsif ($_[2] == 10) { $strlen = 10; } # RSTs
elsif ($_[2] == 11) { $strlen = 10; } # RSTr
elsif ($_[2] == 12) { $strlen = 60; } # Remarks
elsif ($_[2] == 13) { $strlen = 10; } # PWR
move($win,0,0); # move cursor to first position
addstr($win,0,0, $input." "x80); # pass $input to window,
refresh($win);
# For the date, time and band only figures are allowed,
# to achieve this, invoke readw with $_[1] = 1
if ((defined $_[1]) && ($_[1] == "1")) { # only numbers
$match = '\d'; # set match expression
}
# For the QSL-status only letters are allowed,
# to achieve this, invoke readw with $_[1] = 2
if ((defined $_[1]) && ($_[1] == "2")) { # only letters
$match = '[a-zA-Z]'; # set match expression
}
# For the Name, QTH and Remarks letters, figures and punctuation is allowed
# to achieve this, invoke readw with $_[1] = 3
if ((defined $_[1]) && ($_[1] == "3")) {
$match = "[\\w\\d!'\"$%&/()=?.,;:\\-@ ]"; # set match expression
}
# In the BAND-field, numbers and a decimal point are allowed.
if ((defined $_[1]) && ($_[1] == "4")) {
$match = '[0-9.]'; # set match expression
}
# Now the main loop starts which is waiting for any input from the keyboard
# which is stored in $ch. If it is a valid character that matches $match,
# it will be added to the string $input at the proper place.
#
# If an arrow key LEFT or RIGHT is entered, the position within the string
# $input will be changed, considering that it can only be within
# 0..length($input-1). The position is stored in $pos.
#
# If a control character like a F-Key, Enter or Tab is found, the sub
# exists and $input is written to @qso, with attached information on which
# key was pressed, as ||F1 .. ||F10. This way we can switch to the proper
# window when we get back into the main loop.
while (1) { # loop infinitely
$pos-- if ($pos == $width); # keep cursor in field
$strpos-- if ($strpos == $strlen); # stop if string filled
# If the cursor positions in the field and the string are not the same
# then give only a partial view of the string.
if ($strpos > $pos) {
if (length($input) < $width) {
$pos = $strpos; # perfect, it fits again
}
addstr($win,0,0, substr($input, $strpos-$pos, )." "x80);
}
else {
addstr($win,0,0, $input." "x80); # pass $input to window,
} # delete all after $input.
move ($win,0,$pos); # move cursor to $pos
refresh($win); # show new window
$ch = &getch2();
# We first check if it is a legal character of the specified $match,
# and if the string will not be too long.
# if so, it will be added to the string (at the proper position!)
if (($ch =~ /^$match$/) &&
((length($input) < $strlen) || ($strpos < $strlen && $ovr))
) {
unless ($_[1] == 3) { # Unless Name, QTH, Remarks
$ch =~ tr/[a-z]/[A-Z]/; # make letters uppercase
}
# The new character will be added to $input at the right place.
$strpos++;
$pos++;
if ($ovr) {
$input = substr($input, 0, $strpos-1).$ch.substr($input,
$strpos > length($input) ? $strpos-1 : $strpos, );
}
else {
$input = substr($input, 0, $strpos-1).$ch.substr($input,
$strpos-1, );
}
}
# The l/r arrow keys change the position of the cursor to left or right
# but only within the boundaries of $input.
elsif ($ch eq KEY_LEFT) {
if ($pos > 0) { $pos-- }
if ($strpos > 0) { $strpos-- }
}
elsif ($ch eq KEY_RIGHT) {
if (($pos < length($input)) && ($pos < $width)) { $pos++ }
if ($strpos < length($input)) { $strpos++ }
}
elsif ($ch eq KEY_HOME) { # Pos1 key
$pos = 0;
$strpos = 0;
}
elsif ($ch eq KEY_END) { # End key
$strpos = length($input);
if ($strpos >= $strlen) {$strpos = $strlen-1;}
$pos = $strpos;
if ($pos >= $width) {$pos = $width-1;}
}
elsif (($ch eq KEY_DC) && ($strpos < length($input))) { # Delete key
$input = substr($input, 0, $strpos).substr($input, $strpos+1, );
}
# BACKSPACE. When pressing backspace, the character left of the cursor
# is deleted, if it exists. For some reason, KEY_BACKSPACE only is true
# when pressing CTL+H on my system (and all the others I tested); the
# other tests lead to success, although it's probably less portable.
# Found this solution in qe.pl by Wilbert Knol, ZL2BSJ.
elsif ((($ch eq KEY_BACKSPACE) || (ord($ch)==8) || (ord($ch)==0x7F))
&& ($strpos > 0)) {
$input = substr($input, 0, $strpos-1).substr($input, $strpos, );
$strpos--;
if ($pos > 0) { $pos--; }
}
# Space, Tab, keydown and Enter are the keys to go to the next field,
# except in mode $_[1], where it was already caught in the first
# pattern match. If space, tab or newline is found, the sub puts
# $input into the proper place in the @qso array: ${$_[3]}[$_[2]];
elsif (($ch =~ /^[ \t\n]$/) || $ch eq KEY_DOWN) {
${$_[3]}[$_[2]] = $input; # save to @qso;
return 1;
}
# Arrow-up or Shift-Tab goes to the previous QSO field. Everything
# else same as above
elsif (($ch eq KEY_UP) || ($ch eq '353')) { # Cursor up or Shift-Tab
${$_[3]}[$_[2]] = $input; # save to @qso;
return 7; # 6 -> one field back
}
# If the pressed key was F2, we will save; that is, when the qso array
# has sufficient information for a good QSO. Then the qso-array
# and the input fields are deleted.
elsif ($ch eq KEY_F(2)) { # pressed F2 -> SAVE
${$_[3]}[$_[2]] = $input; # save field to @qso
if (&saveqso(@{$_[3]}[0..13],$editnr)) { # save @QSO to DB
&clearinputfields($_[0],1); # clear input fields 0..13
# Increase serial number in QSO array, clear all other fields
my $snr = ${$_[3]}[14];
if ($editnr == 0) {
$snr++;
}
@{$_[3]} = ("","","","","","","","","","","","","","");
${$_[3]}[14] = $snr;
# Now we actualize the display of the last QSOs in the
# window $wlog.
&lastqsos(\$wlog);
${$_[5]} = 0; # we finished editing, if we
# did at all. $editnr = 0
return 4; # success, leave readw, new Q
} # if no success, we continue in the loop.
}
# exit to the MAIN MENU
elsif ($ch eq KEY_F(1)) {
my $k = 'y';
if ($askme && ${$_[3]}[0] ne '') {
$k = &askconfirmation("Really go back to the menu? [y/N]",
'y|n|\n|\s');
}
return 5 if ($k =~ /y/i); # active window = 5 -> MENU
}
# F3 cancels the current QSO and returns to the CALL input field.
# if $editnr is set (= we edit a QSO), it's set back to 0
# ask for confirmation if set in config file
elsif ($ch eq KEY_F(3)) { # F3 pressed -> clear QSO
my $k='y';
if ($askme) {
$k = &askconfirmation("Really clear this QSO? [y/N]",
'y|n|\n|\s');
}
if ($k =~ /y/i) {
for (0 .. 13) { # iterate through windows 0-13
addstr(@{$_[0]}[$_],0,0," "x80); # clear it
refresh(@{$_[0]}[$_]);
${$_[3]}[$_] = ""; # clear QSO array
}
${$_[5]} = 0; # editqso = 0
return 4; # return 4 -> to window 0 (call)
}
}
# F4 -> update start time of the QSO
elsif ($ch eq KEY_F(4)) {
${$_[3]}[2] = &gettime;
addstr(@{$_[0]}[2],0,0,&gettime);
refresh(@{$_[0]}[2]);
return 4;
}
# F5 -> get frequency and mode from the transceiver
elsif ($ch eq KEY_F(5)) { # F5 pressed -> freq/mode from rig
my ($freq, $mode) = ('80', 'CW');
if (&queryrig(\$freq, \$mode)) {
${$_[3]}[4] = $freq;
${$_[3]}[5] = $mode;
addstr(@{$_[0]}[4],0,0,$freq." ");
addstr(@{$_[0]}[5],0,0,$mode." ");
refresh(@{$_[0]}[4]);
refresh(@{$_[0]}[5]);
}
return 4; # return 4 because we want back to
}
# F6 -> open browser with qrz.com info on callsign
elsif ($ch eq KEY_F(6)) {
my $lookup = ${$_[3]}[0];
unless ($lookup) { $lookup = $input };
system("$browser http://www.qrz.com/db/$lookup > /dev/null 2>&1 &");
}
# F7 -> go to remote mode for fldigi
elsif ($ch eq KEY_F(7)) {
return 6;
}
# go to log-window $wlog ($aw = 2)
elsif ($ch eq KEY_F(9)) {
return 2;
}
# go to prev-QSO-window $wqsos ($aw = 3)
elsif ($ch eq KEY_F(10)) {
return 3;
}
# QUIT YFKlog
elsif ($ch eq KEY_F(12)) { # QUIT
my $k='y';
if ($askme && ${$_[3]}[0] ne '') {
$k = &askconfirmation("Really quit YFKlog? [y/N]",
'y|n|\n|\s');
}
if ($k =~ /y/i) {
endwin; # Leave curses mode
system ("killall -9 rigctld");
print "Thanks for using YFKlog!\n";
exit;
}
}
}
}
##############################################################################
# &lastqsos Prints the last 16 QSOs into the $wlog window. depending on $_[1],
# 16 or 8 QSOs are displayed, with different layout.
##############################################################################
sub lastqsos {
my $wlog = ${$_[0]}; # reference to $wlog window
my $nr; # nr of QSOs to display
my $y; # y-position in window
my $by = " `NR` DESC ";
if ($logsort eq 'C') {
$by = " `DATE` DESC, `T_ON` DESC ";
}
if ($screenlayout == 0) { # original screen layout, 16 QSOs, small
$nr = $main::row - 8;
$y = $nr - 1; # y-position in $wlog
}
elsif ($screenlayout == 1) { # windows above each other, 8 QSOs
$nr = ($main::row - 8)/2;
$y = $nr - 1; # y-position in $wlog
}
# Now we fetch the last x QSOs in the database, only CALL, BAND, MODE and
# date needed.
my $l = $dbh->prepare("SELECT `CALL`, `BAND`, `MODE`, `DATE`, `T_ON`,
`NAME`, `QTH`, `RSTS`, `RSTR`, `QSLS`, `QSLR`, `QSLRL` FROM
log_$mycall
ORDER BY $by LIMIT $nr");
$l->execute();
# temporary vars
my ($call, $band, $mode, $date, $time, $name, $qth, $rsts,
$rstr,$qsls,$qslr, $qslrl);
$l->bind_columns(\$call, \$band, \$mode, \$date,\$time, \$name,\$qth,
\$rsts,\$rstr,\$qsls,\$qslr, \$qslrl);
while ($l->fetch()) { # while row available
# we put the date into DD-MM-YY format from YYYY-MM-DD
$date = substr($date,8,2).substr($date,4,4).substr($date,2,2);
# cut Call, Name, QTH, RSTR, RSTS, mode, if needed
$call = substr($call,0,12);
$name = substr($name,0,8);
$qth = substr($qth,0,13);
$rstr = substr($rstr,0,3);
$rsts = substr($rsts,0,3);
$mode = substr($mode,0,5);
if ($screenlayout == 0) {
addstr($wlog,$y,0, sprintf("%-12s%-4s %-5s%-6s",
$call,$band,$mode,$date));
}
elsif ($screenlayout == 1) {
substr($time,-3,)=''; # remove seconds
addstr($wlog,$y,0,
sprintf("%-12s%-4s %-5s%-4s %-6s %-8s %-13s %-3s %-3s %s %s %s ",
$call,$band,$mode,$time,$date,$name,$qth,$rsts,$rstr,
$qsls, $qslr, $qslrl));
}
$y--; # move one row up
}
# If there were less than 16 QSOs in the log, the remaining lines have to
# be filled with spaces
if ($y > 0) {
for $y (0 .. $y) {
addstr($wlog,$y,0, " "x30) if ($screenlayout == 0);
addstr($wlog,$y,0, " "x80) if ($screenlayout == 1);
}
}
refresh($wlog);
}
##############################################################################
# &gridinfo When a new GRID is entered in the input form, this sub is
# called and it prints
# 1) The distance and heading
# 2) Previous stations from that grid in $wqsos window
##############################################################################
sub gridinfo {
my $grid = ${$_[0]}[0]; # grid to analyse
my $band = ${$_[0]}[4]; # band of the current QSO
my $dxwin = $_[1]; # window where to print DXCC/Pfx
my @wi = @{$_[2]}; # reference to input-windows
my $wqsos = $_[3]; # qso-b4-window
my $PI=3.14159265; # PI for the distance and bearing
my $RE=6371; # Earth radius
my $grid4 = substr($grid, 0, 4);
addstr($dxwin, 1,38, sprintf("%-6d", 1000));
addstr($dxwin, 1,58, sprintf("%3d", 359));
my $nbr; # different layouts
if ($screenlayout == 0) {
$nbr = $main::row - 8;
}
if ($screenlayout == 1) {
$nbr = ($main::row - 8)/2;
}
addstr($wqsos, 0, 0, " "x(80*$nbr));
# cfmed on which bands?
my $q = $dbh->prepare("SELECT distinct(band) FROM log_$mycall WHERE substr(GRID, 1, 4) = '$grid4' and (qslr='Y' or qslrl='Y')");
$q->execute();
my %cfmedbands;
while (my @b = $q->fetchrow_array()) {
$cfmedbands{$b[0]} = 1;
}
# wkd on which bands?
$q = $dbh->prepare("SELECT distinct(band) FROM log_$mycall WHERE substr(GRID, 1, 4) = '$grid4' order by band asc");
$q->execute();
my %wkdbands;
my $new = 1;
my $newb = 1;
while (my @b = $q->fetchrow_array()) {
$wkdbands{$b[0]} = defined($cfmedbands{$b[0]}) ? 'C' : 'W';
$new = 0;
if ($b[0] == $band) {
$newb = 0;
}
}
if ($new) {
$new = " New Grid!";
}
elsif ($newb and $band) {
$new = " New Grid on $band!";
}
else {
$new = '';
}
my $line = "$grid4: ";
foreach (sort { $a <=> $b } keys %wkdbands) {
$line .= $_.$wkdbands{$_}." ";
}
addstr($wqsos, 0, 0, $line." ".$new." "x80);
# callsigns worked from this exact grid
$q = $dbh->prepare("SELECT distinct(`call`) from log_$mycall where grid like '$grid%'");
$q->execute();
my @calls;
while (my @b = $q->fetchrow_array()) {
push(@calls, $b[0]);
}
my $cls = "@calls";
$cls =~ s/(.{73}[^\s]*)\s+/$1\n/g;
@calls = split(/\n/, $cls);
addstr($wqsos, 2, 0, "Wkd from $grid:");
my $y = 3;
foreach (@calls) {
addstr($wqsos, $y++, 0, $_);
}
# for full grids, also search for calls from the same square
if (length($grid) == 6) {
$q = $dbh->prepare("SELECT distinct(`call`) from log_$mycall where grid like '$grid4%'");
$q->execute();
my @calls;
while (my @b = $q->fetchrow_array()) {
push(@calls, $b[0]);
}
$cls = "@calls";
$cls =~ s/(.{73}[^\s]*)\s+/$1\n/g;
@calls = split(/\n/, $cls);
$y++;
addstr($wqsos, $y++, 0, "Wkd from $grid4:");
foreach (@calls) {
addstr($wqsos, $y++, 0, $_);
}
}
refresh($wqsos);
refresh($dxwin);
return;
}
##############################################################################
# &callinfo When a new callsign is entered in the input form, this sub is
# called and it prints
# 1) The Name and QTH (from a separate database table), if available.
# 2) The DXCC info, prefix, distance and beam heading. Info if new DXCC.
# 3) The (max.) 16 last QSOs into the $wqsos-window.
# 4) Club info (HSC, etc)
# 5) IF $autoqueryrig = 1, get frequency / band from radio
##############################################################################
sub callinfo {
my $call = ${$_[0]}[0]; # callsign to analyse
my $band = ${$_[0]}[4]; # band of the current QSO
my $dxwin = $_[1]; # window where to print DXCC/Pfx
my @wi = @{$_[2]}; # reference to input-windows
my $wqsos = $_[3]; # qso-b4-window
my $editnr = $_[4]; # if we edit a QSO, we don't query the RIG
my $prefix = &wpx($call); # determine the Prefix
my $PI=3.14159265; # PI for the distance and bearing
my $RE=6371; # Earth radius
my $z =180/$PI; # Just to reduce typing in formular dist/dir
my $foundlog = 0;
my $ascdesc = ' ASC ';
if ($prevsort eq 'D') {
$ascdesc = ' DESC ';
}
if (defined $prefix) { # &wpx returns undef when callsign is invalid
# Now we print all the fields to their appropriate locations, with
# added whitespaces behind it so any previous entries will be
# overwritten.
my @dxcc = &dxcc($call); # dxcc array gets filled
my $sprefix = substr($prefix, 0, 5);
addstr($dxwin, 0,9, $dxcc[0]." " x (25-length($dxcc[0])));
addstr($dxwin, 0,40, $dxcc[7]." " x (5-length($dxcc[7])));
addstr($dxwin, 0,51, $sprefix." " x (5-length($sprefix)));
addstr($dxwin, 0,61, $dxcc[2]." " x (2-length($dxcc[2])));
addstr($dxwin, 0,69, $dxcc[1]." " x (2-length($dxcc[1])));
addstr($dxwin, 1,5, $dxcc[4]." " x (7-length($dxcc[4])));
addstr($dxwin, 1,19, $dxcc[5]." " x (7-length($dxcc[5])));
my $lat2 = $dxcc[4]; # to save typing work :-)
my $lon2 = $dxcc[5];
# g is the "distance angle", 0 .. pi
my $g = acos(sin($lat1/$z)*sin($lat2/$z)+cos($lat1/$z)*cos($lat2/$z)*
cos(($lon2-$lon1)/$z));
# The distance is $g * $RE
my $dist = $g * $RE;
# Direction
my $dir = 0;
unless ($dist == 0) {
$dir = acos((sin($lat2/$z)-sin($lat1/$z)*cos($g))/
(cos($lat1/$z)*sin($g)))*360/(2*$PI);
}
# Shortpath
if (sin(($lon2-$lon1)/$z) < 0) { $dir = 360 - $dir;}
$dir = 360 - $dir;
addstr($dxwin, 1,38, sprintf("%-6d",$dist));
addstr($dxwin, 1,58, sprintf("%3d",$dir));
# now we have to get the home-call to get the name, previous QSOs any
# maybe (TBD) award data from the station. We split the callsign at
# every / (if any), and then take the longest part as homecall. of
# course such exotic calls as KH5K/K1A would get the wrong result but I
# do not care :)
my @call = split(/\//, $call);
my $length=0; # length of splitted part
foreach(@call) { # chose longest part
if (length($_) >= $length) {
$length = length($_);
$call = $_;
}
}
# We fetch the name and the qth (if available) from the database.
my $nq = $dbh->prepare("SELECT NAME, QTH from calls WHERE
`CALL`='$call'");
$nq->execute();
my ($name, $qth); # temporary vars
$nq->bind_columns(\$name, \$qth); # bind references
if ($nq->fetch()) { # if name available
unless (${$_[0]}[7] ne '') { # and no name in $qso
${$_[0]}[7] = $name; # save to @qso
addstr($wi[7],0,0,"$name"); # put into window
}
unless (${$_[0]}[6] ne '') { # and no QTH in $qso
${$_[0]}[6] = $qth; # save to @qso
addstr($wi[6],0,0,"$qth"); # put into window
}
refresh($wi[6]);
refresh($wi[7]);
$foundlog = 1;
}
# If QTH or name is empty, query qrz.com to add missing details.
if ($haveqrz && ($qrzuser ne "") && ($qrzpass ne "") &&
((${$_[0]}[7] == "") || (${$_[0]}[7] == ""))) {
my $qrz = Ham::Reference::QRZ->new(
callsign => $call,
username => $qrzuser,
password => $qrzpass
);
my $listing = $qrz->get_listing;
# If no name has been found in a previous qso, grab name from qrz
if (${$_[0]}[7] == "") {
my $qrzname = $listing->{fname}." ".$listing->{name};
${$_[0]}[7] = $qrzname;
addstr($wi[7],0,0,"$qrzname");
refresh($wi[7]);
}
# If no QTH has been found in a previous qso, grab QTH from qrz
if (${$_[0]}[6] == "") {
${$_[0]}[6] = $listing->{addr2};
addstr($wi[6],0,0,"$listing->{addr2}");
refresh($wi[6]);
}
}
# Now the previous QSOs with the station will be displayed. A database
# query is made for: CALL (because it might have been something
# different than the homecall, like PA/DJ1YFK/p, DATE, time, band,
# mode, QSL sent and QSL-rx.
# (TBD maybe it would be worth thinking about adding an additional
# column for the own call and then specify a list of logs to search in
# the config file)
# Select all QSOs where the base-callsign is $call (which is the base
# call of the current QSO)
my $nbr; # different layouts
if ($screenlayout == 0) {
$nbr = $main::row - 8;
}
if ($screenlayout == 1) {
$nbr = ($main::row - 8)/2;
}
# First count...
my $lqcount = $dbh->prepare("SELECT count(*) FROM log_$mycall WHERE
`CALL` = '$call' OR `CALL` LIKE '\%/$call' OR
`CALL` LIKE '\%/$call/\%' OR `CALL` LIKE '$call/\%';");
$lqcount->execute();
my $count = $lqcount->fetchrow_array();
my $lq = $dbh->prepare("SELECT `CALL`, `DATE`, `T_ON`, `BAND`, `MODE`,
`QSLS`, `QSLR`, `NAME`, `QTH`, `RSTS`, `RSTR`, `QSLRL` from
log_$mycall
WHERE `CALL` = '$call' OR
`CALL` LIKE '\%/$call' OR
`CALL` LIKE '\%/$call/\%' OR
`CALL` LIKE '$call/\%'
ORDER BY `DATE` $ascdesc, `T_ON` $ascdesc;");
$lq->execute();
my ($lcall, $ldate, $ltime, $lband, $lmode, $lqsls, $lqslr, $lname,
$lqth, $lrsts, $lrstr, $lqslrl);
$lq->bind_columns(\$lcall, \$ldate, \$ltime, \$lband, \$lmode, \$lqsls,
\$lqslr, \$lname, \$lqth, \$lrsts, \$lrstr, \$lqslrl);
my $y = 0;
while ($lq->fetch()) { # more QSOs available
$ltime = substr($ltime, 0,5); # cut seconds from time
$ldate = substr($ldate,8,2).substr($ldate,4,4).substr($ldate,2,2);
# cut Call, Name, QTH, RSTR, RSTS, Mode
$lcall = substr($lcall,0,12);
$lname = substr($lname,0,8);
$lqth = substr($lqth,0,13);
$lrstr = substr($lrstr,0,3);
$lrsts = substr($lrsts,0,3);
$lmode = substr($lmode,0,5);
my $line;
if ($screenlayout == 0) {
$line = sprintf("%-14s %-8s %-5s %4s %-4s %1s %1s %1s ",
$lcall, $ldate, $ltime, $lband, $lmode, $lqsls, $lqslr,$lqslrl);
}
elsif ($screenlayout ==1) {
$line = sprintf("%-12s%-4s %-5s%-4s %-6s %-8s %-13s %-3s %-3s %s %s %s ",
$lcall,$lband,$lmode,$ltime,$ldate,$lname,$lqth,$lrsts,
$lrstr, $lqsls, $lqslr, $lqslrl);
}
addstr($wqsos, $y, 0, $line);
($y < $nbr) ? $y++ : last; # prints first 16 rows
} # all QSOs printed
for (;$y < $nbr;$y++) { # for the remaining rows
addstr($wqsos, $y, 0, " "x80); # fill with whitespace
}
if ($count > ($nbr-1)) { # more QSOs than fit in window
my $x; # x-position of msg, depending on width
if ($screenlayout == 0) {
$x = 47; # TODO maybe with getxy?
}
elsif ($screenlayout == 1) {
$x=77;
}
addstr($wqsos, ($nbr-2), $x, ($count-$nbr));
addstr($wqsos, ($nbr-1), $x-1, "more");
}
refresh($wqsos);
# We fetch club membership information from the database ...
# As of version 0.2.3: Also check other logbooks for the callsign
# as given in .yfklog for previous QSOs. See .yfktest or MANUAL.
my $clubline=''; # We will store the club infos here
my $clubs = $dbh->prepare("SELECT `CLUB`, `NR` FROM clubs WHERE
`CALL`='$call'");
$clubs->execute();
while (my @a = $clubs->fetchrow_array()) { # fetch row
$clubline .= $a[0].":".$a[1]." "; # assemble string
}
# Output will be something like: AGCW:2666 HSC:1754 ...
# now previous QSOs:
my $qsoinotherlogs='';
$checklogs =~ s#/#_#g;
my @calls = split(/\s+/, "\L$checklogs");
foreach my $callsign (@calls) {
my $sth = $dbh->prepare("SELECT `CALL` FROM log_$callsign WHERE
`CALL` = '$call' OR
`CALL` LIKE '\%\/$call' OR
`CALL` LIKE '\%\/$call\/\%' OR
`CALL` LIKE '$call\/\%'
"); # No more regex with SQlite..
$sth->execute();
if ($sth->fetch()) {
$qsoinotherlogs.= "\U$callsign " unless ($callsign eq $mycall);
}
}
if ($qsoinotherlogs ne '') {
$qsoinotherlogs =~ s#_#/#g;
$clubline .= 'Wkd as: '.$qsoinotherlogs;
}
##########################################
# Show DXCC bandpoints for the $call, also add to club-line. if new
# DXCC or bandpoint, give extra notice.
my $dx = $dbh->prepare("SELECT count(*) from log_$mycall WHERE
DXCC='$dxcc[7]';");
$dx->execute();
my $newdxcc = $dx->fetchrow_array();
if ($newdxcc) { # DXCC already wkd, show bands
$dx = $dbh->prepare("SELECT `band`, `qslr`, `QSLRL` from
log_$mycall WHERE
DXCC='$dxcc[7]';");
$dx->execute();
my %bandhash;
my @i;
while (@i = $dx->fetchrow_array()) {
if ($i[2] eq 'Y') { $i[1] = 'Y' } # LOTW = paper
unless(defined($bandhash{$i[0]}) && $bandhash{$i[0]} ne 'N') {
$bandhash{$i[0]} = $i[1];
}
}
my $j;
my $string='';
foreach $j (sort {$a <=> $b} keys %bandhash) {
$string .= "$j$bandhash{$j} ";
}
$string =~ s/Y/C/g;
$string =~ s/N/W/g;
$clubline .= $string;
# bandpoint?
unless ($string =~ /\b$band()[A-Z]\b/) {
addstr($dxwin, 1, 65, "New Band!");
}
else {
addstr($dxwin, 1, 65, " ");
}
}
else { # NEW DXCC
addstr($dxwin, 1, 65, "New DXCC!");
}
addstr($dxwin, 2, 0, sprintf("%-80s", $clubline));
refresh($dxwin);
}
##########################################################
# Query rig if autoqueryrig = 1 and NO QSO being edited.
##########################################################
if ($autoqueryrig && !$editnr) {
my ($band, $mode) = (${$_[0]}[4] , ${$_[0]}[5]);
&queryrig(\$band, \$mode);
${$_[0]}[4] = $band;
${$_[0]}[5] = $mode;
addstr($wi[4],0,0,$band." ");
addstr($wi[5],0,0,$mode." ");
refresh($wi[4]);
refresh($wi[5]);
}
if ($usehamdb && $hamdb) {
my $results = $hamdb->lookup(uc($call));
if ($results && $#$results > -1) {
my $result = $results->[0]; # just get the first
# assume that if we previously logged them the previous logged name
# is right.
if (!$foundlog) {
my $nm = $result->{'first_name'} . " " . $result->{'last_name'};
${$_[0]}[7] = $nm;
addstr($wi[7],0,0,$nm);
refresh($wi[7]);
}
# assume the QTH may have moved though, so use the new one
my $qth = $result->{'qth'};
${$_[0]}[6] = $qth;
addstr($wi[6],0,0,$qth);
refresh($wi[6]);
my $remarks = "";
# remarks
# class
if (defined($result->{'operator_class'})) {
$remarks .= "Cl: $result->{'operator_class'}";
}
# GRID
if (defined($result->{'Grid'})) {
$remarks .= " GRID:$result->{'Grid'}";
}
if (defined($result->{'State'})) {
$remarks .= " STATE:$result->{'State'}";
} elsif ($result->{'Addr2'} =~ /[^,],\s*([^,]+)/) {
$remarks .= " STATE:$1";
}
if ($remarks ne '') {
${$_[0]}[12] = $remarks;
addstr($wi[12],0,0,$remarks);
refresh($wi[12]);
}
}
}
}
##############################################################################
# &getdate; Uses gmtime() to get the current date in DDMMYYYY
##############################################################################
sub getdate {
my @date = gmtime(); # $date[3] has day, 4 month, 5 year
# The year is in years from 1900, month is counting from 0 from january.
# Thus month++ and year += 1900;
$date[4] += 1;
if ($date[3] < 10) { $date[3] = "0".$date[3]; } # add leading zero
if ($date[4] < 10) { $date[4] = "0".$date[4]; }
my $date = $date[3].$date[4].($date[5] + 1900);
return $date;
}
##############################################################################
# &gettime; Uses gmtime() to get the current UTC / GMT format HHMM
##############################################################################
sub gettime {
my @date = gmtime(); # $date[2] has hour, 1 has minutes
if ($date[1] < 10) { $date[1] = "0".$date[1]; } # Add 0 if neccessary
if ($date[2] < 10) { $date[2] = "0".$date[2]; }
return $date[2].$date[1];
}
##############################################################################
# splashscreen returns the splash screen
##############################################################################
sub splashscreen {
my $yfkver = $_[0];
return "YFKlog v$yfkver - a general purpose ham radio logbook
Copyright (C) 2005-2019 Fabian Kurz, DJ1YFK
This is free software, and you are welcome to redistribute it
under certain conditions (see COPYING).
YFKlog website: https://fkurz.net/ham/yfklog.html
Your feedback is appreciated.";
}
return 1;
##############################################################################
# &choseqso This sub lets the OP chose a QSO from the logbook. It displays 16
# QSOs as usual in the $wlog window, the user can select a QSO with the cursor
# keys. The list automatically scrolls up and down after the last or first QSO
# in the window. PgUp and PgDwn jump a page up or down.
# The return value is the NR of the selected QSO, as in the database column NR
##############################################################################
sub choseqso {
my $wlog = ${$_[0]}; # reference to $wlog window
my $offset=0; # offset for DB query.
my $aline; # active line, cursor position.
my $ch; # character we get from keyboard
my $ret=0; # return value. saves the NR from the
# database which suits in $aline
my $goon=1; # "go on" in the do .. while loop
my $nbr; # nr of lines/qsos
my $y; # y-position for printing in $wlog
my $totalcalls=0; # might be 0, then return
my $by = " `NR` DESC ";
if ($logsort eq 'C') {
$by = " `DATE` DESC, `T_ON` DESC ";
}
# set active (highlighted) line according to screen layout
if ($screenlayout == 0) {
$nbr = $main::row-8;
$aline = $nbr - 1;
}
elsif ($screenlayout == 1) {
$nbr = ($main::row-8)/2;
$aline=$nbr-1;
}
# Now we fetch 16/8 QSOs from the database, eventually with an offset when we
# scrolled. only NR, CALL, BAND, MODE and DATE needed.
# a do {..} while construct is used because we need a highlighted line right at
# the start, without any extra key pressed
do { # loop and get keyboard input
# after every keystroke the database query is done again and the active
# line displayed in another color. unfortunately chgat() does not work on
# things that have already been sent to the display with refresh(), so only
# colouring one line while scrolling is not possible. since I was too lazy
# to save the 16/8 QSOs into some kind of array, I decided to do the query
# every time again. no performance problems even on my old K6-300.
my $cq = $dbh->prepare("SELECT `NR`, `CALL`, `BAND`, `MODE`, `DATE`,
`T_ON`, `NAME`, `QTH`, `RSTS`, `RSTR`, `QSLS`, `QSLR`, `QSLRL` FROM
log_$mycall ORDER BY $by LIMIT $offset, $nbr");
$cq->execute();
# my $nrofrows = $cq->execute();
# if ($nrofrows eq "0E0") { return "i"; } # nothing, back to log input
# temporary vars
my ($nr, $call, $band, $mode, $date, $time, $name, $qth, $rsts,
$rstr,$qsls,$qslr, $qslrl);
$cq->bind_columns(\$nr, \$call, \$band, \$mode, \$date,\$time, \$name,
\$qth,\$rsts,\$rstr,\$qsls,\$qslr, \$qslrl);
$y = ($nbr-1);
my $callsthispage=0; # calls displayed on this page
while ($cq->fetch()) { # while row available
$callsthispage++;
$totalcalls++;
# we put the date into DD-MM-YY format from YYYY-MM-DD
$date = substr($date,8,2).substr($date,4,4).substr($date,2,2);
# cut Call, Name, QTH, RSTR, RSTS, Mode
$call = substr($call,0,12);
$name = substr($name,0,8);
$qth = substr($qth,0,13);
$rstr = substr($rstr,0,3);
$rsts = substr($rsts,0,3);
$mode = substr($mode,0,5);
if ($y == $aline) { # highlight line?
attron($wlog, COLOR_PAIR(1));
$ret = $nr; # remember the NR
}
if ($screenlayout == 0) {
addstr($wlog,$y,0, sprintf("%-12s%-4s %-5s%-6s",
$call,$band,$mode,$date)); # print formatted
}
elsif ($screenlayout ==1) {
substr($time,-3,)=''; # remove seconds
addstr($wlog,$y,0,
sprintf("%-12s%-4s %-5s%-4s %-6s %-8s %-13s %-3s %-3s %s %s %s ",
$call,$band,$mode,$time,$date,$name,$qth,$rsts,$rstr,
$qsls, $qslr, $qslrl));
}
attron($wlog, COLOR_PAIR(3));
$y--; # move one row up
}
while ($y > -1) { # fill remaining lines
my $width=30;
if ($screenlayout==1) {$width=80;}
addstr($wlog,$y,0," "x$width);
$y--;
}
move($wlog, $aline, 0); # move cursor to highlighted line
refresh($wlog);
return "i" unless ($totalcalls); # no QSOs!
$ch = &getch2(); # get character from keyboard
if ($ch eq KEY_DOWN || $ch eq 'j') { # key down was pressed
if ($aline < ($nbr-1)) { # no scrolling needed
$aline++;
}
elsif ($offset != 0) { # scroll down, when possible (=offset)
# (when there is an offset, it means we have scrolled back, so we can
# safely scroll forth again)
$offset -= $nbr; # next $nr (16 or 8)
$aline = 0; # cursor to highest line
}
}
if ($ch eq KEY_UP || $ch eq 'k') { # key up was pressed
if (($aline > -1) &&
($callsthispage>($nbr-$aline))) { # no scrolling needed
$aline--;
}
elsif ($callsthispage > ($nbr-1)) {
$offset += $nbr; # earlier 16/8
$aline = ($nbr-1); # cursor to lowest line
}
}
if (($ch eq KEY_NPAGE) && ($offset != 0)) { # scroll down 16/8 QSOs
$aline = 0; # first line
$offset -= $nbr; # next 16/8 QSOs
flushinp(); # avoid excessive scrolling
}
elsif (($ch eq KEY_PPAGE) && $callsthispage>7) {# scroll up 16/8 QSOs
$aline = ($nbr-1); # last line
$offset += $nbr; # prev 8/16 QSOs
flushinp(); # avoid excessive scrolling
}
elsif ($ch eq KEY_F(1)) { # go to the MAIN MENU
$goon = 0; # do not go on!
$ret = "m"; # return value m = Menu
}
elsif ($ch eq KEY_F(8)) { # back to inp-window without any action
$goon = 0; # do not go on!
$ret = "i"; # return value i = Input Window
}
elsif ($ch eq KEY_F(10)) { # to QSO b4-window without any action
$goon = 0;
$ret = "q"; # return value q = QSO Window
}
elsif ($ch =~ /\s/) { # we selected a QSO!
$goon=0; # get out of the do .. while loop
}
elsif ($ch eq KEY_F(12)) { # QUIT
endwin;
exit;
}
} while ($goon); # as long as goon is true, we loop
return $ret;
} # &choseqso ends here
##############################################################################
# &getqso Gets a number as parameter and returns the @qso array matching to
# the number from the database. Also updates the content of the Inputfields to
# the QSO. This works for fields 0..13 and is designed for the LOG INPUT mode.
# (There is also geteditqso for the Search/Edit mode).
##############################################################################
sub getqso {
my @qso; # QSO array
my $q = $dbh->prepare("SELECT `CALL`, `DATE`, `T_ON`, `T_OFF`, `BAND`, `MODE`,
`QTH`, `NAME`, `QSLS`, `QSLR`, `RSTS`, `RSTR`, `REM`, `PWR` FROM
log_$mycall WHERE `NR`='$_[0]'");
$q->execute;
@qso = $q->fetchrow_array;
# proper format for the date (yyyy-mm-dd -> ddmmyyyy)
$qso[1] = substr($qso[1],8,2).substr($qso[1],5,2).substr($qso[1],0,4);
# proper format for the times. hh:mm:ss -> hhmm
$qso[2] = substr($qso[2],0,2).substr($qso[2],3,2);
$qso[3] = substr($qso[3],0,2).substr($qso[3],3,2);
for (my $x=0;$x < 14;$x++) { # iterate through all input windows
addstr(${$_[1]}[$x],0,0,$qso[$x]); # add new value from @qso.
refresh(${$_[1]}[$x]);
}
return @qso;
}