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.
18 Commits
2 Branches
0 Tags
8.5 MiB
Tree: 3eacb00254
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '3eacb00254'
${ noResults }
yfklog/yfksubs.pl

5606 lines
178 KiB
Raw Normal View History Unescape

Initial import of yfklog
16 years ago
#!/usr/bin/perl -w
# identation looks best with tw=4
# Several subroutines for yfklog, a amateur radio logbook software
#
# Copyright (C) 2005-2007 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
Now deletes old logbooks
15 years ago
changemycall newlogtable oldlogtable choseeditqso geteditqso editw updateqso checkdate
Initial import of yfklog
16 years ago
awards statistics qslstatistics editdb editdbw savedbedit lotwimport
databaseupgrade xplanet queryrig tableexists changeconfig readsubconfig
connectdb connectrig jumpfield receive_qso);
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);
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 $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
To match hamlib new version and cosmetic changes to delete old logbooks
15 years ago
our $prefix="/usr/"; # may be changed by 'make'
Initial import of yfklog
16 years ago
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="A"; # Order of prev. QSOs
our $browser='dillo';
our $hamlibtcpport = 4532;
# 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 =~ /^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;
}
}
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 {
}
# Now we read cty.dat from K1EA, or exit when it's not found.
Look for local cty.dat
16 years ago
my $ctydat = "$prefix/share/yfklog/cty.dat";
if (-R "./cty.dat") {
$ctydat = "./cty.dat";
}
open CTY, "$ctydat" or die "$ctydat not found.".
Initial import of yfklog
16 years ago
"Please download it from http://country-files.com/\n";
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;
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 K1EA at http://www.k1ea.com/cty/cty.dat .
# An example entry of the file looks like this:
#
# Portugal: 14: 37: EU: 38.70: 9.20: 0.0: CT:
# CQ,CR,CR5A,CR5EBD,CR6EDX,CR7A,CR8A,CR8BWW,CS,CS98,CT,CT98;
#
# The first line contains the name of the country, WAZ, ITU zones, continent,
# latitude, longitude, UTC difference and main Prefix, the second line contains
# possible Prefixes and/or whole callsigns that fit for the country, sometimes
# followed by zones in brackets (WAZ in (), ITU in []).
#
# 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 ($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 =~ /\//) { # 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.
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
# 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
}
# 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;
}
# 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`='$qso[6]', `NAME`='$qso[7]',
`QSLS`='$qso[8]', `QSLR`='$qso[9]', `RSTS`='$qso[10]',
`RSTR`='$qso[11]', `REM`='$qso[12]', `PWR`='$qso[13]'
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]', '$qso[6]', '$qso[7]',
'$qso[8]', '$qso[9]', '$qso[10]', '$qso[11]',
'$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', '$qso[7]', '$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. F5 --> Reads frequency and mode from the rig
# 3. F9 --> return 2 as next active window $aw. --> $wlog.
# 4. 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 string
my $wlog = ${$_[4]}; # reference to log-windw
my $editnr = ${$_[5]}; # reference to editnr
my $debug=0;
my $ovr = $_[6]; # overwrite
my $maxlen = $_[7];
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
addstr($win,0,0, $input." "x80); # pass $input to window,
# delete all after $input.
$pos-- if ($pos == $maxlen);
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) < $maxlen) || ($pos < $maxlen && $ovr))
) {
unless ($_[1] == 3) { # Unless Name, QTH mode
$ch =~ tr/[a-z]/[A-Z]/; # make letters uppercase
}
$pos++;
if ($ovr) {
$input = substr($input, 0, $pos-1).$ch.substr($input, $pos >
length($input) ? $pos-1 : $pos, );
}
else {
$input = substr($input, 0, $pos-1).$ch.substr($input, $pos-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-- }
}
elsif ($ch eq KEY_RIGHT) {
if ($pos < length($input)) { $pos++ }
}
elsif (($ch eq KEY_DC) && ($pos < length($input))) { # Delete key
$input = substr($input, 0, $pos).substr($input, $pos+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))
&& ($pos > 0)) {
$input = substr($input, 0, $pos-1).substr($input, $pos, );
$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 gues 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]},$editnr)) { # save @QSO to DB
&clearinputfields($_[0],1); # clear input fields 0..13
@{$_[3]} = ("","","","","","","","","","","","","","");
# 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 go 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]}[$_]);
}
foreach (@{$_[3]}) { # iterate through QSO-array
$_=""; # clear content
}
${$_[5]} = 0; # editqso = 0
return 4; # return 4 -> to window 0 (call)
}
}
# 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
}
# F7 -> go to remote mode for fldigi
elsif ($ch eq KEY_F(6)) {
my $lookup = ${$_[3]}[0];
unless ($lookup) { $lookup = $input };
system("$browser http://www.qrz.com/$lookup &> /dev/null &");
}
# 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
endwin; # Leave curses mode
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 = 16;
$y=15; # y-position in $wlog
}
elsif ($screenlayout == 1) { # windows above each other, 8 QSOs
$nr = 8;
$y=7; # y-position in $wlog
}