X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXProt.pm;h=310416e8dfda883713b863a969a080867e2d55a6;hb=2c3a20bdcef84e620b0c3c2d306a71ebe17956b0;hp=0a1c83ddbce0278dbac19abfa5fc76d4678096c0;hpb=e83b70ecab022dbbeac0b56f67ed2e4bed609e86;p=spider.git diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 0a1c83dd..310416e8 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -34,7 +34,7 @@ use strict; use vars qw($me $pc11_max_age $pc23_max_age $last_hour %pings %rcmds %nodehops @baddx $baddxfn - $allowzero $decode_dk0wcy); + $allowzero $decode_dk0wcy $send_opernam); $me = undef; # the channel id for this cluster $pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11 @@ -96,8 +96,8 @@ sub start # remember type of connection $self->{consort} = $line; $self->{outbound} = $sort eq 'O'; - $self->{priv} = $user->priv; - $self->{lang} = $user->lang; + $self->{priv} = $user->priv || 1; # other clusters can always be 'normal' users + $self->{lang} = $user->lang || 'en'; $self->{isolate} = $user->{isolate}; $self->{consort} = $line; # save the connection type $self->{here} = 1; @@ -158,8 +158,8 @@ sub normal return unless $pcno; return if $pcno < 10 || $pcno > 99; - # dump bad protocol messages unless it is a PC29 - if ($line =~ /\%[0-9A-F][0-9A-F]/o && $pcno != 29) { + # dump bad protocol messages + if ($line =~ /\%[01][0-9A-F]/) { dbg('chan', "CORRUPT protocol message - dumped"); return; } @@ -175,16 +175,24 @@ sub normal SWITCH: { if ($pcno == 10) { # incoming talk + unless (is_callsign($field[1]) && is_callsign($field[2]) && is_callsign($field[6])) { + dbg('chan', "Corrupt talk, rejected"); + return; + } # is it for me or one of mine? - my $call = ($field[5] gt ' ') ? $field[5] : $field[2]; - if ($call eq $main::mycall || grep $_ eq $call, DXChannel::get_all_user_calls()) { - - # yes, it is - my $text = unpad($field[3]); - Log('talk', $call, $field[1], $field[6], $text); - $call = $main::myalias if $call eq $main::mycall; - my $ref = DXChannel->get($call); - $ref->send("$call de $field[1]: $text") if $ref && $ref->{talk}; + my ($to, $via, $call, $dxchan); + if ($field[5] gt ' ') { + $call = $via = $field[2]; + $to = $field[5]; + unless (is_callsign($to)) { + dbg('chan', "Corrupt talk, rejected"); + return; + } + } else { + $call = $to = $field[2]; + } + if ($dxchan = DXChannel->get($call)) { + $dxchan->talk($field[1], $to, $via, $field[3]); } else { $self->route($field[2], $line); # relay it on its way } @@ -193,6 +201,16 @@ sub normal if ($pcno == 11 || $pcno == 26) { # dx spot + # are any of the callsign fields invalid? + unless ($field[2] !~ m/[^A-Z0-9\-\/]/ && is_callsign($field[6]) && is_callsign($field[7])) { + dbg('chan', "Spot contains lower case callsigns or blanks, rejected"); + return; + } + if ($field[1] =~ m/[^0-9\.]/) { + dbg('chan', "Spot frequency not numeric, rejected"); + return; + } + # route 'foreign' pc26s if ($pcno == 26) { if ($field[7] ne $main::mycall) { @@ -220,12 +238,6 @@ sub normal dbg('chan', "Bad DX spot, ignored"); return; } - - # are any of the crucial fields invalid? - if ($field[2] =~ /(?:^\s*$|[a-z])/ || $field[6] =~ /(?:^\s*$|[a-z])/ || $field[7] =~ /(?:^\s*$|[a-z])/) { - dbg('chan', "Spot contains lower case callsigns or blanks, rejected"); - return; - } # do some de-duping $field[5] =~ s/^\s+//; # take any leading blanks off @@ -247,7 +259,7 @@ sub normal my $user = DXUser->get_current($spot[4]); if ($user) { my $qra = $user->qra; - if (!DXBearing::is_qra) { + unless ($qra && DXBearing::is_qra($qra)) { my $lat = $user->lat; my $long = $user->long; if (defined $lat && defined $long) { @@ -255,6 +267,35 @@ sub normal $user->put; } } + + # send a remote command to a distant cluster if it is visible and there is no + # qra locator and we havn't done it for a month. + + unless ($user->qra) { + my $node; + my $to = $user->homenode; + my $last = $user->lastoper || 0; + if ($send_opernam && $main::systime > $last + $DXUser::lastoperinterval && $to && ($node = DXCluster->get_exact($to)) ) { + my $cmd = "forward/opernam $spot[4]"; + # send the rcmd but we aren't interested in the replies... + if ($node && $node->dxchan && $node->dxchan->is_clx) { + route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd)); + } else { + route(undef, $to, pc34($main::mycall, $to, $cmd)); + } + if ($to ne $field[7]) { + $to = $field[7]; + $node = DXCluster->get_exact($to); + if ($node && $node->dxchan && $node->dxchan->is_clx) { + route(undef, $to, pc84($main::mycall, $to, $main::mycall, $cmd)); + } else { + route(undef, $to, pc34($main::mycall, $to, $cmd)); + } + } + $user->lastoper($main::systime); + $user->put; + } + } } # local processing @@ -274,6 +315,11 @@ sub normal } if ($pcno == 12) { # announces + unless (is_callsign($field[1]) && is_callsign($field[2]) && is_callsign($field[5])) { + dbg('chan', "Corrupt announce, rejected"); + return; + } + # announce duplicate checking $field[3] =~ s/^\s+//; # remove leading blanks if (AnnTalk::dup($field[1], $field[2], $field[3])) { @@ -590,7 +636,7 @@ sub normal my $ref = DXUser->get_current($field[2]); my $cref = DXCluster->get($field[2]); Log('rcmd', 'in', $ref->{priv}, $field[2], $field[3]); - unless ($field[3] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) { # not allowed to relay RCMDS! + unless (!$cref || !$ref || $cref->mynode->call ne $ref->homenode) { # not allowed to relay RCMDS! if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering $self->{remotecmd} = 1; # for the benefit of any command that needs to know my $oldpriv = $self->{priv}; @@ -627,6 +673,10 @@ sub normal my $dxchan = DXChannel->get($s->{call}); $dxchan->send($field[3]) if $dxchan; delete $rcmds{$field[2]} if !$dxchan; + } else { + # send unsolicited ones to the sysop + my $dxchan = DXChannel->get($main::myalias); + $dxchan->send($field[3]) if $dxchan; } } else { my $ref = DXUser->get_current($field[1]); @@ -668,11 +718,11 @@ sub normal my ($lat, $long) = DXBearing::stoll($field[3]); $user->lat($lat); $user->long($long); - my $qra = $user->qra || DXBearing::lltoqra($lat, $long); - $qra = DXBearing::lltoqra($lat, $long) unless DXBearing::is_qra($qra); + $user->qra(DXBearing::lltoqra($lat, $long)) unless $user->qra && DXBearing::is_qra($user->qra); } elsif ($field[2] == 4) { $user->homenode($field[3]); } + $user->lastoper($main::systime); # to cut down on excessive for/opers being generated $user->put; last SWITCH; } @@ -770,7 +820,7 @@ sub normal my $ref = DXUser->get_current($field[2]); my $cref = DXCluster->get($field[2]); Log('rcmd', 'in', $ref->{priv}, $field[2], $field[4]); - unless ($field[3] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) { # not allowed to relay RCMDS! + unless ($field[4] =~ /rcmd/i || !$cref || !$ref || $cref->mynode->call ne $ref->homenode) { # not allowed to relay RCMDS! if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering $self->{remotecmd} = 1; # for the benefit of any command that needs to know my $oldpriv = $self->{priv}; @@ -794,7 +844,7 @@ sub normal if ($ref && $ref->is_clx) { $self->route($field[1], $line); } else { - route($field[1], pc34($field[2], $field[1], $field[3])); + route($field[1], pc34($field[2], $field[1], $field[4])); } } return; @@ -811,6 +861,10 @@ sub normal $dxchan = DXChannel->get($s->{call}); $dxchan->send($field[4]) if $dxchan; delete $rcmds{$field[2]} if !$dxchan; + } else { + # send unsolicited ones to the sysop + my $dxchan = DXChannel->get($main::myalias); + $dxchan->send($field[4]) if $dxchan; } } } else { @@ -818,7 +872,7 @@ sub normal if ($ref && $ref->is_clx) { $self->route($field[1], $line); } else { - route($field[1], pc35($field[2], $field[1], $field[3])); + route($field[1], pc35($field[2], $field[1], $field[4])); } } return; @@ -957,9 +1011,9 @@ sub send_dx_spot $dxchan->send($routeit) unless $dxchan->{isolate} || $self->{isolate}; } } elsif ($dxchan->is_user && $dxchan->{dx}) { - my $buf = Spot::formatb($_[0], $_[1], $_[2], $_[3], $_[4]); + my $buf = Spot::formatb($dxchan->{user}->wantgrid, $_[0], $_[1], $_[2], $_[3], $_[4]); $buf .= "\a\a" if $dxchan->{beep}; - if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') { + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { $dxchan->send($buf); } else { $dxchan->delay($buf); @@ -1003,7 +1057,7 @@ sub send_wwv_spot } elsif ($dxchan->is_user && $dxchan->{wwv}) { my $buf = "WWV de $_[6] <$_[1]>: SFI=$_[2], A=$_[3], K=$_[4], $_[5]"; $buf .= "\a\a" if $dxchan->{beep}; - if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') { + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { $dxchan->send($buf); } else { $dxchan->delay($buf); @@ -1046,7 +1100,7 @@ sub send_wcy_spot } elsif ($dxchan->is_user && $dxchan->{wcy}) { my $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]"; $buf .= "\a\a" if $dxchan->{beep}; - if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') { + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { $dxchan->send($buf); } else { $dxchan->delay($buf); @@ -1110,7 +1164,7 @@ sub send_announce next if $target eq 'SYSOP' && $dxchan->{priv} < 5; my $buf = "$to$target de $_[0]: $text"; $buf .= "\a\a" if $dxchan->{beep}; - if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') { + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { $dxchan->send($buf); } else { $dxchan->delay($buf); @@ -1261,7 +1315,7 @@ sub broadcast_list $s =~ s/\a//og unless $dxchan->{beep}; - if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'convers') { + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { $dxchan->send($s); } else { $dxchan->delay($s); @@ -1371,5 +1425,23 @@ sub disconnect $self->SUPER::disconnect; } + +# check that a field only has callsign characters in it +sub is_callsign +{ + return $_[0] !~ /[^A-Z0-9\-]/ +} + +# +# send a talk message to this thingy +# +sub talk +{ + my ($self, $from, $to, $via, $line) = @_; + + $line =~ s/\^/\\5E/g; # remove any ^ characters + $self->send(DXProt::pc10($from, $to, $via, $line)); + Log('talk', $self->call, $from, $via?$via:$main::mycall, $line); +} 1; __END__