X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=fbdbeee310bf430b5bac3d5f7282347916f47b04;hb=refs%2Fheads%2Fnewdisc;hp=b0208f103e0e6093df5b654c133420e110780419;hpb=b359511572b5dcd67dc17437e7ce4ca3574eada8;p=spider.git diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index b0208f10..fbdbeee3 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -19,9 +19,9 @@ # firstly and OO about ninthly (if you don't like the design and you can't # improve it with better OO and thus make it smaller and more efficient, then tough). # -# Copyright (c) 1998-2000 - Dirk Koopman G1TLH +# Copyright (c) 1998-2016 - Dirk Koopman G1TLH +# # -# $Id$ # package DXChannel; @@ -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', @@ -101,6 +103,7 @@ $count = 0; itu => '0,ITU Zone', cq => '0,CQ Zone', enhanced => '5,Enhanced Client,yesno', + gtk => '5,Using GTK,yesno', senddbg => '8,Sending Debug,yesno', width => '0,Column Width', disconnecting => '9,Disconnecting,yesno', @@ -118,14 +121,14 @@ $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', + next_pc92_update => '9,Next PC92 Update,atime', + next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + hostname => '0,Hostname', ); -use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; +$maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection # object destruction sub DESTROY @@ -153,7 +156,8 @@ sub alloc if (defined $user) { $self->{user} = $user; $self->{lang} = $user->lang; - $user->new_group() if !$user->group; + $user->new_group unless $user->group; + $user->new_buddies unless $user->buddies; $self->{group} = $user->group; $self->{sort} = $user->sort; } @@ -168,7 +172,7 @@ sub alloc if (@dxcc > 0) { $self->{dxcc} = $dxcc[1]->dxcc; $self->{itu} = $dxcc[1]->itu; - $self->{cq} = $dxcc[1]->cq; + $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; @@ -178,6 +182,22 @@ sub alloc 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 { @@ -194,6 +214,7 @@ sub rec if (defined $msg) { push @{$self->{inqueue}}, $msg; } + $self->process_one; } # obtain a channel object by callsign [$obj = DXChannel::get($call)] @@ -222,6 +243,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 { @@ -268,69 +300,65 @@ sub del # is it a bbs sub is_bbs { - my $self = shift; - return $self->{'sort'} eq 'B'; + return $_[0]->{sort} eq 'B'; } sub is_node { - my $self = shift; - return $self->{'sort'} =~ /[ACRSXW]/; + return $_[0]->{sort} =~ /^[ACRSX]$/; } # is it an ak1a node ? sub is_ak1a { - my $self = shift; - return $self->{'sort'} eq 'A'; + return $_[0]->{sort} eq 'A'; } # is it a user? sub is_user { - my $self = shift; - return $self->{'sort'} eq 'U'; + return $_[0]->{sort} =~ /^[UW]$/; } # is it a clx node sub is_clx { - my $self = shift; - return $self->{'sort'} eq 'C'; + return $_[0]->{sort} eq 'C'; } -# it is Aranea -sub is_aranea +# it is a Web connected user +sub is_web { - my $self = shift; - return $self->{'sort'} eq 'W'; + return $_[0]->{sort} eq 'W'; } # is it a spider node sub is_spider { - my $self = shift; - return $self->{'sort'} eq 'S'; + return $_[0]->{sort} eq 'S'; } # is it a DXNet node sub is_dxnet { - my $self = shift; - return $self->{'sort'} eq 'X'; + return $_[0]->{sort} eq 'X'; } # is it a ar-cluster node sub is_arcluster { - my $self = shift; - return $self->{'sort'} eq 'R'; + return $_[0]->{sort} eq 'R'; +} + +sub is_rbn +{ + return $_[0]->{sort} eq 'N'; } # for perl 5.004's benefit sub sort { my $self = shift; - return @_ ? $self->{'sort'} = shift : $self->{'sort'} ; + return @_ ? $self->{sort} = shift : $self->{sort} ; } # find out whether we are prepared to believe this callsign on this interface @@ -357,7 +385,8 @@ sub send_now my @lines = split /\n/; for (@lines) { $conn->send_now("$sort$call|$_"); - dbg("-> $sort $call $_") if isdbg('chan'); + # debug log it, but not if it is a log message + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -380,7 +409,8 @@ sub send_later my @lines = split /\n/; for (@lines) { $conn->send_later("$sort$call|$_"); - dbg("-> $sort $call $_") if isdbg('chan'); + # debug log it, but not if it is a log message + dbg("-> $sort $call $_") if $sort ne 'L' && isdbg('chan'); } } $self->{t} = time; @@ -468,7 +498,7 @@ sub disconnect my $user = $self->{user}; $user->close() if defined $user; - $self->{conn}->disconnect; + $self->{conn}->disconnect if $self->{conn}; $self->del(); } @@ -493,7 +523,30 @@ sub closeall # sub tell_login { - my ($self, $m) = @_; + my ($self, $m, $call) = @_; + + $call ||= $self->{call}; + + # send info to all logged in thingies + my @dxchan = get_all_users(); + my $dxchan; + foreach $dxchan (@dxchan) { + next if $dxchan == $self; + next if $dxchan->{call} eq $main::mycall; + $dxchan->send($dxchan->msg($m, $call)) if $dxchan->{logininfo}; + } +} + +# +# Tell all the users if a buddy is logged or out +# +sub tell_buddies +{ + my ($self, $m, $call, $node) = @_; + + $call ||= $self->{call}; + $call =~ s/-\d+$//; + $m .= 'n' if $node; # send info to all logged in thingies my @dxchan = get_all_users(); @@ -501,7 +554,7 @@ sub tell_login foreach $dxchan (@dxchan) { next if $dxchan == $self; next if $dxchan->{call} eq $main::mycall; - $dxchan->send($dxchan->msg($m, $self->{call})) if $dxchan->{logininfo}; + $dxchan->send($dxchan->msg($m, $call, $node)) if grep $_ eq $call, @{$dxchan->{user}->{buddies}} ; } } @@ -531,7 +584,7 @@ sub decode_input { my $dxchan = shift; my $data = shift; - my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z0-9\-]{3,9})\|(.*)$/; + my ($sort, $call, $line) = $data =~ /^([A-Z])(#?[A-Z0-9\/\-]{3,25})\|(.*)$/; my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN"; @@ -550,28 +603,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 @@ -663,43 +694,69 @@ sub broadcast_list } } -sub process +sub process_one { - foreach my $dxchan (get_all()) { - - 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; - } + my $self = shift; - # handle A records - my $user = $dxchan->user; - if ($sort eq 'A' || $sort eq 'O') { - $dxchan->start($line, $sort); - } elsif ($sort eq 'I') { - die "\$user not defined for $call" if !defined $user; + while (my $data = shift @{$self->{inqueue}}) { + my ($sort, $call, $line) = $self->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'); + + # handle A records + my $user = $self->user; + if ($sort eq 'I') { + die "\$user not defined for $call" unless defined $user; - # normal input - $dxchan->normal($line); - } elsif ($sort eq 'Z') { - $dxchan->disconnect; - } elsif ($sort eq 'D') { - ; # ignored (an echo) - } elsif ($sort eq 'G') { - $dxchan->enhanced($line); - } else { - print STDERR atime, " Unknown command letter ($sort) received from $call\n"; - } + # normal input + $self->normal($line); + } elsif ($sort eq 'G') { + $self->enhanced($line); + } elsif ($sort eq 'A' || $sort eq 'O' || $sort eq 'W') { + $self->start($line, $sort); + } elsif ($sort eq 'Z') { + $self->disconnect; + } elsif ($sort eq 'D') { + ; # ignored (an echo) + } else { + dbg atime . " DXChannel::process_one: Unknown command letter ($sort) received from $call\n"; } } } +sub process +{ + foreach my $dxchan (values %channels) { + next if $dxchan->{disconnecting}; + $dxchan->process_one; + } +} + +sub handle_xml +{ + my $self = shift; + my $r = 0; + + if (DXXml::available()) { + $r = $self->{handle_xml} || 0; + } else { + delete $self->{handle_xml} if exists $self->{handle_xml}; + } + return $r; +} + +sub error_handler +{ + my $self = shift; + my $error = shift || ''; + dbg("$self->{call} ERROR '$error', closing") if isdbg('chan'); + $self->{conn}->set_error(undef) if exists $self->{conn}; + $self->disconnect(1); +} + + #no strict; sub AUTOLOAD {