+14Jun01=======================================================================
+1. changed debug api to (potentially) use less cpu time
13Jun01=======================================================================
1. fix init cnd rinit cmds
2. add missing clear/route cmd
if (-e $fn) {
my $m = $self->msg('e16', $fn);
Log('msg', $self->call . " tried to export $m");
- dbg('msg', $m);
+ dbg($m) if isdbg('msg');
return (1, $m);
}
Log('call', "$call: show/qrz \U$l");
my $state = "blank";
while (my $result = $t->getline) {
- dbg('qrz', $result);
+ dbg($result) if isdbg('qrz');
if ($state eq 'blank' && $result =~ /^\s*Callsign\s*:/i) {
$state = 'go';
} elsif ($state eq 'go') {
$rproc = shift;
finish();
- dbg('err', "AGW initialising and connecting to $addr/$port ...");
+ dbg("AGW initialising and connecting to $addr/$port ...");
$sock = IO::Socket::INET->new(PeerAddr => $addr, PeerPort => $port, Proto=>'tcp', Timeout=>15);
unless ($sock) {
- dbg('err', "Cannot connect to AGW Engine at $addr/$port $!");
+ dbg("Cannot connect to AGW Engine at $addr/$port $!");
return;
}
Msg::blocking($sock, 0);
return if $finishing;
if ($sock) {
$finishing = 1;
- dbg('err', "AGW ending...");
+ dbg("AGW ending...");
for (values %circuit) {
&{$_->{eproc}}() if $_->{eproc};
$_->disconnect;
$len = length $data;
if ($sort eq 'y' || $sort eq 'H') {
- dbg('agwpoll', "AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$data\"");
+ dbg("AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$data\"") if isdbg('agwpoll');
} elsif ($sort eq 'D') {
if (isdbg('agw')) {
my $d = $data;
$d =~ s/\cM$//;
- dbg('agw', "AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$d\"");
+ dbg("AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$d\"") if isdbg('agw');
}
} else {
- dbg('agw', "AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$data\"");
+ dbg("AGW sendf: $sort '${from}'->'${to}' port: $port pid: $pid \"$data\"") if isdbg('agw');
}
push @outqueue, pack('C x3 a1 x1 C x1 a10 a10 V x4 a*', $port, $sort, $pid, $from, $to, $len, $data);
Msg::set_event_handler($sock, write=>\&_send);
sub _error
{
- dbg('err', "error on AGW connection $addr/$port $!");
+ dbg("error on AGW connection $addr/$port $!");
Msg::set_event_handler($sock, read=>undef, write=>undef, error=>undef);
$sock = undef;
for (%circuit) {
# do a sanity check on the length
if ($len > 2000) {
- dbg('err', "AGW: invalid length $len > 2000 received ($sort $port $pid '$from'->'$to')");
+ dbg("AGW: invalid length $len > 2000 received ($sort $port $pid '$from'->'$to')");
finish();
return;
}
if ($sort eq 'D') {
my $d = unpack "Z*", $data;
$d =~ s/\cM$//;
- dbg('agw', "AGW Data In port: $port pid: $pid '$from'->'$to' length: $len \"$d\"");
+ dbg("AGW Data In port: $port pid: $pid '$from'->'$to' length: $len \"$d\"") if isdbg('agw');
my $conn = _find($from eq $main::mycall ? $to : $from);
if ($conn) {
if ($conn->{state} eq 'WC') {
if (exists $conn->{cmd}) {
if (@{$conn->{cmd}}) {
- dbg('connect', $d);
+ dbg($d) if isdbg('connect');
$conn->_docmd($d);
}
}
}
}
} else {
- dbg('err', "AGW error Unsolicited Data!");
+ dbg("AGW error Unsolicited Data!");
}
} elsif ($sort eq 'I' || $sort eq 'S' || $sort eq 'U' || $sort eq 'M' || $sort eq 'T') {
my $d = unpack "Z*", $data;
for (@lines) {
s/([\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
- dbg('agw', "AGW Monitor port: $port \"$_\"");
+ dbg("AGW Monitor port: $port \"$_\"") if isdbg('agw');
}
} elsif ($sort eq 'C') {
my $d = unpack "Z*", $data;
$d =~ s/\cM$//;
- dbg('agw', "AGW Connect port: $port pid: $pid '$from'->'$to' \"$d\"");
+ dbg("AGW Connect port: $port pid: $pid '$from'->'$to' \"$d\"") if isdbg('agw');
my $call = $from eq $main::mycall ? $to : $from;
my $conn = _find($call);
if ($conn) {
} elsif ($sort eq 'd') {
my $d = unpack "Z*", $data;
$d =~ s/\cM$//;
- dbg('agw', "AGW '$from'->'$to' port: $port Disconnected ($d)");
+ dbg("AGW '$from'->'$to' port: $port Disconnected ($d)") if isdbg('agw');
my $conn = _find($from eq $main::mycall ? $to : $from);
if ($conn) {
&{$conn->{eproc}}() if $conn->{eproc};
}
} elsif ($sort eq 'y') {
my ($frames) = unpack "V", $data;
- dbg('agwpollans', "AGW Frames Outstanding on port $port = $frames");
+ dbg("AGW Frames Outstanding on port $port = $frames") if isdbg('agwpollans');
my $conn = _find($from);
$conn->{oframes} = $frames if $conn;
} elsif ($sort eq 'Y') {
my ($frames) = unpack "V", $data;
- dbg('agw', "AGW Frames Outstanding on circuit '$from'->'$to' = $frames");
+ dbg("AGW Frames Outstanding on circuit '$from'->'$to' = $frames") if isdbg('agw');
my $conn = _find($from eq $main::mycall ? $to : $from);
$conn->{oframes} = $frames if $conn;
} elsif ($sort eq 'H') {
unless ($from =~ /^\s+$/) {
my $d = unpack "Z*", $data;
$d =~ s/\cM$//;
- dbg('agw', "AGW Heard port: $port \"$d\"");
+ dbg("AGW Heard port: $port \"$d\"") if isdbg('agw');
}
} elsif ($sort eq 'X') {
my ($r) = unpack "C", $data;
$r = $r ? "Successful" : "Failed";
- dbg('err', "AGW Register $from $r");
+ dbg("AGW Register $from $r");
finish() unless $r;
} elsif ($sort eq 'R') {
my ($major, $minor) = unpack "v x2 v x2", $data;
- dbg('agw', "AGW Version $major.$minor");
+ dbg("AGW Version $major.$minor") if isdbg('agw');
} elsif ($sort eq 'G') {
my @ports = split /;/, $data;
$noports = shift @ports || '0';
- dbg('agw', "AGW $noports Ports available");
+ dbg("AGW $noports Ports available") if isdbg('agw');
pop @ports while @ports > $noports;
for (@ports) {
next unless $_;
- dbg('agw', "AGW Port: $_");
+ dbg("AGW Port: $_") if isdbg('agw');
}
for (my $i = 0; $i < $noports; $i++) {
_sendf('y', undef, undef, $i);
}
} else {
my $d = unpack "Z*", $data;
- dbg('agw', "AGW decode $sort port: $port pid: $pid '$from'->'$to' length: $len \"$d\"");
+ dbg("AGW decode $sort port: $port pid: $pid '$from'->'$to' length: $len \"$d\"") if isdbg('agw');
}
}
}
# _sendf('Y', $main::mycall, $conn->{call}, $conn->{agwport}, $conn->{agwpid});
_sendf('D', $main::mycall, $conn->{agwcall}, $conn->{agwport}, $conn->{agwpid}, $msg . $conn->{lineend});
my $len = length($msg) + 1;
- dbg('agw', "AGW Data Out port: $conn->{agwport} pid: $conn->{agwpid} '$main::mycall'->'$conn->{agwcall}' length: $len \"$msg\"");
+ dbg("AGW Data Out port: $conn->{agwport} pid: $conn->{agwpid} '$main::mycall'->'$conn->{agwcall}' length: $len \"$msg\"") if isdbg('agw');
}
}
delete $self->{$_};
}
}
- dbg('chan', "DXChannel $self->{call} destroyed ($count)");
+ dbg("DXChannel $self->{call} destroyed ($count)") if isdbg('chan');
$count--;
}
}
$count++;
- dbg('chan', "DXChannel $self->{call} created ($count)");
+ dbg("DXChannel $self->{call} created ($count)") if isdbg('chan');
bless $self, $pkg;
return $channels{$call} = $self;
}
my @lines = split /\n/;
for (@lines) {
$conn->send_now("$sort$call|$_");
- dbg('chan', "-> $sort $call $_");
+ dbg("-> $sort $call $_") if isdbg('chan');
}
}
$self->{t} = time;
my @lines = split /\n/;
for (@lines) {
$conn->send_later("D$call|$_");
- dbg('chan', "-> D $call $_");
+ dbg("-> D $call $_") if isdbg('chan');
}
}
$self->{t} = time;
$self->{oldstate} = $self->{state};
$self->{state} = shift;
$self->{func} = '' unless defined $self->{func};
- dbg('state', "$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n");
+ dbg("$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n") if isdbg('state');
# if there is any queued up broadcasts then splurge them out here
if ($self->{delayed} && ($self->{state} eq 'prompt' || $self->{state} eq 'talk')) {
# the above regexp must work
unless (defined $sort && defined $call && defined $line) {
# $data =~ s/([\x00-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
- dbg('err', "DUFF Line on $chcall: $data");
+ dbg("DUFF Line on $chcall: $data") if isdbg('err');
return ();
}
if(ref($dxchan) && $call ne $chcall) {
- dbg('err', "DUFF Line come in for $call on wrong channel $chcall" );
+ dbg("DUFF Line come in for $call on wrong channel $chcall") if isdbg('err');
return();
}
unless ($noderef) {
my $mynode = $self->{mynode};
my $call = $self->{call};
- dbg('err', "parent node $mynode has disappeared from $call" );
+ dbg("parent node $mynode has disappeared from $call") if isdbg('err');
}
}
return $noderef;
unless ($dxchan) {
my $dxcall = $self->{dxchancall};
my $call = $self->{call};
- dbg('err', "parent dxchan $dxcall has disappeared from $call" );
+ dbg("parent dxchan $dxcall has disappeared from $call") if isdbg('err');
}
}
return $dxchan;
my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
$self->{mynode} = $node->call;
$node->add_user($call, $self);
- dbg('cluster', "allocating user $call to $node->{call} in cluster\n");
+ dbg("allocating user $call to $node->{call} in cluster\n") if isdbg('cluster');
return $self;
}
my $node = $self->mynode;
$node->del_user($call);
- dbg('cluster', "deleting user $call from $node->{call} in cluster\n");
+ dbg("deleting user $call from $node->{call} in cluster\n") if isdbg('cluster');
}
sub count
$self->{mynode} = $self->call; # for sh/station
$self->{users} = 0;
$nodes++;
- dbg('cluster', "allocating node $call to cluster\n");
+ dbg("allocating node $call to cluster\n") if isdbg('cluster');
return $self;
}
$ref->del(); # this also takes them out of this list
}
delete $DXCluster::cluster{$call}; # remove me from the cluster table
- dbg('cluster', "deleting node $call from cluster\n");
+ dbg("deleting node $call from cluster\n") if isdbg('cluster');
$users -= $self->{users}; # it may be PC50 updated only therefore > 0
$users = 0 if $users < 0;
$nodes--;
if ($self->{func}) {
my $c = qq{ \@ans = $self->{func}(\$self, \$cmdline) };
- dbg('eval', "stored func cmd = $c\n");
+ dbg("stored func cmd = $c\n") if isdbg('eval');
eval $c;
if ($@) {
return ("Syserr: Eval err $errstr on stored func $self->{func}", $@);
my ($path, $fcmd);
- dbg('command', "cmd: $cmd");
+ dbg("cmd: $cmd") if isdbg('command');
# alias it if possible
my $acmd = CmdAlias::get_cmd($cmd);
if ($acmd) {
($cmd, $args) = split /\s+/, "$acmd $args", 2;
$args = "" unless defined $args;
- dbg('command', "aliased cmd: $cmd $args");
+ dbg("aliased cmd: $cmd $args") if isdbg('command');
}
# first expand out the entry to a command
($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
if ($path && $cmd) {
- dbg('command', "path: $cmd cmd: $fcmd");
+ dbg("path: $cmd cmd: $fcmd") if isdbg('command');
my $package = find_cmd_name($path, $fcmd);
@ans = (0) if !$package ;
if ($package) {
- dbg('command', "package: $package");
+ dbg("package: $package") if isdbg('command');
my $c;
unless (exists $Cache{$package}->{'sub'}) {
$c = eval $Cache{$package}->{'eval'};
};
}
} else {
- dbg('command', "cmd: $cmd not found");
+ dbg("cmd: $cmd not found") if isdbg('command');
if (++$self->{errors} > $maxerrors) {
$self->send($self->msg('e26'));
$self->disconnect;
}
my @rout = $main::routeroot->del_user($call);
- dbg('route', "B/C PC17 on $main::mycall for: $call");
+ dbg("B/C PC17 on $main::mycall for: $call") if isdbg('route');
# issue a pc17 to everybody interested
DXProt::route_pc17($DXProt::me, $main::routeroot, @rout) if @rout;
# commands are lower case
$short_cmd = lc $short_cmd;
- dbg('command', "command: $path $short_cmd\n");
+ dbg("command: $path $short_cmd\n") if isdbg('command');
# do some checking for funny characters
return () if $short_cmd =~ /\/$/;
# return immediately if we have it
($apath, $acmd) = split ',', $cmd_cache{$short_cmd} if $cmd_cache{$short_cmd};
if ($apath && $acmd) {
- dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
+ dbg("cached $short_cmd = ($apath, $acmd)\n") if isdbg('command');
return ($apath, $acmd);
}
next if $l =~ /^\./;
if ($i < $#parts) { # we are dealing with directories
if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
- dbg('command', "got dir: $curdir/$l\n");
+ dbg("got dir: $curdir/$l\n") if isdbg('command');
$dirfn .= "$l/";
$curdir .= "/$l";
last;
# chop $dirfn; # remove trailing /
$dirfn = "" unless $dirfn;
$cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn$l")); # cache it
- dbg('command', "got path: $path cmd: $dirfn$l\n");
+ dbg("got path: $path cmd: $dirfn$l\n") if isdbg('command');
return ($path, "$dirfn$l");
}
}
my @list = split /\n/, $eval;
my $line;
for (@list) {
- dbg('eval', $_, "\n");
+ dbg($_ . "\n") if isdbg('eval');
}
}
my $fh = new IO::File;
my $line = 0;
- dbg('cron', "cron: reading $fn\n");
+ dbg("cron: reading $fn\n") if isdbg('cron');
open($fh, $fn) or confess("cron: can't open $fn $!");
while (<$fh>) {
$line++;
if (!$err) {
$ref->{cmd} = $cmd;
push @crontab, $ref;
- dbg('cron', "cron: adding $_\n");
+ dbg("cron: adding $_\n") if isdbg('cron');
} else {
- dbg('cron', "cron: error on line $line '$_'\n");
+ dbg("cron: error on line $line '$_'\n") if isdbg('cron');
}
}
close($fh);
(!$cron->{wday} || grep $_ eq $wday, @{$cron->{wday}}) ){
if ($cron->{cmd}) {
- dbg('cron', "cron: $min $hour $mday $mon $wday -> doing '$cron->{cmd}'");
+ dbg("cron: $min $hour $mday $mon $wday -> doing '$cron->{cmd}'") if isdbg('cron');
eval "$cron->{cmd}";
- dbg('cron', "cron: cmd error $@") if $@;
+ dbg("cron: cmd error $@") if $@ && isdbg('cron');
}
}
}
$SIG{CHLD} = $SIG{TERM} = $SIG{INT} = $SIG{__WARN__} = 'DEFAULT';
alarm(0);
}
- exec "$line" or dbg('cron', "exec '$line' failed $!");
+ exec "$line" or dbg("exec '$line' failed $!") if isdbg('cron');
}
- dbg('cron', "spawn of $line started");
+ dbg("spawn of $line started") if isdbg('cron');
} else {
- dbg('cron', "can't fork for $line $!");
+ dbg("can't fork for $line $!") if isdbg('cron');
}
# coordinate
{
my $line = shift;
my @in = DXCommandmode::run_cmd($DXProt::me, $line);
- dbg('cron', "cmd run: $line");
+ dbg("cmd run: $line") if isdbg('cron');
for (@in) {
s/\s*$//og;
- dbg('cron', "cmd out: $_");
+ dbg("cmd out: $_") if isdbg('cron');
}
}
1;
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(dbginit dbgstore dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
+@EXPORT = qw(dbginit dbg dbgadd dbgsub dbglist dbgdump isdbg dbgclose confess croak cluck);
use strict;
use vars qw(%dbglevel $fp);
local $^W=0;
eval qq( sub confess {
\$SIG{__DIE__} = 'DEFAULT';
- DXDebug::dbgstore(\$@, Carp::shortmess(\@_));
+ DXDebug::dbg(\$@);
+ DXDebug::dbg(Carp::shortmess(\@_));
exit(-1);
}
sub croak {
\$SIG{__DIE__} = 'DEFAULT';
- DXDebug::dbgstore(\$@, Carp::longmess(\@_));
+ DXDebug::dbg(\$@);
+ DXDebug::dbg(Carp::longmess(\@_));
exit(-1);
}
- sub carp { DXDebug::dbgstore(Carp::shortmess(\@_)); }
- sub cluck { DXDebug::dbgstore(Carp::longmess(\@_)); }
+ sub carp { DXDebug::dbg(Carp::shortmess(\@_)); }
+ sub cluck { DXDebug::dbg(Carp::longmess(\@_)); }
);
CORE::die(Carp::shortmess($@)) if $@;
}
-sub dbgstore
+sub dbg($)
{
+ return unless $fp;
my $t = time;
for (@_) {
my $r = $_;
if (!defined $DB::VERSION) {
$SIG{__WARN__} = sub {
if ($_[0] =~ /Deep\s+recursion/i) {
- dbgstore($@, Carp::longmess(@_));
+ dbg($@);
+ dbg(Carp::longmess(@_));
CORE::die;
} else {
- dbgstore($@, Carp::shortmess(@_));
+ dbg($@);
+ dbg(Carp::shortmess(@_));
}
};
- $SIG{__DIE__} = sub { dbgstore($@, Carp::longmess(@_)); };
+ $SIG{__DIE__} = sub { dbg($@); dbg(Carp::longmess(@_)); };
}
$fp = DXLog::new('debug', 'dat', 'd');
undef $fp;
}
-sub dbg
-{
- my $l = shift;
- if ($fp && ($dbglevel{$l} || $l eq 'err')) {
- dbgstore(@_);
- }
-}
-
sub dbgdump
{
my $l = shift;
$c =~ s/[\x00-\x1f\x7f-\xff]/./g;
my $left = 16 - length $c;
$h .= ' ' x (2 * $left) if $left > 0;
- dbgstore($m . sprintf("%4d:", $o) . "$h $c");
+ dbg($m . sprintf("%4d:", $o) . "$h $c");
$m = ' ' x (length $m);
}
}
return keys (%dbglevel);
}
-sub isdbg
+sub isdbg($)
{
- my $s = shift;
- return $dbglevel{$s};
+ return unless $fp;
+ return $dbglevel{$_[0]};
}
sub shortmess
my ($pkg, $name) = @_;
my $s = readfilestr($main::data, $name);
my $self = eval $s if $s;
- dbg('err', "error in reading $name in DXHash $@") if $@;
+ dbg("error in reading $name in DXHash $@") if $@;
$self = bless {name => $name}, $pkg unless $self;
return $self;
}
$self->{year} = $year;
$self->{thing} = $thing;
-# DXDebug::dbg("dxlog", "opening $self->{fn}\n");
+# DXDebug::dbg("opening $self->{fn}\n") if isdbg("dxlog");
return $self->{fh};
}
if (exists $busy{$f[2]}) {
my $ref = $busy{$f[2]};
my $tonode = $ref->{tonode};
- dbg('msg', "Busy, stopping msgno: $ref->{msgno} -> $f[2]");
+ dbg("Busy, stopping msgno: $ref->{msgno} -> $f[2]") if isdbg('msg');
$ref->stop_msg($self->call);
}
$ref->{linesreq} = $f[10];
$ref->{stream} = $stream;
$ref->{count} = 0; # no of lines between PC31s
- dbg('msg', "new message from $f[4] to $f[3] '$f[8]' stream $stream\n");
+ dbg("new message from $f[4] to $f[3] '$f[8]' stream $stream\n") if isdbg('msg');
Log('msg', "Incoming message $f[4] to $f[3] '$f[8]'" );
$work{"$f[2]$stream"} = $ref; # store in work
$busy{$f[2]} = $ref; # set interlock
my $uref = DXUser->get_current($ref->{to});
if (is_callsign($ref->{to}) && !$ref->{private} && $uref && $uref->homenode) {
$ref->{private} = 1;
- dbg('msg', "set bull to $ref->{to} to private");
+ dbg("set bull to $ref->{to} to private") if isdbg('msg');
}
last SWITCH;
}
$ref->{count}++;
if ($ref->{count} >= $ref->{linesreq}) {
$self->send(DXProt::pc31($f[2], $f[1], $f[3]));
- dbg('msg', "stream $f[3]: $ref->{count} lines received\n");
+ dbg("stream $f[3]: $ref->{count} lines received\n") if isdbg('msg');
$ref->{count} = 0;
}
$ref->{lastt} = $main::systime;
} else {
- dbg('msg', "PC29 from unknown stream $f[3] from $f[2]" );
+ dbg("PC29 from unknown stream $f[3] from $f[2]") if isdbg('msg');
$self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream
}
last SWITCH;
$ref->{count} = 0;
$ref->{linesreq} = 5;
$work{"$f[2]$f[3]"} = $ref; # new ref
- dbg('msg', "incoming subject ack stream $f[3]\n");
+ dbg("incoming subject ack stream $f[3]\n") if isdbg('msg');
$busy{$f[2]} = $ref; # interlock
push @{$ref->{lines}}, ($ref->read_msg_body);
$ref->send_tranche($self);
$ref->{lastt} = $main::systime;
} else {
- dbg('msg', "PC30 from unknown stream $f[3] from $f[2]" );
+ dbg("PC30 from unknown stream $f[3] from $f[2]") if isdbg('msg');
$self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream
}
last SWITCH;
if ($pcno == 31) { # acknowledge a tranche of lines
my $ref = $work{"$f[2]$f[3]"};
if ($ref) {
- dbg('msg', "tranche ack stream $f[3]\n");
+ dbg("tranche ack stream $f[3]\n") if isdbg('msg');
$ref->send_tranche($self);
$ref->{lastt} = $main::systime;
} else {
- dbg('msg', "PC31 from unknown stream $f[3] from $f[2]" );
+ dbg("PC31 from unknown stream $f[3] from $f[2]") if isdbg('msg');
$self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream
}
last SWITCH;
}
if ($pcno == 32) { # incoming EOM
- dbg('msg', "stream $f[3]: EOM received\n");
+ dbg("stream $f[3]: EOM received\n") if isdbg('msg');
my $ref = $work{"$f[2]$f[3]"};
if ($ref) {
$self->send(DXProt::pc33($f[2], $f[1], $f[3])); # acknowledge it
if ($ref->{subject} eq $m->{subject} && $ref->{t} == $m->{t} && $ref->{from} eq $m->{from} && $ref->{to} eq $m->{to}) {
$ref->stop_msg($self->call);
my $msgno = $m->{msgno};
- dbg('msg', "duplicate message from $ref->{from} -> $ref->{to} to $msgno");
+ dbg("duplicate message from $ref->{from} -> $ref->{to} to $msgno") if isdbg('msg');
Log('msg', "duplicate message from $ref->{from} -> $ref->{to} to $msgno");
return;
}
# look for 'bad' to addresses
if ($ref->dump_it) {
$ref->stop_msg($self->call);
- dbg('msg', "'Bad' message $ref->{to}");
+ dbg("'Bad' message $ref->{to}") if isdbg('msg');
Log('msg', "'Bad' message $ref->{to}");
return;
}
}
$ref->stop_msg($self->call);
} else {
- dbg('msg', "PC32 from unknown stream $f[3] from $f[2]" );
+ dbg("PC32 from unknown stream $f[3] from $f[2]") if isdbg('msg');
$self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream
}
# queue_msg(0);
}
$ref->stop_msg($self->call);
} else {
- dbg('msg', "PC33 from unknown stream $f[3] from $f[2]" );
+ dbg("PC33 from unknown stream $f[3] from $f[2]") if isdbg('msg');
$self->send(DXProt::pc42($f[2], $f[1], $f[3])); # unknown stream
}
$f[3] =~ s/\.//og; # remove dots
$f[3] =~ s/^\///o; # remove the leading /
$f[3] = lc $f[3]; # to lower case;
- dbg('msg', "incoming file $f[3]\n");
+ dbg("incoming file $f[3]\n") if isdbg('msg');
$f[3] = 'packclus/' . $f[3] unless $f[3] =~ /^packclus\//o;
# create any directories
$fn .= "/$part";
next if -e $fn;
last SWITCH if !mkdir $fn, 0777;
- dbg('msg', "created directory $fn\n");
+ dbg("created directory $fn\n") if isdbg('msg');
}
my $stream = next_transno($f[2]);
my $ref = DXMsg->alloc($stream, "$main::root/$f[3]", $self->call, time, !$f[4], $f[3], ' ', '0', '0');
}
if ($pcno == 42) { # abort transfer
- dbg('msg', "stream $f[3]: abort received\n");
+ dbg("stream $f[3]: abort received\n") if isdbg('msg');
my $ref = $work{"$f[2]$f[3]"};
if ($ref) {
$ref->stop_msg($self->call);
my $lines = shift;
if ($ref->{file}) { # a file
- dbg('msg', "To be stored in $ref->{to}\n");
+ dbg("To be stored in $ref->{to}\n") if isdbg('msg');
my $fh = new IO::File "$ref->{to}", "w";
if (defined $fh) {
print $fh "$line\n";
}
$fh->close;
- dbg('msg', "file $ref->{to} stored\n");
+ dbg("file $ref->{to} stored\n") if isdbg('msg');
Log('msg', "file $ref->{to} from $ref->{from} stored" );
} else {
confess "can't open file $ref->{to} $!";
# attempt to open the message file
my $fn = filename($ref->{msgno});
- dbg('msg', "To be stored in $fn\n");
+ dbg("To be stored in $fn\n") if isdbg('msg');
# now save the file, overwriting what's there, YES I KNOW OK! (I will change it if it's a problem)
my $fh = new IO::File "$fn", "w";
print $fh "$line\n";
}
$fh->close;
- dbg('msg', "msg $ref->{msgno} stored\n");
+ dbg("msg $ref->{msgno} stored\n") if isdbg('msg');
Log('msg', "msg $ref->{msgno} from $ref->{from} to $ref->{to} stored" );
} else {
confess "can't open msg file $fn $!";
my $self = shift;
# remove it from the active message list
- dbg('msg', "\@msg = " . scalar @msg . " before delete");
+ dbg("\@msg = " . scalar @msg . " before delete") if isdbg('msg');
@msg = grep { $_ != $self } @msg;
# remove the file
unlink filename($self->{msgno});
- dbg('msg', "deleting $self->{msgno}\n");
- dbg('msg', "\@msg = " . scalar @msg . " after delete");
+ dbg("deleting $self->{msgno}\n") if isdbg('msg');
+ dbg("\@msg = " . scalar @msg . " after delete") if isdbg('msg');
}
# clean out old messages from the message queue
my $ref;
# mark old messages for deletion
- dbg('msg', "\@msg = " . scalar @msg . " before delete");
+ dbg("\@msg = " . scalar @msg . " before delete") if isdbg('msg');
foreach $ref (@msg) {
if (ref($ref) && !$ref->{keep} && $ref->{t} < $main::systime - $maxage) {
$ref->{deleteme} = 1;
unlink filename($ref->{msgno});
- dbg('msg', "deleting old $ref->{msgno}\n");
+ dbg("deleting old $ref->{msgno}\n") if isdbg('msg');
}
}
# remove them all from the active message list
@msg = grep { !$_->{deleteme} } @msg;
- dbg('msg', "\@msg = " . scalar @msg . " after delete");
+ dbg("\@msg = " . scalar @msg . " after delete") if isdbg('msg');
$last_clean = $main::systime;
}
$file = new IO::File "$fn";
if (!$file) {
- dbg('err', "Error reading $fn $!");
+ dbg("Error reading $fn $!");
Log('err', "Error reading $fn $!");
return undef;
}
$size = -s $fn;
$line = <$file>; # first line
if ($size == 0 || !$line) {
- dbg('err', "Empty $fn $!");
+ dbg("Empty $fn $!");
Log('err', "Empty $fn $!");
return undef;
}
chomp $line;
$size -= length $line;
if (! $line =~ /^===/o) {
- dbg('err', "corrupt first line in $fn ($line)");
+ dbg("corrupt first line in $fn ($line)");
Log('err', "corrupt first line in $fn ($line)");
return undef;
}
chomp $line;
$size -= length $line;
if (! $line =~ /^===/o) {
- dbg('err', "corrupt second line in $fn ($line)");
+ dbg("corrupt second line in $fn ($line)");
Log('err', "corrupt second line in $fn ($line)");
return undef;
}
$file = new IO::File;
if (!open($file, $fn)) {
- dbg('err' ,"Error reading $fn $!");
+ dbg("Error reading $fn $!");
Log('err' ,"Error reading $fn $!");
return undef;
}
# bat down the message list looking for one that needs to go off site and whose
# nearest node is not busy.
- dbg('msg', "queue msg ($sort)\n");
+ dbg("queue msg ($sort)\n") if isdbg('msg');
my @nodelist = DXChannel::get_all_nodes;
foreach $ref (@msg) {
# any time outs?
if (exists $ref->{lastt} && $main::systime >= $ref->{lastt} + $timeout) {
my $node = $ref->{tonode};
- dbg('msg', "Timeout, stopping msgno: $ref->{msgno} -> $node");
+ dbg("Timeout, stopping msgno: $ref->{msgno} -> $node") if isdbg('msg');
Log('msg', "Timeout, stopping msgno: $ref->{msgno} -> $node");
$ref->stop_msg($node);
$ref->start_msg($dxchan) if !get_busy($dxchan->call) && $dxchan->state eq 'normal';
}
} else {
- dbg('route', "Route: No dxchan for $ref->{to} " . ref($clref) );
+ dbg("Route: No dxchan for $ref->{to} " . ref($clref) ) if isdbg('msg');
}
}
}
{
my ($self, $dxchan) = @_;
- dbg('msg', "start msg $self->{msgno}\n");
+ dbg("start msg $self->{msgno}\n") if isdbg('msg');
$self->{linesreq} = 10;
$self->{count} = 0;
$self->{tonode} = $dxchan->call;
my $stream = $self->{stream} if exists $self->{stream};
- dbg('msg', "stop msg $self->{msgno} -> node $node\n");
+ dbg("stop msg $self->{msgno} -> node $node\n") if isdbg('msg');
delete $work{$node};
delete $work{"$node$stream"} if $stream;
$self->workclean;
$msgno++;
seek $fh, 0, 0;
$fh->print("$msgno\n");
- dbg('msg', "msgno $msgno allocated for $name\n");
+ dbg("msgno $msgno allocated for $name\n") if isdbg('msg');
$fh->close;
} else {
confess "can't open $fn $!";
my $ref;
# load various control files
- dbg('err', "load badmsg: " . (load_badmsg() or "Ok"));
- dbg('err', "load forward: " . (load_forward() or "Ok"));
- dbg('err', "load swop: " . (load_swop() or "Ok"));
+ dbg("load badmsg: " . (load_badmsg() or "Ok"));
+ dbg("load forward: " . (load_forward() or "Ok"));
+ dbg("load swop: " . (load_swop() or "Ok"));
# read in the directory
opendir($dir, $msgdir) or confess "can't open $msgdir $!";
$ref = read_msg_header("$msgdir/$_");
unless ($ref) {
- dbg('err', "Deleting $_");
+ dbg("Deleting $_");
Log('err', "Deleting $_");
unlink "$msgdir/$_";
next;
# delete any messages to 'badmsg.pl' places
if ($ref->dump_it) {
- dbg('msg', "'Bad' TO address $ref->{to}");
+ dbg("'Bad' TO address $ref->{to}") if isdbg('msg');
Log('msg', "'Bad' TO address $ref->{to}");
$ref->del_msg;
next;
# are there any to do in this directory?
return unless -d $importfn;
unless (opendir(DIR, $importfn)) {
- dbg('msg', "can\'t open $importfn $!");
+ dbg("can\'t open $importfn $!") if isdbg('msg');
Log('msg', "can\'t open $importfn $!");
return;
}
my $fn = "$importfn/$name";
next unless -f $fn;
unless (open(MSG, $fn)) {
- dbg('msg', "can\'t open import file $fn $!");
+ dbg("can\'t open import file $fn $!") if isdbg('msg');
Log('msg', "can\'t open import file $fn $!");
unlink($fn);
next;
my @f = split /\s+/, $line;
unless (@f && $f[0] =~ /^(:?S|SP|SB|SEND)$/ ) {
my $m = "invalid first line in import '$line'";
- dbg('MSG', $m );
+ dbg($m) if isdbg('msg');
return (1, $m);
}
while (@f) {
# check for and dump bad protocol messages
my $n = check($pcno, @field);
if ($n) {
- dbg('chan', "PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")");
+ dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chan');
return;
}
eval {
$pcr = Local::pcprot($self, $pcno, @field);
};
-# dbg('local', "Local::pcprot error $@") if $@;
+# dbg("Local::pcprot error $@") if isdbg('local') if $@;
return if $pcr;
SWITCH: {
if ($censorpc) {
my @bad;
if (@bad = BadWords::check($field[3])) {
- dbg('chan', "PCPROT: Bad words: @bad, dropped" );
+ dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chan');
return;
}
}
# if this is a 'nodx' node then ignore it
if ($badnode->in($field[7])) {
- dbg('chan', "PCPROT: Bad Node, dropped");
+ dbg("PCPROT: Bad Node, dropped") if isdbg('chan');
return;
}
# if this is a 'bad spotter' user then ignore it
if ($badspotter->in($field[6])) {
- dbg('chan', "PCPROT: Bad Spotter, dropped");
+ dbg("PCPROT: Bad Spotter, dropped") if isdbg('chan');
return;
}
my $d = cltounix($field[3], $field[4]);
# bang out (and don't pass on) if date is invalid or the spot is too old (or too young)
if (!$d || ($pcno == 11 && ($d < $main::systime - $pc11_max_age || $d > $main::systime + 900))) {
- dbg('chan', "PCPROT: Spot ignored, invalid date or out of range ($field[3] $field[4])\n");
+ dbg("PCPROT: Spot ignored, invalid date or out of range ($field[3] $field[4])\n") if isdbg('chan');
return;
}
# is it 'baddx'
if ($baddx->in($field[2])) {
- dbg('chan', "PCPROT: Bad DX spot, ignored");
+ dbg("PCPROT: Bad DX spot, ignored") if isdbg('chan');
return;
}
$field[5] =~ s/^\s+//; # take any leading blanks off
$field[2] = unpad($field[2]); # take off leading and trailing blanks from spotted callsign
if ($field[2] =~ /BUST\w*$/) {
- dbg('chan', "PCPROT: useless 'BUSTED' spot");
+ dbg("PCPROT: useless 'BUSTED' spot") if isdbg('chan');
return;
}
if (Spot::dup($field[1], $field[2], $d, $field[5])) {
- dbg('chan', "PCPROT: Duplicate Spot ignored\n");
+ dbg("PCPROT: Duplicate Spot ignored\n") if isdbg('chan');
return;
}
if ($censorpc) {
my @bad;
if (@bad = BadWords::check($field[5])) {
- dbg('chan', "PCPROT: Bad words: @bad, dropped" );
+ dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chan');
return;
}
}
if ($self->{inspotsfilter}) {
my ($filter, $hops) = $self->{inspotsfilter}->it(@spot);
unless ($filter) {
- dbg('chan', "PCPROT: Rejected by filter");
+ dbg("PCPROT: Rejected by filter") if isdbg('chan');
return;
}
}
eval {
$r = Local::spot($self, @spot);
};
-# dbg('local', "Local::spot1 error $@") if $@;
+# dbg("Local::spot1 error $@") if isdbg('local') if $@;
return if $r;
# DON'T be silly and send on PC26s!
# announce duplicate checking
$field[3] =~ s/^\s+//; # remove leading blanks
if (AnnTalk::dup($field[1], $field[2], $field[3])) {
- dbg('chan', "PCPROT: Duplicate Announce ignored");
+ dbg("PCPROT: Duplicate Announce ignored") if isdbg('chan');
return;
}
if ($censorpc) {
my @bad;
if (@bad = BadWords::check($field[3])) {
- dbg('chan', "PCPROT: Bad words: @bad, dropped" );
+ dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chan');
return;
}
}
my ($filter, $hops) = $self->{inannfilter}->it(@field[1..6], $self->{call},
$ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq);
unless ($filter) {
- dbg('chan', "PCPROT: Rejected by filter");
+ dbg("PCPROT: Rejected by filter") if isdbg('chan');
return;
}
}
my $newline = "PC16^";
if ($ncall eq $main::mycall) {
- dbg('chan', "PCPROT: trying to alter config on this node from outside!");
+ dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chan');
return;
}
$dxchan = DXChannel->get($ncall);
if ($dxchan && $dxchan ne $self) {
- dbg('chan', "PCPROT: PC16 from $self->{call} trying to alter locally connected $ncall, ignored!");
+ dbg("PCPROT: PC16 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chan');
return;
}
my $parent = Route::Node::get($ncall);
unless ($parent) {
- dbg('chan', "PCPROT: Node $ncall not in config");
+ dbg("PCPROT: Node $ncall not in config") if isdbg('chan');
return;
}
my $i;
my $ncall = $field[2];
my $ucall = $field[1];
if ($ncall eq $main::mycall) {
- dbg('chan', "PCPROT: trying to alter config on this node from outside!");
+ dbg("PCPROT: trying to alter config on this node from outside!") if isdbg('chan');
return;
}
$dxchan = DXChannel->get($ncall);
if ($dxchan && $dxchan ne $self) {
- dbg('chan', "PCPROT: PC17 from $self->{call} trying to alter locally connected $ncall, ignored!");
+ dbg("PCPROT: PC17 from $self->{call} trying to alter locally connected $ncall, ignored!") if isdbg('chan');
return;
}
my $parent = Route::Node::get($ncall);
unless ($parent) {
- dbg('chan', "PCPROT: Route::Node $ncall not in config");
+ dbg("PCPROT: Route::Node $ncall not in config") if isdbg('chan');
return;
}
my @rout = $parent->del_user($ucall);
my @rout;
my $parent = Route::Node::get($self->{call});
unless ($parent) {
- dbg('chan', "PCPROT: Route::Node $call not in config");
+ dbg("PCPROT: Route::Node $call not in config") if isdbg('chan');
return;
}
my $node = Route::Node::get($call);
if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me!
if ($call eq $self->{call}) {
- dbg('chan', "PCPROT: Trying to disconnect myself with PC21");
+ dbg("PCPROT: Trying to disconnect myself with PC21") if isdbg('chan');
return;
}
# routing objects
push @rout, $node->del($parent) if $node;
} else {
- dbg('chan', "PCPROT: I WILL _NOT_ be disconnected!");
+ dbg("PCPROT: I WILL _NOT_ be disconnected!") if isdbg('chan');
return;
}
$self->route_pc21(@rout) if @rout;
my ($r) = $field[6] =~ /R=(\d+)/;
$r = 0 unless $r;
if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $field[2] < 0 || $field[2] > 23) {
- dbg('chan', "PCPROT: WWV Date ($field[1] $field[2]) out of range");
+ dbg("PCPROT: WWV Date ($field[1] $field[2]) out of range") if isdbg('chan');
return;
}
if (Geomag::dup($d,$sfi,$k,$i,$field[6])) {
- dbg('chan', "PCPROT: Dup WWV Spot ignored\n");
+ dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chan');
return;
}
$field[7] =~ s/-\d+$//o; # remove spotter's ssid
eval {
$rep = Local::wwv($self, $field[1], $field[2], $sfi, $k, $i, @field[6..8], $r);
};
-# dbg('local', "Local::wwv2 error $@") if $@;
+# dbg("Local::wwv2 error $@") if isdbg('local') if $@;
return if $rep;
# DON'T be silly and send on PC27s!
return;
}
if ($field[2] eq $main::mycall) {
- dbg('chan', "PCPROT: Trying to merge to myself, ignored");
+ dbg("PCPROT: Trying to merge to myself, ignored") if isdbg('chan');
return;
}
if ($field[1] eq $self->{call}) {
$self->disconnect(1);
} else {
- dbg('chan', "PCPROT: came in on wrong channel");
+ dbg("PCPROT: came in on wrong channel") if isdbg('chan');
}
return;
}
# do some de-duping
my $d = cltounix($call, sprintf("%02d18Z", $field[2]));
if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $field[2] < 0 || $field[2] > 23) {
- dbg('chan', "PCPROT: WCY Date ($call $field[2]) out of range");
+ dbg("PCPROT: WCY Date ($call $field[2]) out of range") if isdbg('chan');
return;
}
@field = map { unpad($_) } @field;
if (WCY::dup($d,@field[3..7])) {
- dbg('chan', "PCPROT: Dup WCY Spot ignored\n");
+ dbg("PCPROT: Dup WCY Spot ignored\n") if isdbg('chan');
return;
}
eval {
$rep = Local::wwv($self, @field[1..12]);
};
- # dbg('local', "Local::wcy error $@") if $@;
+ # dbg("Local::wcy error $@") if isdbg('local') if $@;
return if $rep;
# broadcast to the eager world
#
if (eph_dup($line)) {
- dbg('chan', "PCPROT: Ephemeral dup, dropped");
+ dbg("PCPROT: Ephemeral dup, dropped") if isdbg('chan');
} else {
unless ($self->{isolate}) {
broadcast_ak1a($line, $self); # send it to everyone but me
my @localnodes;
my @remotenodes;
- dbg('trace', 'DXProt::send_local_config');
+ dbg('DXProt::send_local_config') if isdbg('trace');
# send our nodes
if ($self->{isolate}) {
if ($n) {
send_route($self, \&pc16, 1, $n, map {my $r = Route::User::get($_); $r ? ($r) : ()} $n->users);
} else {
- dbg('chan', "sent a null value");
+ dbg("sent a null value") if isdbg('chan');
}
}
}
my ($self, $call, $line) = @_;
if (ref $self && $call eq $self->{call}) {
- dbg('chan', "PCPROT: Trying to route back to source, dropped");
+ dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chan');
return;
}
$dxchan = $cl->dxchan if $cl;
if (ref $dxchan) {
if (ref $self && $dxchan eq $self) {
- dbg('chan', "PCPROT: Trying to route back to source, dropped");
+ dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chan');
return;
}
}
$dxchan->send($routeit);
}
} else {
- dbg('chan', "PCPROT: No route available, dropped");
+ dbg("PCPROT: No route available, dropped") if isdbg('chan');
}
}
($filter, $hops) = $self->{routefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq);
push @rin, $r if $filter;
} else {
- dbg('chan', "was sent a null value");
+ dbg("was sent a null value") if isdbg('chan');
}
}
}
my $ref;
eval '$ref = ' . $s;
if ($@) {
- dbg('err', $@) if $@;
- Log('err', $@) if $@;
+ dbg($@);
+ Log('err', $@);
$ref = undef;
}
return $ref;
my $sock = $conn->{sock};
return unless defined($sock);
push (@{$conn->{outqueue}}, $msg);
- dbg('connect', "connect $conn->{cnum}: $msg") unless $conn->{state} eq 'C';
+ dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
Msg::set_event_handler ($sock, "write" => sub {$conn->_send(0)});
}
if ($conn->{state} eq 'WC') {
if (exists $conn->{cmd}) {
if (@{$conn->{cmd}}) {
- dbg('connect', "connect $conn->{cnum}: $conn->{msg}");
+ dbg("connect $conn->{cnum}: $conn->{msg}") if isdbg('connect');
$conn->_docmd($conn->{msg});
}
}
$conn->{msg} = pop @lines;
}
while (defined ($msg = shift @lines)) {
- dbg('connect', "connect $conn->{cnum}: $msg") unless $conn->{state} eq 'C';
+ 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
$msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters
$conn->{blocking} = 0;
eval {$conn->{peerhost} = $sock->peerhost};
if ($@) {
- dbg('conn', $@);
+ dbg($@) if isdbg('connll');
$conn->disconnect;
} else {
eval {$conn->{peerport} = $sock->peerport};
$conn->{peerport} = 0 if $@;
my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost}, $conn->{peerport});
- dbg('connll', "accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}");
+ dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
if ($eproc) {
$conn->{eproc} = $eproc;
Msg::set_event_handler ($sock, "error" => $eproc);
}
}
} else {
- dbg('err', "ExtMsg: error on accept ($!)");
+ dbg("ExtMsg: error on accept ($!)") if isdbg('err');
}
}
my $r;
$sort = lc $sort;
- dbg('connect', "CONNECT $conn->{cnum} sort: $sort command: $line");
+ 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('connect', "Connected $conn->{cnum} to $host $port");
+ dbg("Connected $conn->{cnum} to $host $port") if isdbg('connect');
} else {
- dbg('connect', "***Connect $conn->{cnum} Failed to $host $port $!");
+ dbg("***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('connect');
}
} elsif ($sort eq 'agw') {
# turn it into an AGW object
my $callback = sub {$conn->_rcv};
Msg::set_event_handler ($a, read => $callback);
}
- dbg('connect', "connect $conn->{cnum}: started pid: $conn->{pid} as $line");
+ dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect');
} else {
$^W = 0;
dbgclose();
$SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
alarm(0);
}
- exec "$line" or dbg('err', "exec '$line' failed $!");
+ exec "$line" or dbg("exec '$line' failed $!");
}
} else {
- dbg('err', "cannot fork");
+ dbg("cannot fork");
$r = undef;
}
} else {
- dbg('err', "no socket pair $!");
+ dbg("no socket pair $!");
}
} else {
- dbg('err', "invalid type of connection ($sort)");
+ dbg("invalid type of connection ($sort)");
}
$conn->disconnect unless $r;
return $r;
{
my $conn = shift;
my $string = shift;
- dbg('connect', "connect $conn->{cnum}: abort $string");
+ dbg("connect $conn->{cnum}: abort $string") if isdbg('connect');
$conn->{abort} = $string;
}
{
my $conn = shift;
my $val = shift;
- dbg('connect', "connect $conn->{cnum}: timeout set to $val");
+ 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) });
{
my $conn = shift;
my $val = shift;
- dbg('connect', "connect $conn->{cnum}: lineend set to $val ");
+ dbg("connect $conn->{cnum}: lineend set to $val ") if isdbg('connect');
$val =~ s/\\r/\r/g;
$val =~ s/\\n/\n/g;
$conn->{lineend} = $val;
if ($line) {
my ($expect, $send) = $cmd =~ /^\s*\'(.*)\'\s+\'(.*)\'/;
if ($expect) {
- dbg('connect', "connect $conn->{cnum}: expecting: \"$expect\" received: \"$line\"");
+ dbg("connect $conn->{cnum}: expecting: \"$expect\" received: \"$line\"") if isdbg('connect');
if ($conn->{abort} && $line =~ /\Q$conn->{abort}/i) {
- dbg('connect', "connect $conn->{cnum}: aborted on /$conn->{abort}/");
+ dbg("connect $conn->{cnum}: aborted on /$conn->{abort}/") if isdbg('connect');
$conn->disconnect;
delete $conn->{cmd};
return;
}
if ($line =~ /\Q$expect/i) {
if (length $send) {
- dbg('connect', "connect $conn->{cnum}: got: \"$expect\" sending: \"$send\"");
+ dbg("connect $conn->{cnum}: got: \"$expect\" sending: \"$send\"") if isdbg('connect');
$conn->send_later("D$conn->{call}|$send");
}
delete $conn->{msg}; # get rid any input if a match
sub _timedout
{
my $conn = shift;
- dbg('connect', "connect $conn->{cnum}: timed out after $conn->{timeval} seconds");
+ dbg("connect $conn->{cnum}: timed out after $conn->{timeval} seconds") if isdbg('connect');
$conn->disconnect;
}
while (<$f>) {
chomp;
my $l = $_;
- dbg('connll', "connect $conn->{cnum}: $l");
+ dbg("connect $conn->{cnum}: $l") if isdbg('connll');
$conn->send_raw($l . $conn->{lineend});
}
$f->close;
if ($@) {
my $sort = $ref->{sort};
my $name = $ref->{name};
- dbg('err', "Error compiling $ar $sort $name: $@");
+ dbg("Error compiling $ar $sort $name: $@") if isdbg('err');
Log('err', "Error compiling $ar $sort $name: $@");
}
$rr = $@;
$in = undef;
my $s = readfilestr($fn);
my $newin = eval $s;
- dbg('conn', "$@") if $@;
+ dbg($@) if $@;
if ($in) {
$newin = new('Filter::Old', $sort, $call, $flag);
$newin->{filter} = $in;
my $true = $r ? "OK" : "REJ";
my $sort = $self->{sort};
$hops ||= "none";
- dbg('filter', "Filter: $type/$sort with $asc on '$args': $true hops: $hops");
+ dbg("Filter: $type/$sort with $asc on '$args': $true hops: $hops") if isdbg('filter');
}
return ($r, $hops);
}
$noconns++;
- dbg('connll', "Connection created ($noconns)");
+ dbg("Connection created ($noconns)") if isdbg('connll');
return bless $conn, $class;
}
if (ref $pkg) {
$call = $pkg->{call} unless $call;
return undef unless $call;
- dbg('connll', "changing $pkg->{call} to $call") if exists $pkg->{call} && $call ne $pkg->{call};
+ dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call};
delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call;
$pkg->{call} = $call;
$ref = $conns{$call} = $pkg;
- dbg('connll', "Connection $pkg->{cnum} $call stored");
+ dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll');
} else {
$ref = $conns{$call};
}
delete $conns{$call} if $ref && $ref == $conn;
}
$call ||= 'unallocated';
- dbg('connll', "Connection $conn->{cnum} $call disconnected");
+ dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll');
unless ($main::is_win) {
kill 'TERM', $conn->{pid} if exists $conn->{pid};
$conn->disconnect();
}
} else {
- dbg('err', "Msg: error on accept ($!)");
+ dbg("Msg: error on accept ($!)") if isdbg('err');
}
}
my $call = $conn->{call} || 'unallocated';
my $host = $conn->{peerhost} || '';
my $port = $conn->{peerport} || '';
- dbg('connll', "Connection $conn->{cnum} $call [$host $port] being destroyed");
+ dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll');
$noconns--;
}
$pkg = ref $pkg if ref $pkg;
my $self = bless {call => $call}, $pkg;
- dbg('routelow', "create $pkg with $call");
+ dbg("create $pkg with $call") if isdbg('routelow');
# add in all the dxcc, itu, zone info
my @dxcc = Prefix::extract($call);
my $call = _getcall($c);
unless (grep {$_ eq $call} @{$self->{$field}}) {
push @{$self->{$field}}, $call;
- dbg('routelow', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}");
+ dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow');
}
}
return $self->{$field};
my $call = _getcall($c);
if (grep {$_ eq $call} @{$self->{$field}}) {
$self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
- dbg('routelow', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}");
+ dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow');
}
}
return $self->{$field};
if ($nref) {
my $c = $nref->user_call;
-# dbg('routec', "recursing from $call -> $c");
+# dbg("recursing from $call -> $c") if isdbg('routec');
push @out, $nref->config($nodes_only, $level+1, $seen, @_);
} else {
push @out, ' ' x (($level+1)*2) . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_);
{
my $self = shift;
my @dxchan;
-# dbg('routech', "Trying node $self->{call}");
+# dbg("Trying node $self->{call}") if isdbg('routech');
my $dxchan = DXChannel->get($self->{call});
push @dxchan, $dxchan if $dxchan;
# for all the candidates.
unless (@dxchan) {
foreach my $p (@{$self->{parent}}) {
-# dbg('routech', "Trying parent $p");
+# dbg("Trying parent $p") if isdbg('routech');
next if $p eq $main::mycall; # the root
my $dxchan = DXChannel->get($p);
if ($dxchan) {
} else {
next if grep $p eq $_, @_;
my $ref = Route::Node::get($p);
-# dbg('routech', "Next node $p " . ($ref ? 'Found' : 'NOT Found') );
+# dbg("Next node $p " . ($ref ? 'Found' : 'NOT Found') if isdbg('routech') );
push @dxchan, $ref->alldxchan($self->{call}, @_) if $ref;
}
}
my $self = shift;
my $pkg = ref $self;
- dbg('routelow', "$pkg $self->{call} destroyed");
+ dbg("$pkg $self->{call} destroyed") if isdbg('routelow');
}
no strict;
my $call = shift;
$call = shift if ref $call;
my $ref = $list{uc $call};
- dbg('routerr', "Failed to get Node $call" ) unless $ref;
+ dbg("Failed to get Node $call" ) if !$ref && isdbg('routerr');
return $ref;
}
my $pkg = ref $self;
my $call = $self->{call} || "Unknown";
- dbg('route', "destroying $pkg with $call");
+ dbg("destroying $pkg with $call") if isdbg('routelow');
}
#
my $call = shift;
$call = shift if ref $call;
my $ref = $list{uc $call};
- dbg('routerr', "Failed to get User $call" ) unless $ref;
+ dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
return $ref;
}
$expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name
# $expr =~ s/\$f(\d)/\$spots[$1]/g; # swap the letter n for the correct field name
- dbg("search", "hint='$hint', expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n");
+ dbg("hint='$hint', expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n") if isdbg('search');
# build up eval to execute
$eval = qq(
$self->{interval} = $time if $recur;
push @timerchain, $self;
$notimers++;
- dbg('connll', "Timer created ($notimers)");
+ dbg("Timer created ($notimers)") if isdbg('connll');
return $self;
}
sub DESTROY
{
- dbg('connll', "timer destroyed ($Timer::notimers)");
+ dbg("timer destroyed ($Timer::notimers)") if isdbg('connll');
$Timer::notimers--;
}
1;
my ($conn, $call, $mess) = @_;
$conn->disable_read(1);
- dbg('chan', "-> D $call $mess\n");
+ dbg("-> D $call $mess\n") if isdbg('chan');
$conn->send_now("D$call|$mess");
sleep(2);
$conn->disconnect;
eval {
Local::finish(); # end local processing
};
- dbg('local', "Local::finish error $@") if $@;
+ dbg("Local::finish error $@") if $@;
# disconnect nodes
foreach $dxchan (DXChannel->get_all_nodes) {
$l->close_server;
}
- dbg('chan', "DXSpider version $version, build $build ended");
+ dbg("DXSpider version $version, build $build ended") if isdbg('chan');
Log('cluster', "DXSpider V$version, build $build ended");
dbgclose();
Logclose();
{
my $cpid;
while (($cpid = waitpid(-1, WNOHANG)) > 0) {
- dbg('reap', "cpid: $cpid");
+ dbg("cpid: $cpid") if isdbg('reap');
# Msg->pid_gone($cpid);
$zombies-- if $zombies > 0;
}
- dbg('reap', "cpid: $cpid");
+ dbg("cpid: $cpid") if isdbg('reap');
}
# this is where the input queue is dealt with and things are dispatched off to other parts of
return unless defined $sort;
# do the really sexy console interface bit! (Who is going to do the TK interface then?)
- dbg('chan', "<- $sort $call $line\n") unless $sort eq 'D';
+ dbg("<- $sort $call $line\n") if $sort ne 'D' && isdbg('chan');
# handle A records
my $user = $dxchan->user;
Log('cluster', "DXSpider V$version, build $build started");
# banner
-dbg('err', "DXSpider Version $version, build $build started", "Copyright (c) 1998-2001 Dirk Koopman G1TLH");
+dbg("Copyright (c) 1998-2001 Dirk Koopman G1TLH");
+dbg("DXSpider Version $version, build $build started");
# load Prefixes
-dbg('err', "loading prefixes ...");
+dbg("loading prefixes ...");
Prefix::load();
# load band data
-dbg('err', "loading band data ...");
+dbg("loading band data ...");
Bands::load();
# initialise User file system
-dbg('err', "loading user file system ...");
+dbg("loading user file system ...");
DXUser->init($userfn, 1);
# start listening for incoming messages/connects
-dbg('err', "starting listeners ...");
+dbg("starting listeners ...");
my $conn = IntMsg->new_server($clusteraddr, $clusterport, \&login);
$conn->conns("Server $clusteraddr/$clusterport");
push @listeners, $conn;
-dbg('err', "Internal port: $clusteraddr $clusterport");
+dbg("Internal port: $clusteraddr $clusterport");
foreach my $l (@main::listen) {
$conn = ExtMsg->new_server($l->[0], $l->[1], \&login);
$conn->conns("Server $l->[0]/$l->[1]");
push @listeners, $conn;
- dbg('err', "External Port: $l->[0] $l->[1]");
+ dbg("External Port: $l->[0] $l->[1]");
}
AGWrestart();
# load bad words
-dbg('err', "load badwords: " . (BadWords::load or "Ok"));
+dbg("load badwords: " . (BadWords::load or "Ok"));
# prime some signals
unless ($DB::VERSION) {
$SIG{HUP} = 'IGNORE';
$SIG{CHLD} = sub { $zombies++ };
- $SIG{PIPE} = sub { dbg('err', "Broken PIPE signal received"); };
- $SIG{IO} = sub { dbg('err', "SIGIO received"); };
+ $SIG{PIPE} = sub { dbg("Broken PIPE signal received"); };
+ $SIG{IO} = sub { dbg("SIGIO received"); };
$SIG{WINCH} = $SIG{STOP} = $SIG{CONT} = 'IGNORE';
$SIG{KILL} = 'DEFAULT'; # as if it matters....
# catch the rest with a hopeful message
for (keys %SIG) {
if (!$SIG{$_}) {
- # dbg('chan', "Catching SIG $_");
+ # dbg("Catching SIG $_") if isdbg('chan');
$SIG{$_} = sub { my $sig = shift; DXDebug::confess("Caught signal $sig"); };
}
}
Spot->init();
# initialise the protocol engine
-dbg('err', "reading in duplicate spot and WWV info ...");
+dbg("reading in duplicate spot and WWV info ...");
DXProt->init();
# put in a DXCluster node for us here so we can add users and take them away
}
# read in any existing message headers and clean out old crap
-dbg('err', "reading existing message headers ...");
+dbg("reading existing message headers ...");
DXMsg->init();
DXMsg::clean_old();
# read in any cron jobs
-dbg('err', "reading cron jobs ...");
+dbg("reading cron jobs ...");
DXCron->init();
# read in database descriptors
-dbg('err', "reading database descriptors ...");
+dbg("reading database descriptors ...");
DXDb::load();
# starting local stuff
-dbg('err', "doing local initialisation ...");
+dbg("doing local initialisation ...");
eval {
Local::init();
};
-dbg('local', "Local::init error $@") if $@;
+dbg("Local::init error $@") if $@;
# print various flags
-#dbg('err', "seful info - \$^D: $^D \$^W: $^W \$^S: $^S \$^P: $^P");
+#dbg("seful info - \$^D: $^D \$^W: $^W \$^S: $^S \$^P: $^P");
# this, such as it is, is the main loop!
-dbg('err', "orft we jolly well go ...");
+dbg("orft we jolly well go ...");
#open(DB::OUT, "|tee /tmp/aa");
eval {
Local::process(); # do any localised processing
};
- dbg('local', "Local::process error $@") if $@;
+ dbg("Local::process error $@") if $@;
}
if ($decease) {
last if --$decease <= 0;
sub doconnect
{
my ($sort, $line) = @_;
- dbg('connect', "CONNECT sort: $sort command: $line");
+ dbg("CONNECT sort: $sort command: $line") if isdbg('connect');
if ($sort eq 'net') {
# this is a straight network connect
my ($host) = $line =~ /host\s+(\w+)/o;
} elsif ($sort eq 'ax25') {
my @args = split /\s+/, $line;
$pid = open2(\*R, \*W, "$line") or die "can't do $line $!";
- dbg('connect', "got pid $pid");
+ dbg("got pid $pid") if isdbg('connect');
W->autoflush(1);
} else {
die "can't get here";
sub doabort
{
my $string = shift;
- dbg('connect', "abort $string");
+ dbg("abort $string") if isdbg('connect');
$abort = $string;
}
sub dotimeout
{
my $val = shift;
- dbg('connect', "timeout set to $val");
+ dbg("timeout set to $val") if isdbg('connect');
alarm($timeout = $val);
}
sub dochat
{
my ($expect, $send) = @_;
- dbg('connect', "CHAT \"$expect\" -> \"$send\"");
+ dbg("CHAT \"$expect\" -> \"$send\"") if isdbg('connect');
my $line;
alarm($timeout);
$line = <R>;
$line =~ s/\r//og;
}
- dbg('connect', "received \"$line\"");
+ dbg("received \"$line\"") if isdbg('connect');
if ($abort && $line =~ /$abort/i) {
- dbg('connect', "aborted on /$abort/");
+ dbg("aborted on /$abort/") if isdbg('connect');
exit(11);
}
}
local $\ = "\r";
W->print("$send\r");
}
- dbg('connect', "sent \"$send\"");
+ dbg("sent \"$send\"") if isdbg('connect');
}
}
sub doclient
{
my ($cl, $args) = @_;
- dbg('connect', "client: $cl args: $args");
+ dbg("client: $cl args: $args") if isdbg('connect');
my @args = split /\s+/, $args;
# if (!defined ($pid = fork())) {
-# dbg('connect', "can't fork");
+# dbg("can't fork") if isdbg('connect');
# exit(13);
# }
# if ($pid) {
open STDOUT, ">&W";
exec $cl, @args;
} else {
- dbg('connect', "client can't get here");
+ dbg("client can't get here") if isdbg('connect');
exit(13);
}
# }
sub timeout
{
- dbg('connect', "timed out after $timeout seconds");
+ dbg("timed out after $timeout seconds") if isdbg('connect');
exit(10);
}
sub term
{
- dbg('connect', "caught INT or TERM signal");
+ dbg("caught INT or TERM signal") if isdbg('connect');
kill $pid if $pid;
sleep(2);
exit(12);
sub reap
{
my $wpid = wait;
- dbg('connect', "pid $wpid has died");
+ dbg("pid $wpid has died") if isdbg('connect');
}
projects / spider.git / commitdiff