X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=8384567003685d54e1a5dfe155095e2a91e573db;hb=85eea0e7a1a773e5da2422bd1b5ff77951f24e77;hp=7048257188392544b42ca287eed2001e5b1c5162;hpb=fd0a34c34ad4112ee21e0730f7307498ff437e18;p=spider.git diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 70482571..83845670 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -35,7 +35,7 @@ use Prefix; use Route; use strict; -use vars qw(%channels %valid @ISA $count); +use vars qw(%channels %valid @ISA $count $maxerrors); %channels = (); $count = 0; @@ -80,11 +80,13 @@ $count = 0; wcyfilter => '5,WCY Filt-out', spotsfilter => '5,Spot Filt-out', routefilter => '5,Route Filt-out', + pc92filter => '5,PC92 Route Filt-out', inannfilter => '5,Ann Filt-inp', inwwvfilter => '5,WWV Filt-inp', inwcyfilter => '5,WCY Filt-inp', inspotsfilter => '5,Spot Filt-inp', inroutefilter => '5,Route Filt-inp', + inpc92filter => '5,PC92 Route Filt-inp', passwd => '9,Passwd List,yesno', pingint => '5,Ping Interval ', nopings => '5,Ping Obs Count', @@ -122,8 +124,12 @@ $count = 0; do_pc9x => '9,Handles PC9x,yesno', inqueue => '9,Input Queue,parray', next_pc92_update => '9,Next PC92 Update,atime', + next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + anyevents => '9,outstanding AnyEvent handles,parray', ); +$maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection + # object destruction sub DESTROY { @@ -142,11 +148,16 @@ sub alloc { my ($pkg, $call, $conn, $user) = @_; my $self = {}; - + die "trying to create a duplicate channel for $call" if $channels{$call}; + bless $self, $pkg; + $self->{call} = $call; $self->{priv} = 0; - $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list + if (defined $conn && ref $conn) { # if this isn't defined then it must be a list + $self->{conn} = $conn; + $conn->set_on_eof(sub {$self->disconnect}); + } if (defined $user) { $self->{user} = $user; $self->{lang} = $user->lang; @@ -169,19 +180,37 @@ sub alloc $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; + $self->{anyevents} = []; $count++; dbg("DXChannel $self->{call} created ($count)") if isdbg('chan'); - bless $self, $pkg; return $channels{$call} = $self; } +# count errors and disconnect if too many +# this has to be here because it can come from rcmd (DXProt) as +# well as DXCommandmode. +sub _error_out +{ + my $self = shift; + my $e = shift; + if (++$self->{errors} > $maxerrors) { + $self->send($self->msg('e26')); + $self->disconnect; + return (); + } else { + return ($self->msg($e)); + } +} + # rebless this channel as something else sub rebless { my $self = shift; my $class = shift; - return $channels{$self->{call}} = bless $self, $class; + my $new = bless $self, $class; + $new->{conn}->on_eof(sub {$new->disconnect}); + return $channels{$self->{call}} = $new; } sub rec @@ -220,6 +249,17 @@ sub get_all_nodes return @out; } +# return a list of node calls +sub get_all_node_calls +{ + my $ref; + my @out; + foreach $ref (values %channels) { + push @out, $ref->{call} if $ref->is_node; + } + return @out; +} + # return a list of all users sub get_all_users { @@ -354,9 +394,9 @@ sub send_now # chomp; my @lines = split /\n/; for (@lines) { + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); $conn->send_now("$sort$call|$_"); # debug log it, but not if it is a log message - dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -378,9 +418,9 @@ sub send_later # chomp; my @lines = split /\n/; for (@lines) { + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); $conn->send_later("$sort$call|$_"); # debug log it, but not if it is a log message - dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -400,8 +440,8 @@ sub send # this is always later and always data for (ref $l ? @$l : $l) { my @lines = split /\n/; for (@lines) { - $conn->send_later("D$call|$_"); dbg("-> D $call $_") if isdbg('chan'); + $conn->send_later("D$call|$_"); } } } @@ -468,7 +508,7 @@ sub disconnect my $user = $self->{user}; $user->close() if defined $user; - $self->{conn}->disconnect if $self->{conn}; + $self->{conn}->close_on_empty if $self->{conn}; $self->del(); } @@ -573,28 +613,6 @@ sub decode_input return ($sort, $call, $line); } -sub rspfcheck -{ - my ($self, $flag, $node, $user) = @_; - my $nref = Route::Node::get($node); - my $dxchan = $nref->dxchan if $nref; - if ($nref && $dxchan) { - if ($dxchan == $self) { - return 1 unless $user; - return 1 if $user eq $node; - my @users = $nref->users; - return 1 if @users == 0 || grep $user eq $_, @users; - dbg("RSPF: $user not on $node") if isdbg('chanerr'); - } else { - dbg("RSPF: Shortest path for $node is " . $nref->dxchan->{call}) if isdbg('chanerr'); - } - } else { - return 1 if $flag; - dbg("RSPF: required $node not found" ) if isdbg('chanerr'); - } - return 0; -} - # broadcast a message to all clusters taking into account isolation # [except those mentioned after buffer] sub broadcast_nodes @@ -688,18 +706,16 @@ sub broadcast_list sub process { - foreach my $dxchan (get_all()) { - + foreach my $dxchan (values %channels) { + + next if $dxchan->{disconnecting}; + while (my $data = shift @{$dxchan->{inqueue}}) { my ($sort, $call, $line) = $dxchan->decode_input($data); next unless defined $sort; # do the really sexy console interface bit! (Who is going to do the TK interface then?) dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan'); - if ($dxchan->{disconnecting}) { - dbg('In disconnection, ignored'); - next; - } # handle A records my $user = $dxchan->user; @@ -736,6 +752,25 @@ sub handle_xml return $r; } +sub anyevent_add +{ + my $self = shift; + my $handle = shift; + my $sort = shift || "unknown"; + + push @{$self->{anyevents}}, $handle; + dbg("anyevent: add $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent'); +} + +sub anyevent_del +{ + my $self = shift; + my $handle = shift; + my $sort = shift || "unknown"; + $self->{anyevents} = [ grep {$_ != $handle} @{$self->{anyevents}} ]; + dbg("anyevent: delete $sort handle making " . scalar @{$self->{anyevents}} . " handles in use") if isdbg('anyevent'); +} + #no strict; sub AUTOLOAD {