use Filter;
use strict;
-use vars qw(%channels %valid @ISA);
+use vars qw(%channels %valid @ISA $count);
%channels = ();
+$count = 0;
%valid = (
call => '0,Callsign',
sub DESTROY
{
my $self = shift;
- undef $self->{user};
- undef $self->{conn};
- undef $self->{loc};
- undef $self->{pagedata};
- undef $self->{group};
- undef $self->{delayed};
- undef $self->{annfilter};
- undef $self->{wwvfilter};
- undef $self->{spotsfilter};
- undef $self->{inannfilter};
- undef $self->{inwwvfilter};
- undef $self->{inspotsfilter};
- undef $self->{passwd};
- undef $self->{node};
+ for (keys %$self) {
+ if (ref($self->{$_})) {
+ delete $self->{$_};
+ }
+ }
+ dbg('chan', "DXChannel $self->{call} destroyed ($count)");
+ $count--;
}
# create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
$self->{lang} = $main::lang if !$self->{lang};
$self->{func} = "";
+ $count++;
+ dbg('chan', "DXChannel $self->{call} created ($count)");
bless $self, $pkg;
return $channels{$call} = $self;
}
$motd = "$data/motd";
# are we debugging ?
-@debug = ('chan', 'state', 'msg', 'cron', 'connect');
+@debug = qw(chan state msg cron connect);
}
}
if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
- $conn->{state} = 'C';
- &{$conn->{rproc}}($conn, "O$conn->{call}|telnet");
- delete $conn->{cmd};
- $conn->{timeout}->del if $conn->{timeout};
+ $conn->to_connected($conn->{call}, 'O', 'telnet');
}
} elsif ($conn->{msg} =~ /\n/) {
my @lines = split /\r?\n/, $conn->{msg};
} elsif ($conn->{state} eq 'WL' ) {
$msg = uc $msg;
if (is_callsign($msg)) {
- &{$conn->{rproc}}($conn, "A$msg|telnet");
- _send_file($conn, "$main::data/connected");
- $conn->{state} = 'C';
+ $conn->to_connected($msg, 'A', 'telnet');
} else {
$conn->send_now("Sorry $msg is an invalid callsign");
$conn->disconnect;
if (exists $conn->{cmd} && @{$conn->{cmd}}) {
$conn->_docmd($msg);
if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
- $conn->{state} = 'C';
- &{$conn->{rproc}}($conn, "O$conn->{call}|telnet");
- delete $conn->{cmd};
- $conn->{timeout}->del if $conn->{timeout};
+ $conn->to_connected($conn->{call}, 'O', 'telnet');
}
}
}
}
}
+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->_send_file("$main::data/connected");
+ &{$conn->{rproc}}($conn, "$dir$call|$sort");
+}
+
sub new_client {
my $server_conn = shift;
my $sock = $server_conn->{sock}->accept();
my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport());
if ($eproc) {
$conn->{eproc} = $eproc;
- set_event_handler ($sock, "error" => $eproc);
+ Msg::set_event_handler ($sock, "error" => $eproc);
}
if ($rproc) {
$conn->{rproc} = $rproc;
# $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
# $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
# $conn->send_raw("\xFF\xFC\x01");
- _send_file($conn, "$main::data/issue");
+ $conn->_send_file("$main::data/issue");
$conn->send_raw("login: ");
+ $conn->_dotimeout(60);
} else {
$conn->disconnect();
}
{
my $call = shift;
my $fn = shift;
- my $conn = ExtMsg->new(\&main::rec);
+ my $conn = ExtMsg->new(\&main::new_channel);
$conn->conns($call);
my $f = new IO::File $fn;
my $conn = shift;
my $val = shift;
dbg('connect', "timeout set to $val");
- my $old = $conn->{timeout}->del if $conn->{timeout};
- $conn->{timeout} = Timer->new($val, sub{ &_timeout($conn) });
+ $conn->{timeout}->del if $conn->{timeout};
$conn->{timeval} = $val;
+ $conn->{timeout} = Timer->new($val, sub{ &_timedout($conn) });
}
sub _dolineend
unshift @{$conn->{cmd}}, $cmd;
}
-sub _timeout
+sub _timedout
{
my $conn = shift;
dbg('connect', "timed out after $conn->{timeval} seconds");
+ $conn->{timeout}->del;
+ delete $conn->{timeout};
$conn->disconnect;
}
my $conn = shift;
my $line = shift;
my @f = split /\s+/, $line;
- $conn->{call} = uc $f[0] if $f[0];
+ 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$conn->{call}|telnet");
+ &{$conn->{rproc}}($conn, "O$call|telnet");
delete $conn->{cmd};
$conn->{timeout}->del if $conn->{timeout};
}
set_event_handler($conn->{sock}, error => $callback) if exists $conn->{sock};
}
+sub set_rproc
+{
+ my $conn = shift;
+ my $callback = shift;
+ $conn->{rproc} = $callback;
+}
+
sub blocking
{
my $flags = fcntl ($_[0], F_GETFL, 0);
$conn->{sock} = $sock;
if ($conn->{rproc}) {
- my $callback = sub {_rcv($conn)};
- set_event_handler ($sock, "read" => $callback);
+ my $callback = sub {$conn->_rcv};
+ set_event_handler ($sock, read => $callback);
}
return $conn;
}
$conn->{disconnecting} = 1;
my $sock = delete $conn->{sock};
$conn->{state} = 'E';
- delete $conn->{cmd};
- delete $conn->{eproc};
- delete $conn->{rproc};
$conn->{timeout}->del if $conn->{timeout};
# be careful to delete the correct one
dbg('connll', "Connection $call disconnected");
set_event_handler ($sock, read => undef, write => undef, error => undef);
+
unless ($^O =~ /^MS/i) {
kill 'TERM', $conn->{pid} if exists $conn->{pid};
}
+
+ # get rid of any references
+ for (keys %$conn) {
+ if (ref($conn->{$_})) {
+ delete $conn->{$_};
+ }
+ }
+
return unless defined($sock);
shutdown($sock, 3);
close($sock);
$conn->enqueue($msg);
my $sock = $conn->{sock};
return unless defined($sock);
- set_event_handler ($sock, "write" => sub {$conn->_send(0)});
+ set_event_handler ($sock, write => sub {$conn->_send(0)});
}
sub enqueue {
}
# Call me back if queue has not been drained.
if (@$rq) {
- set_event_handler ($sock, "write" => sub {$conn->_send(0)});
+ set_event_handler ($sock, write => sub {$conn->_send(0)});
} else {
- set_event_handler ($sock, "write" => undef);
+ set_event_handler ($sock, write => undef);
if (exists $conn->{close_on_empty}) {
&{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
$conn->disconnect;
Proto => 'tcp',
Reuse => 1);
die "Could not create socket: $! \n" unless $self->{sock};
- set_event_handler ($self->{sock}, "read" => sub { $self->new_client } );
+ set_event_handler ($self->{sock}, read => sub { $self->new_client } );
return $self;
}
FINISH:
if (defined $bytes_read && $bytes_read == 0) {
- &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
- $conn->disconnect();
+ &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
+ $conn->disconnect;
} else {
$conn->dequeue if exists $conn->{msg};
}
$conn->{sort} = 'Incoming';
if ($eproc) {
$conn->{eproc} = $eproc;
- set_event_handler ($sock, "error" => $eproc);
+ set_event_handler ($sock, error => $eproc);
}
if ($rproc) {
$conn->{rproc} = $rproc;
- my $callback = sub {_rcv($conn)};
- set_event_handler ($sock, "read" => $callback);
+ my $callback = sub {$conn->_rcv};
+ set_event_handler ($sock, read => $callback);
} else { # Login failed
&{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
$conn->disconnect();
sub close_server
{
my $conn = shift;
- set_event_handler ($conn->{sock}, "read" => undef);
+ set_event_handler ($conn->{sock}, read => undef, write => undef, error => undef );
$conn->{sock}->close;
}
package Timer;
-use vars qw(@timerchain);
+use vars qw(@timerchain $notimers);
+use DXDebug;
@timerchain = ();
+$notimers = 0;
sub new
{
my $self = bless { t=>$time + time, proc=>$proc }, $class;
$self->{interval} = $time if $recur;
push @timerchain, $self;
+ $notimers++;
+ dbg('connll', "Timer created ($notimers)");
return $self;
}
sub del
{
my $self = shift;
- my $old = delete $self->{proc};
+ delete $self->{proc};
@timerchain = grep {$_ != $self} @timerchain;
- return $old;
}
sub handler
}
}
+sub DESTROY
+{
+ dbg('connll', "Timer destroyed ($notimers)");
+ $notimers--;
+}
1;
package main;
-#use strict;
-#use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects $zombies $root
-# $lang $myalias @debug $userfn $clusteraddr $clusterport $mycall $decease );
+use strict;
+use vars qw(@inqueue $systime $version $starttime $lockfn @outstanding_connects $zombies $root
+ @listeners $lang $myalias @debug $userfn $clusteraddr $clusterport $mycall $decease );
@inqueue = (); # the main input queue, an array of hashes
$systime = 0; # the time now (in seconds)
sub error_handler
{
my $dxchan = shift;
+ $dxchan->{conn}->set_error(undef) if exists $dxchan->{conn};
$dxchan->disconnect;
}
# handle incoming messages
-sub rec
+sub new_channel
{
my ($conn, $msg) = @_;
- my $dxchan = DXChannel->get_by_cnum($conn); # get the dxconnnect object for this message
my ($sort, $call, $line) = DXChannel::decode_input(0, $msg);
return unless defined $sort;
# set up the basic channel info
- if (!defined $dxchan) {
-
- # is there one already connected to me - locally?
- my $user = DXUser->get($call);
- if ($sort ne 'O' && Msg->conns($call)) {
- my $mess = DXM::msg($lang, ($user && $user->is_node) ? 'concluster' : 'conother', $call, $main::mycall);
- already_conn($conn, $call, $mess);
- return;
- }
-
- # is there one already connected elsewhere in the cluster?
- if ($user) {
- if (($user->is_node || $call eq $myalias) && !DXCluster->get_exact($call)) {
- ;
- } else {
- if (my $ref = DXCluster->get_exact($call)) {
- my $mess = DXM::msg($lang, 'concluster', $call, $ref->mynode->call);
- already_conn($conn, $call, $mess);
- return;
- }
- }
- $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems
+ # is there one already connected to me - locally?
+ my $user = DXUser->get($call);
+ if ($sort ne 'O' && Msg->conns($call)) {
+ my $mess = DXM::msg($lang, ($user && $user->is_node) ? 'concluster' : 'conother', $call, $main::mycall);
+ already_conn($conn, $call, $mess);
+ return;
+ }
+
+ # is there one already connected elsewhere in the cluster?
+ if ($user) {
+ if (($user->is_node || $call eq $myalias) && !DXCluster->get_exact($call)) {
+ ;
} else {
if (my $ref = DXCluster->get_exact($call)) {
my $mess = DXM::msg($lang, 'concluster', $call, $ref->mynode->call);
already_conn($conn, $call, $mess);
return;
}
- $user = DXUser->new($call);
}
-
- # is he locked out ?
- if ($user->lockout) {
- Log('DXCommand', "$call is locked out, disconnected");
- $conn->disconnect;
+ $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems
+ } else {
+ if (my $ref = DXCluster->get_exact($call)) {
+ my $mess = DXM::msg($lang, 'concluster', $call, $ref->mynode->call);
+ already_conn($conn, $call, $mess);
return;
}
-
- # mark him up
- $conn->conns($call) unless $sort eq 'O';
- $conn->set_error(sub {error_handler($dxchan)});
-
- # create the channel
- $dxchan = DXCommandmode->new($call, $conn, $user) if $user->is_user;
- $dxchan = DXProt->new($call, $conn, $user) if $user->is_node;
- $dxchan = BBS->new($call, $conn, $user) if $user->is_bbs;
- die "Invalid sort of user on $call = $sort" if !$dxchan;
+ $user = DXUser->new($call);
+ }
+
+ # is he locked out ?
+ if ($user->lockout) {
+ Log('DXCommand', "$call is locked out, disconnected");
+ $conn->disconnect;
+ return;
}
+
+ # create the channel
+ my $dxchan;
+ $dxchan = DXCommandmode->new($call, $conn, $user) if $user->is_user;
+ $dxchan = DXProt->new($call, $conn, $user) if $user->is_node;
+ $dxchan = BBS->new($call, $conn, $user) if $user->is_bbs;
+ die "Invalid sort of user on $call = $sort" if !$dxchan;
+
+ # check that the conn has a callsign
+ $conn->conns($call) if $conn->isa('IntMsg');
+
+ # set callbacks
+ $conn->set_error(sub {error_handler($dxchan)});
+ $conn->set_rproc(sub {my ($conn,$msg) = @_; rec($dxchan, $conn, $msg);});
+ rec($dxchan, $conn, $msg);
+}
+
+sub rec
+{
+ my ($dxchan, $conn, $msg) = @_;
# queue the message and the channel object for later processing
if (defined $msg) {
sub login
{
- return \&rec;
+ return \&new_channel;
}
# cease running this program, close down all the connections nicely
$dxchan->normal($line);
$dxchan->disconnect if ($dxchan->{state} eq 'bye');
} elsif ($sort eq 'Z') {
- $dxchan->conn(undef);
$dxchan->disconnect;
} elsif ($sort eq 'D') {
; # ignored (an echo)
projects / spider.git / commitdiff