From 7432cb12ce865030c8b0315a30764e0088a59102 Mon Sep 17 00:00:00 2001 From: djk Date: Sun, 20 Sep 1998 11:52:42 +0000 Subject: [PATCH] did some work on the cluster database related things --- perl/DXChannel.pm | 6 ++++-- perl/DXCluster.pm | 24 +++++++++------------- perl/DXCommandmode.pm | 25 ++++++++++++++++++++++- perl/DXProt.pm | 47 +++++-------------------------------------- perl/Prefix.pm | 4 ++-- perl/Spot.pm | 11 +++++----- perl/cluster.pl | 3 +++ perl/dxcc.pl | 13 ++++++++++-- 8 files changed, 65 insertions(+), 68 deletions(-) diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 519a0b48..7d835171 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -32,10 +32,11 @@ use DXDebug; use Carp; use strict; +use vars qw(%channels %valid); -my %channels = undef; +%channels = undef; -my %valid = ( +%valid = ( call => '0,Callsign', conn => '9,Msg Conn ref', user => '9,DXUser ref', @@ -55,6 +56,7 @@ my %valid = ( here => '0,Here?,yesno', confmode => '0,In Conference?,yesno', dx => '0,DX Spots,yesno', + redirect => '0,Redirect messages to', ); # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] diff --git a/perl/DXCluster.pm b/perl/DXCluster.pm index 9560ba57..2ddd2358 100644 --- a/perl/DXCluster.pm +++ b/perl/DXCluster.pm @@ -20,10 +20,11 @@ use Carp; use DXDebug; use strict; +use vars qw(%cluster %valid); -my %cluster = (); # this is where we store the dxcluster database +%cluster = (); # this is where we store the dxcluster database -my %valid = ( +%valid = ( mynode => '0,Parent Node,showcall', call => '0,Callsign', confmode => '0,Conference Mode,yesno', @@ -61,13 +62,6 @@ sub get_all return values(%cluster); } -sub delcluster; -{ - my $self = shift; - delete $cluster{$self->{call}}; -} - - # return a prompt for a field sub field_prompt { @@ -138,9 +132,9 @@ sub new my $self = $pkg->alloc($dxchan, $call, $confmode, $here); $self->{mynode} = $node; - $self->{list}->{$call} = $self; # add this user to the list on this node + $node->{list}->{$call} = $self; # add this user to the list on this node $users++; - dbg('cluster', "allocating user $self->{call}\n"); + dbg('cluster', "allocating user $call to $node->{call} in cluster\n"); return $self; } @@ -151,7 +145,8 @@ sub del my $node = $self->{mynode}; delete $node->{list}->{$call}; - delete $cluster{$call}; # remove me from the cluster table + delete $DXCluster::cluster{$call}; # remove me from the cluster table + dbg('cluster', "deleting user $call from $node->{call} in cluster\n"); $users-- if $users > 0; } @@ -182,7 +177,7 @@ sub new $self->{version} = $pcversion; $self->{list} = { } ; $nodes++; - dbg('cluster', "allocating node $self->{call}\n"); + dbg('cluster', "allocating node $call to cluster\n"); return $self; } @@ -191,7 +186,7 @@ sub get_all { my $list; my @out; - foreach $list (values(%cluster)) { + foreach $list (values(%DXCluster::cluster)) { push @out, $list if $list->{pcversion}; } return @out; @@ -207,6 +202,7 @@ sub del foreach $ref (values %{$self->{list}}) { $ref->del(); # this also takes them out of this list } + dbg('cluster', "deleting node $call from cluster\n"); $nodes-- if $nodes > 0; } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 9f7b3885..d39af559 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -59,7 +59,16 @@ sub start # set some necessary flags on the user if they are connecting $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; $self->prompt() if $self->{state} =~ /^prompt/o; - + + # add yourself to the database + my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; + my $cuser = DXNodeuser->new($self, $node, $call, 0, 1); + $node->dxchan($self) if $call eq $main::myalias; # send all output for mycall to myalias + + # issue a pc16 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my $pc16 = $nchan->pc16($cuser); + DXProt::broadcast_ak1a($pc16); } # @@ -133,7 +142,21 @@ sub process # sub finish { + my $self = shift; + my $call = $self->call; + if ($call eq $main::myalias) { # unset the channel if it is us really + my $node = DXNode->get($main::mycall); + $node->{dxchan} = 0; + } + my $ref = DXNodeuser->get($call); + + # issue a pc17 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my $pc17 = $nchan->pc17($ref); + DXProt::broadcast_ak1a($pc17); + + $ref->del() if $ref; } # diff --git a/perl/DXProt.pm b/perl/DXProt.pm index f825ebb8..d75dd46c 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -23,14 +23,15 @@ use Date::Parse; use DXProtout; use strict; +use vars qw($me); -my $me; # the channel id for this cluster +$me = undef; # the channel id for this cluster sub init { my $user = DXUser->get($main::mycall); - $me = DXChannel::alloc('DXProt', $main::mycall, undef, $user); - $me->{sort} = 'M'; # M for me + $me = DXProt->new($main::mycall, undef, $user); +# $me->{sort} = 'M'; # M for me } # @@ -157,7 +158,7 @@ sub normal last SWITCH if !$node; # ignore if havn't seen a PC19 for this one yet my $i; - for ($i = 2; $i < $#field-1; $i++) { + for ($i = 2; $i < $#field; $i++) { my ($call, $confmode, $here) = $field[$i] =~ /^(\w+) (-) (\d)/o; next if length $call < 3; next if !$confmode; @@ -324,44 +325,6 @@ sub finish { my $self = shift; broadcast_ak1a($self->pc21('Gone.')); - $self->delnode(); -} - -# -# add a (local) user to the cluster -# - -sub adduser -{ - DXNodeuser->add(@_); -} - -# -# delete a (local) user to the cluster -# - -sub deluser -{ - my $self = shift; - my $ref = DXCluster->get($self->call); - $ref->del() if $ref; -} - -# -# add a (locally connected) node to the cluster -# - -sub addnode -{ - DXNode->new(@_); -} - -# -# delete a (locally connected) node to the cluster -# -sub delnode -{ - my $self = shift; my $ref = DXCluster->get($self->call); $ref->del() if $ref; } diff --git a/perl/Prefix.pm b/perl/Prefix.pm index b9e235cd..5f23fce9 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -145,9 +145,9 @@ sub extract # remove any /0-9 /P /A /M /MM /AM suffixes etc if (@parts > 1) { $p = $parts[$#parts]; - pop @parts if $p =~ /^\d+|[PABM]|AM|MM|BCN|SIX$/o; + pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX)$/o; $p = $parts[$#parts]; - pop @parts if $p =~ /^\d+|[PABM]|AM|MM|BCN|SIX$/o; + pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX)$/o; # can we resolve them by direct lookup foreach $p (@parts) { diff --git a/perl/Spot.pm b/perl/Spot.pm index 64af363e..08520c5b 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -18,12 +18,13 @@ use Carp; @ISA = qw(Julian); use strict; +use vars qw($fp $maxspots $defaultspots $maxdays $dirprefix); -my $fp; -my $maxspots = 50; # maximum spots to return -my $defaultspots = 10; # normal number of spots to return -my $maxdays = 35; # normal maximum no of days to go back -my $dirprefix = "$main::data/spots"; +$fp = undef; +$maxspots = 50; # maximum spots to return +$defaultspots = 10; # normal number of spots to return +$maxdays = 35; # normal maximum no of days to go back +$dirprefix = "$main::data/spots"; sub prefix { diff --git a/perl/cluster.pl b/perl/cluster.pl index e98dd156..e3309a15 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -185,6 +185,9 @@ $SIG{'HUP'} = 'IGNORE'; # initialise the protocol engine DXProt->init(); +# put in a DXCluster node for us here so we can add users and take them away +DXNode->new(0, $mycall, 0, 1, $DXProtvars::myprot_version); + # this, such as it is, is the main loop! print "orft we jolly well go ...\n"; for (;;) { diff --git a/perl/dxcc.pl b/perl/dxcc.pl index 3b4d97f0..889b62e9 100755 --- a/perl/dxcc.pl +++ b/perl/dxcc.pl @@ -1,6 +1,7 @@ #!/usr/bin/perl # -# convert an Ak1a DX.DAT file to comma delimited form +# Analyse the dxcc info in the prefix database, listing the 'official' country and its number +# and also looking for duplicates and missing numbers # # @@ -15,8 +16,16 @@ sub comp return ($a->dxcc()-0) <=> ($b->dxcc()-0); } +$lastdxcc = 0; foreach $ref (sort {$a->dxcc() <=> $b->dxcc()} values %Prefix::prefix_loc) { $name = $ref->name(); $dxcc = $ref->dxcc(); - print "dxcc: $dxcc name: $name\n"; + while ($lastdxcc < $dxcc - 1) { + ++$lastdxcc; + print "dxcc: $lastdxcc name: ** MISSING\n"; + } + $dup = ""; + $dup = "** DUPLICATE" if $dxcc == $lastdxcc; + print "dxcc: $dxcc name: $name $dup\n"; + $lastdxcc = $dxcc; } -- 2.34.1