mirror of
git://scm.dxcluster.org/scm/spider
synced 2024-09-21 07:47:10 +00:00
Merge branch 'SIMPLEROUTE'
and tag as 1.55 Conflicts: .gitignore data/.gitignore perl/DXProt.pm perl/Version.pm
This commit is contained in:
Dirk Koopman
commit
d2580480d2
6
.gitignore
vendored
6
.gitignore
vendored
@ -1,6 +1,10 @@
|
||||
local*
|
||||
*~
|
||||
*.[oa]
|
||||
*.oo
|
||||
*.ooo
|
||||
*.oooo
|
||||
*.ooooo
|
||||
*.tmp
|
||||
CVS
|
||||
tmp
|
||||
@ -14,3 +18,5 @@ tmp
|
||||
packclus
|
||||
tutor*
|
||||
db
|
||||
core
|
||||
a.out
|
||||
|
||||
20
Changes
20
Changes
@ -1,5 +1,15 @@
|
||||
21Jun06=======================================================================
|
||||
1. merge back SIMPLEROUTE branch to issue as official 1.54.
|
||||
18Jun06=======================================================================
|
||||
1. add a optional dependency on Encode (included in 5.8.x) to encode strings
|
||||
to latin1 for deduping purposes, hopefully getting rid of some dupes.
|
||||
2. add a default INPUT filter for a node (by_dxcc <node's country>) if no
|
||||
specific or default INPUT node exists.
|
||||
13Jun06=======================================================================
|
||||
1. start using git.
|
||||
2. change all the version / build numbering.
|
||||
14Jun07=======================================================================
|
||||
1. prepare for git repository and moving of anon cvs repository to
|
||||
1. prepare for git repository and moving of anon cvs repository to
|
||||
scm.tobit.co.uk.
|
||||
11Jun07=======================================================================
|
||||
1. Change the frequency normalisation for DX Spot dupe checks so that any
|
||||
@ -14,12 +24,12 @@ decimal part is thrown away (in other words: truncate the freq to integer khz)
|
||||
04Mar07=======================================================================
|
||||
1. add CTY 1702 prefix data files
|
||||
22Feb07=======================================================================
|
||||
1. add show/myfdx to Aliases.
|
||||
1. add show/myfdx to Aliases.
|
||||
15Feb07=======================================================================
|
||||
1. allow convkeps.pl to parse NORAD keps files.
|
||||
22Jan07=======================================================================
|
||||
1. disable default propagation of PC9x sentences
|
||||
2. simplify PC17 handling
|
||||
2. simplify PC17 handling
|
||||
16Jan07=======================================================================
|
||||
1. back ported a change to PC16 handling so that a locally connected node's
|
||||
info clears out and generally overrides any residual PC16 info gathered from
|
||||
@ -27,7 +37,7 @@ elsewhere.
|
||||
15Jan07=======================================================================
|
||||
1. added CTY-1701
|
||||
07Jan07=======================================================================
|
||||
1. use IO::Socket blocking where available and switch off or ignore all
|
||||
1. use IO::Socket blocking where available and switch off or ignore all
|
||||
attempts to block.
|
||||
05Jan07=======================================================================
|
||||
1. increase default ephemeral deduping on PC15 to 6 minutes (from 2).
|
||||
@ -348,7 +358,7 @@ line. Also added sh/fdx as an alias.
|
||||
01Jan04=======================================================================
|
||||
1. move position of USDB init to get rid of an obscure bug pointed out by
|
||||
Charlie K1XX.
|
||||
2. Remove redundant documentation
|
||||
2. Remove redundant documentation.
|
||||
31Dec03=======================================================================
|
||||
1. alter remote database handling to 'new standard'.
|
||||
30Dec03=======================================================================
|
||||
|
||||
11
cmd/Aliases
11
cmd/Aliases
@ -131,12 +131,11 @@ package CmdAlias;
|
||||
'^sho?w?/myd?x?/(\d+)-(\d+)', 'show/dx filter $1-$2', 'show/mydx',
|
||||
'^sho?w?/myd?x?/(\d+)', 'show/dx filter $1', 'show/mydx',
|
||||
'^sho?w?/myd?x?/d(\d+)', 'show/dx filter from $1', 'show/mydx',
|
||||
'^sho?w?/myd?x?', 'show/dx filter', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/(\d+)-(\d+)', 'show/dx filter real $1-$2', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/(\d+)', 'show/dx filter real $1', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/d(\d+)', 'show/dx filter real from $1', 'show/mydx',
|
||||
'^sho?w?/myfd?x?', 'show/dx filter real', 'show/mydx',
|
||||
|
||||
'^sho?w?/myd?x?', 'show/dx filter real', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/(\d+)-(\d+)', 'show/dx filter real $1-$2', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/(\d+)', 'show/dx filter real $1', 'show/mydx',
|
||||
'^sho?w?/myfd?x?/d(\d+)', 'show/dx filter real from $1', 'show/mydx',
|
||||
'^sho?w?/myfd?x?', 'show/dx filter real', 'show/mydx',
|
||||
'^sho?w?/newco?n?\w*/n', 'show/newconfiguration node', 'show/newconfiguration',
|
||||
'^sho?w?/sta?$', 'show/station', 'show/station',
|
||||
'^sho?w?/tnc', 'who', 'who',
|
||||
|
||||
@ -22,32 +22,25 @@ return (1, $self->msg('e9')) if !@f;
|
||||
return (1, $self->msg('e28')) unless $self->registered;
|
||||
|
||||
my $sort = uc $f[0];
|
||||
my @locals = DXCommandmode->get_all();
|
||||
my $to;
|
||||
my $to = '*';
|
||||
my $from = $self->call;
|
||||
my $t = ztime(time);
|
||||
my $tonode;
|
||||
my $toflag = '*';
|
||||
my $sysopflag;
|
||||
my $via = 'LOCAL';
|
||||
|
||||
if ($sort eq "FULL") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
$to = "ALL";
|
||||
$via = $to = "*";
|
||||
} elsif ($sort eq "SYSOP") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
@locals = map { $_->priv >= 5 ? $_ : () } @locals;
|
||||
$to = "SYSOP";
|
||||
$sysopflag = '*';
|
||||
$via = $sysopflag = '*';
|
||||
} elsif ($sort eq "LOCAL") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
$to = "LOCAL";
|
||||
} else {
|
||||
$to = "LOCAL";
|
||||
}
|
||||
|
||||
# change ^ into : for transmission
|
||||
$line =~ s/\^/:/og;
|
||||
|
||||
# if this is a 'bad spotter' user then ignore it
|
||||
my $nossid = $from;
|
||||
my $drop = 0;
|
||||
@ -67,16 +60,18 @@ if (@bad = BadWords::check($line)) {
|
||||
|
||||
if ($drop) {
|
||||
Log('ann', $to, $from, "[to $from only] $line");
|
||||
$self->send("To $to de $from <$t>: $line");
|
||||
$self->send("To $to de $from: $line");
|
||||
return (1, ());
|
||||
}
|
||||
|
||||
return (1, $self->msg('dup')) if $self->priv < 5 && AnnTalk::dup($from, $toflag, $line);
|
||||
Log('ann', $to, $from, $line);
|
||||
DXChannel::broadcast_list("To $to de $from ($t): $line\a", 'ann', undef, @locals);
|
||||
if ($to ne "LOCAL") {
|
||||
my $pc = DXProt::pc12($from, $line, $tonode, $sysopflag, 0);
|
||||
DXChannel::broadcast_nodes($pc);
|
||||
}
|
||||
$main::me->normal(DXProt::pc93($to, $from, $via, $line));
|
||||
|
||||
#DXChannel::broadcast_list("To $to de $from ($t): $line\a", 'ann', undef, @locals);
|
||||
#if ($to ne "LOCAL") {
|
||||
# my $pc = DXProt::pc12($from, $line, $tonode, $sysopflag, 0);
|
||||
# DXChannel::broadcast_nodes($pc);
|
||||
#}
|
||||
|
||||
return (1, ());
|
||||
|
||||
@ -38,6 +38,8 @@ if (@bad = BadWords::check($line)) {
|
||||
my $msgid = DXProt::nextchatmsgid();
|
||||
$text = "#$msgid $text";
|
||||
|
||||
DXProt::send_chat($self, DXProt::pc12($from, $text, '*', $target), $from, '*', $text, $target, $main::mycall, '0');
|
||||
$main::me->normal(DXProt::pc93($target, $from, undef, $text));
|
||||
|
||||
#DXProt:):send_chat($self, 1, DXProt::pc12($from, $text, '*', $target), $from, '*', $text, $target, $main::mycall, '0');
|
||||
|
||||
return (1, ());
|
||||
|
||||
@ -16,7 +16,7 @@ my @out;
|
||||
my $nowt = time;
|
||||
|
||||
push @out, " Ave Obs Ping Sec Since";
|
||||
push @out, " Callsign Type Started RTT count Int. Last Ping";
|
||||
push @out, " Callsign Type Started RTT count Int. Last Ping PC92";
|
||||
|
||||
foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all_nodes ) {
|
||||
my $call = $dxchan->call();
|
||||
@ -34,7 +34,8 @@ foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all_nodes ) {
|
||||
$sort = "DXNT" if $dxchan->is_dxnet;
|
||||
$sort = "AR-C" if $dxchan->is_arcluster;
|
||||
$sort = "AK1A" if $dxchan->is_ak1a;
|
||||
push @out, sprintf "%10s $sort $t$ping $obscount %5d %5d", $call, $pingint, $lastt;
|
||||
my $pc92 = $dxchan->do_pc9x ? 'Y' : '';
|
||||
push @out, sprintf "%10s $sort $t$ping $obscount %5d %5d $pc92", $call, $pingint, $lastt;
|
||||
}
|
||||
|
||||
return (1, @out)
|
||||
|
||||
19
cmd/talk.pl
19
cmd/talk.pl
@ -30,38 +30,45 @@ if ($via) {
|
||||
|
||||
$to = uc $to if $to;
|
||||
$via = uc $via if $via;
|
||||
my $call = $via ? $via : $to;
|
||||
my $call = $via || $to;
|
||||
my $clref = Route::get($call); # try an exact call
|
||||
my $dxchan = $clref->dxchan if $clref;
|
||||
return (1, $self->msg('e7', $call)) unless $dxchan;
|
||||
#return (1, $self->msg('e7', $call)) unless $dxchan;
|
||||
return (1, $self->msg('e28')) unless $self->registered || $to eq $main::myalias;
|
||||
|
||||
#$DB::single = 1;
|
||||
|
||||
# default the 'via'
|
||||
#$via ||= '*';
|
||||
|
||||
# if there is a line send it, otherwise add this call to the talk list
|
||||
# and set talk mode for command mode
|
||||
if ($line) {
|
||||
my @bad;
|
||||
Log('talk', $to, $from, '>' . ($via || ($dxchan && $dxchan->call) || '*'), $line);
|
||||
if (@bad = BadWords::check($line)) {
|
||||
$self->badcount(($self->badcount||0) + @bad);
|
||||
LogDbg('DXCommand', "$self->{call} swore: $line (with words:" . join(',', @bad) . ")");
|
||||
} else {
|
||||
$dxchan->talk($self->call, $to, $via, $line) if $dxchan;
|
||||
$main::me->normal(DXProt::pc93($to, $self->call, $via, $line));
|
||||
}
|
||||
} else {
|
||||
my $s = $to;
|
||||
$s .= ">$via" if $via;
|
||||
$s .= ">$via" if $via && $via ne '*';
|
||||
my $ref = $self->talklist;
|
||||
if ($ref) {
|
||||
unless (grep { $_ eq $s } @$ref) {
|
||||
$dxchan->talk($self->call, $to, $via, $self->msg('talkstart'));
|
||||
$main::me->normal(DXProt::pc93($to, $self->call, $via, $self->msg('talkstart')));
|
||||
$self->state('talk');
|
||||
push @$ref, $s;
|
||||
}
|
||||
} else {
|
||||
$self->talklist([ $s ]);
|
||||
$dxchan->talk($self->call, $to, $via, $self->msg('talkstart'));
|
||||
$main::me->normal(DXProt::pc93($to, $self->call, $via, $self->msg('talkstart')));
|
||||
push @out, $self->msg('talkinst');
|
||||
$self->state('talk');
|
||||
}
|
||||
Log('talk', $to, $from, '>' . ($via || ($dxchan && $dxchan->call) || '*'), $self->msg('talkstart'));
|
||||
push @out, $self->talk_prompt;
|
||||
}
|
||||
|
||||
|
||||
48
cmd/wx.pl
48
cmd/wx.pl
@ -17,32 +17,52 @@
|
||||
my ($self, $line) = @_;
|
||||
my @f = split /\s+/, $line;
|
||||
my $sort = uc $f[0];
|
||||
my @locals = DXCommandmode->get_all();
|
||||
my $to;
|
||||
my $from = $self->call;
|
||||
my $t = ztime(time);
|
||||
my $tonode;
|
||||
my $sysopflag;
|
||||
my $via;
|
||||
return (1, $self->msg('e5')) if $self->remotecmd || $self->inscript;
|
||||
return (1, $self->msg('e28')) unless $self->registered;
|
||||
|
||||
if ($sort eq "FULL") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
$to = "ALL";
|
||||
} elsif ($sort eq "SYSOP") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
@locals = map { $_->priv >= 5 ? $_ : () } @locals;
|
||||
$to = "SYSOP";
|
||||
$sysopflag = '*';
|
||||
} else {
|
||||
$to = "LOCAL";
|
||||
$via = "LOCAL";
|
||||
}
|
||||
$to = 'WX';
|
||||
|
||||
# if this is a 'bad spotter' user then ignore it
|
||||
my $nossid = $from;
|
||||
my $drop = 0;
|
||||
$nossid =~ s/-\d+$//;
|
||||
if ($DXProt::badspotter->in($nossid)) {
|
||||
LogDbg('DXCommand', "bad spotter ($self->{call}) made announcement: $line");
|
||||
$drop++;
|
||||
}
|
||||
|
||||
DXChannel::broadcast_list("WX de $from <$t>: $line", 'wx', undef, @locals);
|
||||
if ($to ne "LOCAL") {
|
||||
$line =~ s/\^//og; # remove ^ characters!
|
||||
my $pc = DXProt::pc12($from, $line, $tonode, $sysopflag, 1);
|
||||
DXChannel::broadcast_nodes($pc, $main::me);
|
||||
# have they sworn?
|
||||
my @bad;
|
||||
if (@bad = BadWords::check($line)) {
|
||||
$self->badcount(($self->badcount||0) + @bad);
|
||||
LogDbg('DXCommand', "$self->{call} swore: $line (with words:" . join(',', @bad) . ")");
|
||||
$drop++;
|
||||
}
|
||||
|
||||
if ($drop) {
|
||||
Log('ann', $to, $from, "[to $from only] $line");
|
||||
$self->send("WX de $from: $line");
|
||||
return (1, ());
|
||||
}
|
||||
|
||||
Log('ann', $via ? $via : '*', $from, $line);
|
||||
$main::me->normal(DXProt::pc93($to, $from, $via, $line));
|
||||
|
||||
#DXChannel::broadcast_list("WX de $from <$t>: $line", 'wx', undef, @locals);
|
||||
#if ($to ne "LOCAL") {
|
||||
# $line =~ s/\^//og; # remove ^ characters!
|
||||
# my $pc = DXProt::pc12($from, $line, $tonode, $sysopflag, 1);
|
||||
# DXChannel::broadcast_nodes($pc, $main::me);
|
||||
#}
|
||||
|
||||
return (1, ());
|
||||
|
||||
1
data/.gitignore
vendored
1
data/.gitignore
vendored
@ -11,3 +11,4 @@ wcy
|
||||
motd*
|
||||
issue
|
||||
logout
|
||||
connected
|
||||
|
||||
@ -278,6 +278,7 @@
|
||||
'9L' => '301',
|
||||
'9M0' => '261',
|
||||
'9M2' => '302',
|
||||
'9M2/PG5M' => '261',
|
||||
'9M4' => '302',
|
||||
'9M4SAB' => '303,527',
|
||||
'9M4SDX' => '261',
|
||||
@ -962,6 +963,7 @@
|
||||
'GB0SSF' => '64,351',
|
||||
'GB0TCH' => '62',
|
||||
'GB0TD' => '66',
|
||||
'GB0TTT' => '66',
|
||||
'GB0WCY' => '61',
|
||||
'GB0WOA' => '62',
|
||||
'GB0WRC' => '66',
|
||||
@ -970,6 +972,7 @@
|
||||
'GB100LP' => '66',
|
||||
'GB100MAS' => '64,351',
|
||||
'GB100MER' => '61',
|
||||
'GB100TT' => '61',
|
||||
'GB125BRC' => '64,351',
|
||||
'GB125SR' => '61',
|
||||
'GB150NRL' => '64,351',
|
||||
@ -1567,6 +1570,7 @@
|
||||
'KH7K' => '108',
|
||||
'KH8' => '109,333',
|
||||
'KH8/S' => '333',
|
||||
'KH8S/K3UY' => '333',
|
||||
'KH8SI' => '333',
|
||||
'KH9' => '110',
|
||||
'KI0' => '467,473,477,484,485,489,490,502',
|
||||
@ -2347,6 +2351,7 @@
|
||||
'OG0' => '126',
|
||||
'OH' => '125,399',
|
||||
'OH0' => '126',
|
||||
'OH0JJS/1' => '125,399',
|
||||
'OH0M' => '127',
|
||||
'OI' => '125',
|
||||
'OI0' => '126',
|
||||
@ -2497,6 +2502,7 @@
|
||||
'R375I' => '176,425,430',
|
||||
'R3F/9' => '176,425,430',
|
||||
'R4' => '420',
|
||||
'R40WK' => '176,425,430',
|
||||
'R6' => '421',
|
||||
'R60A' => '175',
|
||||
'R60F' => '175',
|
||||
@ -3758,6 +3764,7 @@
|
||||
'WH5' => '105',
|
||||
'WH5K' => '106',
|
||||
'WH6' => '387,388',
|
||||
'WH6ASW/M' => '220',
|
||||
'WH7' => '387,388',
|
||||
'WH7K' => '108',
|
||||
'WH8' => '109',
|
||||
|
||||
@ -47,6 +47,7 @@ sub dup
|
||||
chomp $text;
|
||||
unpad($text);
|
||||
$text =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
|
||||
$text = Encode::encode("iso-8859-1", $text) if $main::can_encode && Encode::is_utf8($text, 1);
|
||||
$text = pack("C*", map {$_ & 127} unpack("C*", $text));
|
||||
$text =~ s/[^\#a-zA-Z0-9]//g;
|
||||
$text = substr($text, 0, $duplth) if length $text > $duplth;
|
||||
|
||||
@ -119,6 +119,7 @@ $count = 0;
|
||||
lastmsgpoll => '0,Last Msg Poll,atime',
|
||||
inscript => '9,In a script,yesno',
|
||||
handle_xml => '9,Handles XML,yesno',
|
||||
do_pc9x => '9,Handles PC9x,yesno',
|
||||
inqueue => '9,Input Queue,parray',
|
||||
);
|
||||
|
||||
@ -466,7 +467,7 @@ sub disconnect
|
||||
my $user = $self->{user};
|
||||
|
||||
$user->close() if defined $user;
|
||||
$self->{conn}->disconnect;
|
||||
$self->{conn}->disconnect if $self->{conn};
|
||||
$self->del();
|
||||
}
|
||||
|
||||
|
||||
@ -69,7 +69,10 @@ sub new
|
||||
|
||||
# ALWAYS output the user
|
||||
my $ref = Route::User::get($call);
|
||||
$main::me->route_pc16($main::mycall, undef, $main::routeroot, $ref) if $ref;
|
||||
if ($ref) {
|
||||
$main::me->route_pc16($main::mycall, undef, $main::routeroot, $ref);
|
||||
$main::me->route_pc92a($main::mycall, undef, $main::routeroot, $ref);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
@ -378,11 +381,11 @@ sub send_talks
|
||||
|
||||
my ($to, $via) = $ent =~ /(\S+)>(\S+)/;
|
||||
$to = $ent unless $to;
|
||||
my $call = $via ? $via : $to;
|
||||
my $call = $via && $via ne '*' ? $via : $to;
|
||||
my $clref = Route::get($call);
|
||||
my $dxchan = $clref->dxchan if $clref;
|
||||
if ($dxchan) {
|
||||
$dxchan->talk($self->{call}, $to, $via, $line);
|
||||
$dxchan->talk($self->{call}, $to, undef, $line);
|
||||
} else {
|
||||
$self->send($self->msg('disc2', $via ? $via : $to));
|
||||
my @l = grep { $_ ne $ent } @{$self->{talklist}};
|
||||
@ -571,6 +574,7 @@ sub disconnect
|
||||
|
||||
# issue a pc17 to everybody interested
|
||||
$main::me->route_pc17($main::mycall, undef, $main::routeroot, $uref);
|
||||
$main::me->route_pc92d($main::mycall, undef, $main::routeroot, $uref);
|
||||
} else {
|
||||
confess "trying to disconnect a non existant user $call";
|
||||
}
|
||||
@ -823,7 +827,7 @@ sub local_send
|
||||
# send a talk message here
|
||||
sub talk
|
||||
{
|
||||
my ($self, $from, $to, $via, $line) = @_;
|
||||
my ($self, $from, $to, $via, $line, $onode) = @_;
|
||||
$line =~ s/\\5E/\^/g;
|
||||
if ($self->{talk}) {
|
||||
if ($self->{gtk}) {
|
||||
@ -832,7 +836,7 @@ sub talk
|
||||
$self->local_send('T', "$to de $from: $line");
|
||||
}
|
||||
}
|
||||
Log('talk', $to, $from, $via?$via:$main::mycall, $line);
|
||||
Log('talk', $to, $from, '<' . ($onode || '*'), $line);
|
||||
# send a 'not here' message if required
|
||||
unless ($self->{here} && $from ne $to) {
|
||||
my $key = "$to$from";
|
||||
@ -1167,5 +1171,12 @@ sub import_cmd
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub print_find_reply
|
||||
{
|
||||
my ($self, $node, $target, $flag, $ms) = @_;
|
||||
my $sort = $flag == 2 ? "External" : "Local";
|
||||
$self->send("$sort $target found at $node in $ms ms" );
|
||||
}
|
||||
1;
|
||||
__END__
|
||||
|
||||
@ -200,7 +200,7 @@ sub Log
|
||||
|
||||
sub LogDbg
|
||||
{
|
||||
DXDebug::dbg($_[$#_]);
|
||||
DXDebug::dbg($_) for @_;
|
||||
Log(@_);
|
||||
}
|
||||
|
||||
|
||||
2621
perl/DXProt.pm
2621
perl/DXProt.pm
File diff suppressed because one or more lines are too long
1
perl/DXProtHandle.pm
Normal file
1
perl/DXProtHandle.pm
Normal file
File diff suppressed because one or more lines are too long
@ -1,50 +1 @@
|
||||
#
|
||||
#
|
||||
# These are various values used by the AK1A protocol stack
|
||||
#
|
||||
# Change these at your peril (or if you know what you are doing)!
|
||||
#
|
||||
# Copyright (c) 1998 - Dirk Koopman G1TLH
|
||||
#
|
||||
# $Id$
|
||||
#
|
||||
|
||||
package DXProt;
|
||||
|
||||
# the interval between pc50s (in seconds)
|
||||
$pc50_interval = 14*60;
|
||||
|
||||
# the version of DX cluster (tm) software I am masquerading as
|
||||
$myprot_version = 5300;
|
||||
|
||||
# default hopcount to use
|
||||
$def_hopcount = 30;
|
||||
|
||||
# some variable hop counts based on message type
|
||||
%hopcount = (
|
||||
11 => 25,
|
||||
16 => 25,
|
||||
17 => 25,
|
||||
19 => 25,
|
||||
21 => 25,
|
||||
);
|
||||
|
||||
# list of nodes we don't accept dx from
|
||||
@nodx_node = (
|
||||
|
||||
);
|
||||
|
||||
# list of nodes we don't accept announces from
|
||||
@noann_node = (
|
||||
|
||||
);
|
||||
|
||||
# list of node we don't accept wwvs from
|
||||
@nowwv_node = (
|
||||
|
||||
);
|
||||
|
||||
# send out for/opernams for callsigns sending dx spots who haven't got qra locators
|
||||
$send_opernam = 0;
|
||||
|
||||
1;
|
||||
### These are various values used by the AK1A protocol stack## Change these at your peril (or if you know what you are doing)!## Copyright (c) 1998 - Dirk Koopman G1TLH## $Id$#package DXProt;# the interval between pc50s (in seconds)$pc50_interval = 14*60;# the version of DX cluster (tm) software I am masquerading as$myprot_version = 5300;# default hopcount to use$def_hopcount = 30;# some variable hop counts based on message type%hopcount = ( 11 => 25, 16 => 25, 17 => 25, 19 => 25, 21 => 25,);# list of nodes we don't accept dx from@nodx_node = ();# list of nodes we don't accept announces from@noann_node = ();# list of node we don't accept wwvs from@nowwv_node = ();# send out for/opernams for callsigns sending dx spots who haven't got qra locators$send_opernam = 0;1;
|
||||
File diff suppressed because one or more lines are too long
@ -434,3 +434,4 @@ sub deleteitem
|
||||
@$list = grep {$_ ne $item } @$list;
|
||||
return $n - @$list;
|
||||
}
|
||||
|
||||
|
||||
@ -17,7 +17,7 @@ use Investigate;
|
||||
use DXXml::Text;
|
||||
use DXLog;
|
||||
|
||||
use vars qw(@ISA %pings);
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(DXXml);
|
||||
|
||||
sub handle_input
|
||||
|
||||
@ -16,7 +16,7 @@ use IsoTime;
|
||||
use Investigate;
|
||||
use Time::HiRes qw(gettimeofday tv_interval);
|
||||
|
||||
use vars qw(@ISA %pings);
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(DXXml);
|
||||
|
||||
#
|
||||
|
||||
@ -14,7 +14,7 @@ use DXDebug;
|
||||
use DXProt;
|
||||
use DXLog;
|
||||
|
||||
use vars qw(@ISA %pings);
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(DXXml);
|
||||
|
||||
sub handle_input
|
||||
|
||||
186
perl/EphMsg.pm
Normal file
186
perl/EphMsg.pm
Normal file
@ -0,0 +1,186 @@
|
||||
#
|
||||
# This class is the internal subclass that deals with 'Ephmeral'
|
||||
# communications like: querying http servers and other network
|
||||
# connected data services and using Msg.pm
|
||||
#
|
||||
# An instance of this is setup by a command together with a load
|
||||
# of callbacks and then runs with a state machine until completion
|
||||
#
|
||||
# $Id$
|
||||
#
|
||||
# Copyright (c) 2001 - Dirk Koopman G1TLH
|
||||
#
|
||||
|
||||
package EphMsg;
|
||||
|
||||
use strict;
|
||||
use Msg;
|
||||
use DXVars;
|
||||
use DXUtil;
|
||||
use DXDebug;
|
||||
use IO::File;
|
||||
use IO::Socket;
|
||||
use IPC::Open3;
|
||||
|
||||
use vars qw(@ISA $deftimeout);
|
||||
|
||||
@ISA = qw(Msg);
|
||||
$deftimeout = 60;
|
||||
|
||||
|
||||
sub new
|
||||
{
|
||||
|
||||
}
|
||||
|
||||
# we probably won't use the normal format
|
||||
sub enqueue
|
||||
{
|
||||
my ($conn, $msg) = @_;
|
||||
push (@{$conn->{outqueue}}, $msg . $conn->{lineend});
|
||||
}
|
||||
|
||||
sub dequeue
|
||||
{
|
||||
my $conn = shift;
|
||||
my $msg;
|
||||
|
||||
if ($conn->{csort} eq 'ax25' && exists $conn->{msg}) {
|
||||
$conn->{msg} =~ s/\cM/\cJ/g;
|
||||
}
|
||||
|
||||
if ($conn->{state} eq 'WC') {
|
||||
$conn->to_connected($conn->{call}, 'O', $conn->{csort});
|
||||
}
|
||||
|
||||
if ($conn->{msg} =~ /\cJ/) {
|
||||
my @lines = $conn->{msg} =~ /([^\cM\cJ]*)\cM?\cJ/g;
|
||||
if ($conn->{msg} =~ /\cJ$/) {
|
||||
delete $conn->{msg};
|
||||
} else {
|
||||
$conn->{msg} =~ s/([^\cM\cJ]*)\cM?\cJ//g;
|
||||
}
|
||||
|
||||
while (defined ($msg = shift @lines)) {
|
||||
dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
|
||||
|
||||
$msg =~ s/\xff\xfa.*\xff\xf0|\xff[\xf0-\xfe].//g; # remove telnet options
|
||||
|
||||
&{$conn->{rproc}}($conn, $msg);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub to_connected
|
||||
{
|
||||
my ($conn, $call, $dir, $sort) = @_;
|
||||
$conn->{state} = 'C';
|
||||
$conn->conns($call);
|
||||
delete $conn->{cmd};
|
||||
$conn->{timeout}->del if $conn->{timeout};
|
||||
delete $conn->{timeout};
|
||||
$conn->nolinger;
|
||||
&{$conn->{rproc}}($conn, "$dir$call|$sort");
|
||||
}
|
||||
|
||||
|
||||
sub start_connect
|
||||
{
|
||||
my $call = shift;
|
||||
my $fn = shift;
|
||||
my $conn = ExtMsg->new(\&main::new_channel);
|
||||
$conn->{outgoing} = 1;
|
||||
$conn->conns($call);
|
||||
|
||||
my $f = new IO::File $fn;
|
||||
push @{$conn->{cmd}}, <$f>;
|
||||
$f->close;
|
||||
$conn->{state} = 'WC';
|
||||
$conn->_dotimeout($deftimeout);
|
||||
}
|
||||
|
||||
sub _doconnect
|
||||
{
|
||||
my ($conn, $sort, $line) = @_;
|
||||
my $r;
|
||||
|
||||
$sort = lc $sort; # in this case telnet, ax25 or prog
|
||||
dbg("CONNECT $conn->{cnum} sort: $sort command: $line") if isdbg('connect');
|
||||
if ($sort eq 'telnet') {
|
||||
# this is a straight network connect
|
||||
my ($host, $port) = split /\s+/, $line;
|
||||
$port = 23 if !$port;
|
||||
$r = $conn->connect($host, $port);
|
||||
if ($r) {
|
||||
dbg("Connected $conn->{cnum} to $host $port") if isdbg('connect');
|
||||
} else {
|
||||
dbg("***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('connect');
|
||||
}
|
||||
} elsif ($sort eq 'prog') {
|
||||
$r = $conn->start_program($line, $sort);
|
||||
} else {
|
||||
dbg("invalid type of connection ($sort)");
|
||||
}
|
||||
$conn->disconnect unless $r;
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub _doabort
|
||||
{
|
||||
my $conn = shift;
|
||||
my $string = shift;
|
||||
dbg("connect $conn->{cnum}: abort $string") if isdbg('connect');
|
||||
$conn->{abort} = $string;
|
||||
}
|
||||
|
||||
sub _dotimeout
|
||||
{
|
||||
my $conn = shift;
|
||||
my $val = shift;
|
||||
dbg("connect $conn->{cnum}: timeout set to $val") if isdbg('connect');
|
||||
$conn->{timeout}->del if $conn->{timeout};
|
||||
$conn->{timeval} = $val;
|
||||
$conn->{timeout} = Timer->new($val, sub{ &_timedout($conn) });
|
||||
}
|
||||
|
||||
|
||||
sub _timedout
|
||||
{
|
||||
my $conn = shift;
|
||||
dbg("connect $conn->{cnum}: timed out after $conn->{timeval} seconds") if isdbg('connect');
|
||||
$conn->disconnect;
|
||||
}
|
||||
|
||||
# handle callsign and connection type firtling
|
||||
sub _doclient
|
||||
{
|
||||
my $conn = shift;
|
||||
my $line = shift;
|
||||
my @f = split /\s+/, $line;
|
||||
my $call = uc $f[0] if $f[0];
|
||||
$conn->conns($call);
|
||||
$conn->{csort} = $f[1] if $f[1];
|
||||
$conn->{state} = 'C';
|
||||
&{$conn->{rproc}}($conn, "O$call|$conn->{csort}");
|
||||
delete $conn->{cmd};
|
||||
$conn->{timeout}->del if $conn->{timeout};
|
||||
}
|
||||
|
||||
sub _send_file
|
||||
{
|
||||
my $conn = shift;
|
||||
my $fn = shift;
|
||||
|
||||
if (-e $fn) {
|
||||
my $f = new IO::File $fn;
|
||||
if ($f) {
|
||||
while (<$f>) {
|
||||
chomp;
|
||||
my $l = $_;
|
||||
dbg("connect $conn->{cnum}: $l") if isdbg('connll');
|
||||
$conn->send_raw($l . $conn->{lineend});
|
||||
}
|
||||
$f->close;
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -12,6 +12,8 @@ package Msg;
|
||||
|
||||
use strict;
|
||||
|
||||
use DXUtil;
|
||||
|
||||
use IO::Select;
|
||||
use IO::Socket;
|
||||
use DXDebug;
|
||||
|
||||
387
perl/Route.pm
387
perl/Route.pm
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@ -10,6 +10,7 @@ package Route::User;
|
||||
|
||||
use DXDebug;
|
||||
use Route;
|
||||
use DXUtil;
|
||||
|
||||
use strict;
|
||||
|
||||
@ -47,7 +48,7 @@ sub new
|
||||
|
||||
my $self = $pkg->SUPER::new($call);
|
||||
$self->{parent} = [ $ncall ];
|
||||
$self->{flags} = $flags;
|
||||
$self->{flags} = $flags || Route::here(1);
|
||||
$list{$call} = $self;
|
||||
|
||||
return $self;
|
||||
|
||||
@ -20,12 +20,14 @@ package RouteDB;
|
||||
|
||||
use DXDebug;
|
||||
use DXChannel;
|
||||
use DXUtil;
|
||||
use Prefix;
|
||||
|
||||
use strict;
|
||||
|
||||
use vars qw(%list %valid $default);
|
||||
|
||||
|
||||
%list = ();
|
||||
$default = 99; # the number of hops to use if we don't know
|
||||
%valid = (
|
||||
@ -84,7 +86,7 @@ sub update
|
||||
my $interface = shift;
|
||||
my $hops = shift || $default;
|
||||
my $ref = $list{$call} || RouteDB->new($call);
|
||||
my $iref = $ref->{item}->{$interface} ||= RouteDB::Item->new($interface);
|
||||
my $iref = $ref->{item}->{$interface} ||= RouteDB::Item->new($interface, $hops);
|
||||
$iref->{count}++;
|
||||
$iref->{hops} = $hops if $hops < $iref->{hops};
|
||||
$iref->{t} = shift || $main::systime;
|
||||
@ -136,7 +138,8 @@ sub new
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $call = shift;
|
||||
return bless {call => $call, hops => $RouteDB::default}, (ref $pkg || $pkg);
|
||||
my $hops = shift || $RouteDB::default;
|
||||
return bless {call => $call, hops => $hops}, (ref $pkg || $pkg);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -21,7 +21,7 @@ use QSL;
|
||||
|
||||
use strict;
|
||||
|
||||
use vars qw($fp $statp $maxspots $defaultspots $maxdays $dirprefix $duplth $dupage $filterdef $totalspots $hfspots $vhfspots $maxcalllth);
|
||||
use vars qw($fp $statp $maxspots $defaultspots $maxdays $dirprefix $duplth $dupage $filterdef $totalspots $hfspots $vhfspots $maxcalllth $can_encode);
|
||||
|
||||
$fp = undef;
|
||||
$statp = undef;
|
||||
@ -402,6 +402,7 @@ sub dup
|
||||
}
|
||||
}
|
||||
my $otext = $text;
|
||||
$text = Encode::encode("iso-8859-1", $text) if $main::can_encode && Encode::is_utf8($text, 1);
|
||||
$text =~ s/^\+\w+\s*//; # remove leading LoTW callsign
|
||||
$text = pack("C*", map {$_ & 127} unpack("C*", $text));
|
||||
$text =~ s/\s{2,}[\dA-Z]?[A-Z]\d?$// if length $text > 24;
|
||||
|
||||
@ -10,6 +10,6 @@ package main;
|
||||
use vars qw($version $build);
|
||||
|
||||
$version = '1.53';
|
||||
$build = '16';
|
||||
$build = '17';
|
||||
|
||||
1;
|
||||
|
||||
526
perl/cluster.pl
526
perl/cluster.pl
File diff suppressed because one or more lines are too long
Loading…
Reference in New Issue
Block a user