X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?p=spider.git;a=blobdiff_plain;f=perl%2FDXChannel.pm;h=674f835599bf972738bd06993bbb5b71606a413f;hp=929e7e530183ed71d62be1c2e4b9ff4701d122ed;hb=f63d598af3f797b56b8d5e23ec4ff5254192eee9;hpb=9b47e7023d41616a9efa885ef9338277dc2ab851 diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 929e7e53..674f8355 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,97 +35,105 @@ use Prefix; use Route; use strict; -use vars qw(%channels %valid @ISA $count); +use vars qw(%channels %valid @ISA $count $maxerrors); %channels = (); $count = 0; %valid = ( - call => '0,Callsign', - conn => '9,Msg Conn ref', - user => '9,DXUser ref', - startt => '0,Start Time,atime', - t => '9,Time,atime', - pc50_t => '5,Last PC50 Time,atime', - priv => '9,Privilege', - state => '0,Current State', - oldstate => '5,Last State', - list => '9,Dep Chan List', - name => '0,User Name', - consort => '5,Connection Type', 'sort' => '5,Type of Channel', - wwv => '0,Want WWV,yesno', - wcy => '0,Want WCY,yesno', - wx => '0,Want WX,yesno', - talk => '0,Want Talk,yesno', ann => '0,Want Announce,yesno', - here => '0,Here?,yesno', + ann_talk => '0,Suppress Talk Anns,yesno', + annfilter => '5,Ann Filt-out', + badcount => '1,Bad Word Count', + badip => '9,BAD IP address', + beep => '0,Want Beeps,yesno', + build => '1,Node Build', + call => '0,Callsign', + cluster => '5,Cluster data', conf => '0,In Conference?,yesno', + conn => '9,Msg Conn ref', + consort => '5,Connection Type', + cq => '0,CQ Zone', + delayed => '5,Delayed messages,parray', + disconnecting => '9,Disconnecting,yesno', + do_pc9x => '9,Handles PC9x,yesno', dx => '0,DX Spots,yesno', - redirect => '0,Redirect messages to', - lang => '0,Language', + dxcc => '0,Country Code', + edit => '7,Edit Function', + enhanced => '5,Enhanced Client,yesno', + errors => '9,Errors', func => '5,Function', - loc => '9,Local Vars', # used by func to store local variables in - beep => '0,Want Beeps,yesno', - lastread => '5,Last Msg Read', - outbound => '5,outbound?,yesno', - remotecmd => '9,doing rcmd,yesno', - pagelth => '0,Page Length', - pagedata => '9,Page Data Store', group => '0,Access Group,parray', # used to create a group of users/nodes for some purpose or other - isolate => '5,Isolate network,yesno', - delayed => '5,Delayed messages,parray', - annfilter => '5,Ann Filt-out', - wwvfilter => '5,WWV Filt-out', - wcyfilter => '5,WCY Filt-out', - spotsfilter => '5,Spot Filt-out', - routefilter => '5,Route Filt-out', + gtk => '5,Using GTK,yesno', + handle_xml => '9,Handles XML,yesno', + here => '0,Here?,yesno', + hostname => '0,Hostname', inannfilter => '5,Ann Filt-inp', - inwwvfilter => '5,WWV Filt-inp', - inwcyfilter => '5,WCY Filt-inp', - inspotsfilter => '5,Spot Filt-inp', + inpc92filter => '5,PC92 Route Filt-inp', + inqueue => '9,Input Queue,parray', + inrbnfilter => '5,RBN Filt-inp', inroutefilter => '5,Route Filt-inp', + inscript => '9,In a script,yesno', + inspotsfilter => '5,Spot Filt-inp', + inwcyfilter => '5,WCY Filt-inp', + inwwvfilter => '5,WWV Filt-inp', + isbasic => '9,Internal Connection', + isolate => '5,Isolate network,yesno', + isslugged => '9,Still Slugged,yesno', + itu => '0,ITU Zone', + lang => '0,Language', + lastmsgpoll => '0,Last Msg Poll,atime', + lastping => '5,Ping last sent,atime', + lastread => '5,Last Msg Read', + list => '9,Dep Chan List', + loc => '9,Local Vars', # used by func to store local variables in + logininfo => '9,Login info req,yesno', + metric => '1,Route metric', + name => '0,User Name', + newroute => '1,New Style Routing,yesno', + next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + next_pc92_update => '9,Next PC92 Update,atime', + nopings => '5,Ping Obs Count', + oldstate => '5,Last State', + outbound => '5,outbound?,yesno', + pagedata => '9,Page Data Store', + pagelth => '0,Page Length', passwd => '9,Passwd List,yesno', + pc50_t => '5,Last PC50 Time,atime', + pc92filter => '5,PC92 Route Filt-out', + pingave => '0,Ping ave time', pingint => '5,Ping Interval ', - nopings => '5,Ping Obs Count', - lastping => '5,Ping last sent,atime', pingtime => '5,Ping totaltime,parray', - pingave => '0,Ping ave time', - logininfo => '9,Login info req,yesno', - talklist => '0,Talk List,parray', - cluster => '5,Cluster data', - isbasic => '9,Internal Connection', - errors => '9,Errors', + priv => '9,Privilege', + prompt => '0,Required Prompt', + rbnfilter => '5,RBN Filt-out', + redirect => '0,Redirect messages to', + registered => '9,Registered?,yesno', + remotecmd => '9,doing rcmd,yesno', route => '9,Route Data', - dxcc => '0,Country Code', - itu => '0,ITU Zone', - cq => '0,CQ Zone', - enhanced => '5,Enhanced Client,yesno', + routefilter => '5,Route Filt-out', senddbg => '8,Sending Debug,yesno', - width => '0,Column Width', - disconnecting => '9,Disconnecting,yesno', - ann_talk => '0,Suppress Talk Anns,yesno', - metric => '1,Route metric', - badcount => '1,Bad Word Count', - edit => '7,Edit Function', - registered => '9,Registered?,yesno', - prompt => '0,Required Prompt', - version => '1,Node Version', - build => '1,Node Build', - verified => '9,Verified?,yesno', - newroute => '1,New Style Routing,yesno', + sluggedpcs => '9,Slugged PCxx Queue,parray', + spotsfilter => '5,Spot Filt-out', + startt => '0,Start Time,atime', + state => '0,Current State', + t => '9,Time,atime', + talk => '0,Want Talk,yesno', + talklist => '0,Talk List,parray', + user => '9,DXUser ref', ve7cc => '0,VE7CC program special,yesno', - lastmsgpoll => '0,Last Msg Poll,atime', - inscript => '9,In a script,yesno', - handle_xml => '9,Handles XML,yesno', - inqueue => '9,Input Queue,parray', + verified => '9,Verified?,yesno', + version => '1,Node Version', + wcy => '0,Want WCY,yesno', + wcyfilter => '5,WCY Filt-out', + width => '0,Column Width', + wwv => '0,Want WWV,yesno', + wwvfilter => '5,WWV Filt-out', + wx => '0,Want WX,yesno', ); -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 @@ -157,19 +165,21 @@ sub alloc $user->new_buddies unless $user->buddies; $self->{group} = $user->group; $self->{sort} = $user->sort; + $self->{width} = $user->width; } - $self->{startt} = $self->{t} = time; + $self->{startt} = $self->{t} = $main::systime; $self->{state} = 0; $self->{oldstate} = 0; $self->{lang} = $main::lang if !$self->{lang}; $self->{func} = ""; + $self->{width} ||= 80; # add in all the dxcc, itu, zone info my @dxcc = Prefix::extract($call); 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} = []; @@ -179,6 +189,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 { @@ -195,6 +221,7 @@ sub rec if (defined $msg) { push @{$self->{inqueue}}, $msg; } + $self->process_one; } # obtain a channel object by callsign [$obj = DXChannel::get($call)] @@ -223,6 +250,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 { @@ -269,69 +307,70 @@ 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'; +} + +sub is_dslink +{ + return $_[0]->{sort} eq 'L'; } # 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 @@ -358,7 +397,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; @@ -381,7 +421,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,8 +509,8 @@ sub disconnect my $self = shift; my $user = $self->{user}; - $user->close() if defined $user; - $self->{conn}->disconnect; + $user->close($self->{startt}, $self->{hostname}) if defined $user; + $self->{conn}->disconnect if $self->{conn}; $self->del(); } @@ -517,7 +558,7 @@ sub tell_buddies $call ||= $self->{call}; $call =~ s/-\d+$//; - my $s = $node ? "$node: $call" : $call; + $m .= 'n' if $node; # send info to all logged in thingies my @dxchan = get_all_users(); @@ -525,7 +566,7 @@ sub tell_buddies foreach $dxchan (@dxchan) { next if $dxchan == $self; next if $dxchan->{call} eq $main::mycall; - $dxchan->send($dxchan->msg($m, $s)) if grep $_ eq $call, @{$dxchan->{user}->{buddies}} ; + $dxchan->send($dxchan->msg($m, $call, $node)) if grep $_ eq $call, @{$dxchan->{user}->{buddies}} ; } } @@ -555,7 +596,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"; @@ -574,28 +615,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 @@ -669,7 +688,7 @@ sub broadcast_list if ($sort eq 'dx') { next unless $dxchan->{dx}; - ($filter) = $dxchan->{spotsfilter}->it(@{$fref}) if ref $fref; + ($filter) = $dxchan->{spotsfilter}->it($fref) if $dxchan->{spotsfilter} && ref $fref; next unless $filter; } next if $sort eq 'ann' && !$dxchan->{ann} && $s !~ /^To\s+LOCAL\s+de\s+(?:$main::myalias|$main::mycall)/i; @@ -687,40 +706,82 @@ sub broadcast_list } } +sub process_one +{ + my $self = shift; + + 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 + $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 'C') { + $self->width($line); # change number of columns + } 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 (get_all()) { + foreach my $dxchan (values %channels) { + next if $dxchan->{disconnecting}; + $dxchan->process_one; + } +} - while (my $data = shift @{$dxchan->{inqueue}}) { - my ($sort, $call, $line) = $dxchan->decode_input($data); - next unless defined $sort; +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; +} - # 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; - } +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); +} - # 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; - - # 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"; - } - } + +sub isregistered +{ + my $self = shift; + + # the sysop is registered! + return 1 if $self->{call} eq $main::myalias || $self->{call} eq $main::mycall; + + if ($main::reqreg) { + return $self->{registered}; + } else { + return 1; } }