X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=6da3ecbe36d0be30a00ee2a47ce64bdac9f1e411;hb=dc305f992d75a6b35edda9e1aefab510a3ed617e;hp=01d2135e657e834eac2bf100d5e61f2e443f6036;hpb=50f6466ca2dff82ca470a4abe327d741cffef61a;p=spider.git diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 01d2135e..6da3ecbe 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -85,7 +85,7 @@ $count = 0; inwcyfilter => '5,WCY Filt-inp', inspotsfilter => '5,Spot Filt-inp', inroutefilter => '5,Route Filt-inp', - passwd => '9,Passwd List,parray', + passwd => '9,Passwd List,yesno', pingint => '5,Ping Interval ', nopings => '5,Ping Obs Count', lastping => '5,Ping last sent,atime', @@ -106,11 +106,24 @@ $count = 0; 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', + 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', ); use vars qw($VERSION $BRANCH); $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0; +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); $main::build += $VERSION; $main::branch += $BRANCH; @@ -157,6 +170,7 @@ sub alloc $self->{itu} = $dxcc[1]->itu; $self->{cq} = $dxcc[1]->cq; } + $self->{inqueue} = []; $count++; dbg("DXChannel $self->{call} created ($count)") if isdbg('chan'); @@ -164,17 +178,26 @@ sub alloc return $channels{$call} = $self; } -# obtain a channel object by callsign [$obj = DXChannel->get($call)] +sub rec +{ + my ($self, $msg) = @_; + + # queue the message and the channel object for later processing + if (defined $msg) { + push @{$self->{inqueue}}, $msg; + } +} + +# obtain a channel object by callsign [$obj = DXChannel::get($call)] sub get { - my ($pkg, $call) = @_; + my $call = shift; return $channels{$call}; } # obtain all the channel objects sub get_all { - my ($pkg) = @_; return values(%channels); } @@ -244,7 +267,7 @@ sub is_bbs sub is_node { my $self = shift; - return $self->{'sort'} =~ /[ACRSX]/; + return $self->{'sort'} =~ /[ACRSXW]/; } # is it an ak1a node ? sub is_ak1a @@ -267,6 +290,13 @@ sub is_clx return $self->{'sort'} eq 'C'; } +# it is Aranea +sub is_aranea +{ + my $self = shift; + return $self->{'sort'} eq 'W'; +} + # is it a spider node sub is_spider { @@ -295,6 +325,15 @@ sub sort return @_ ? $self->{'sort'} = shift : $self->{'sort'} ; } +# find out whether we are prepared to believe this callsign on this interface +sub is_believed +{ + my $self = shift; + my $call = shift; + + return grep $call eq $_, $self->user->believe; +} + # handle out going messages, immediately without waiting for the select to drop # this could, in theory, block sub send_now @@ -490,12 +529,12 @@ sub decode_input # 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("DUFF Line on $chcall: $data") if isdbg('err'); + dbg("DUFF Line on $chcall: $data"); return (); } if(ref($dxchan) && $call ne $chcall) { - dbg("DUFF Line come in for $call on wrong channel $chcall") if isdbg('err'); + dbg("DUFF Line come in for $call on wrong channel $chcall"); return(); } @@ -506,18 +545,20 @@ sub rspfcheck { my ($self, $flag, $node, $user) = @_; my $nref = Route::Node::get($node); - if ($nref) { - if ($nref->dxchan == $self) { + 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('rspf'); + dbg("RSPF: $user not on $node") if isdbg('chanerr'); } else { - dbg("RSPF: Shortest path for $node is " . $nref->dxchan->{call}) if isdbg('rspf'); + 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('rspf'); + dbg("RSPF: required $node not found" ) if isdbg('chanerr'); } return 0; } @@ -528,7 +569,7 @@ sub broadcast_nodes { my $s = shift; # the line to be rebroadcast my @except = @_; # to all channels EXCEPT these (dxchannel refs) - my @dxchan = DXChannel::get_all_nodes(); + my @dxchan = get_all_nodes(); my $dxchan; # send it if it isn't the except list and isn't isolated and still has a hop count @@ -544,11 +585,11 @@ sub broadcast_nodes # broadcast a message to all clusters ignoring isolation # [except those mentioned after buffer] -sub broadcast_all_ak1a +sub broadcast_all_nodes { my $s = shift; # the line to be rebroadcast my @except = @_; # to all channels EXCEPT these (dxchannel refs) - my @dxchan = DXChannel::get_all_nodes(); + my @dxchan = get_all_nodes(); my $dxchan; # send it if it isn't the except list and isn't isolated and still has a hop count @@ -569,7 +610,7 @@ sub broadcast_users my $sort = shift; # the type of transmission my $fref = shift; # a reference to an object to filter on my @except = @_; # to all channels EXCEPT these (dxchannel refs) - my @dxchan = DXChannel::get_all_users(); + my @dxchan = get_all_users(); my $dxchan; my @out; @@ -613,21 +654,57 @@ sub broadcast_list } } +sub process +{ + 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; + } + + # 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"; + } + } + } +} -no strict; +#no strict; sub AUTOLOAD { - my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + goto &$AUTOLOAD; }