X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=699e87a8d8da0a4b27008413281cb0be4076af2f;hb=b9dffeff7239952814342dad19db3a51def6fab7;hp=aae692efb52e4f31230c0b04b118765ee3236775;hpb=1256794cae0d863c829011df3f87dc1fb70f977d;p=spider.git diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index aae692ef..699e87a8 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -101,6 +101,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', @@ -113,14 +114,14 @@ $count = 0; 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,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; - # object destruction sub DESTROY { @@ -147,7 +148,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; } @@ -164,6 +166,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'); @@ -171,17 +174,34 @@ sub alloc return $channels{$call} = $self; } -# obtain a channel object by callsign [$obj = DXChannel->get($call)] +# rebless this channel as something else +sub rebless +{ + my $self = shift; + my $class = shift; + return $channels{$self->{call}} = bless $self, $class; +} + +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); } @@ -251,7 +271,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 @@ -274,6 +294,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 { @@ -302,6 +329,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 @@ -317,7 +353,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; @@ -340,7 +377,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; @@ -356,15 +394,16 @@ sub send # this is always later and always data return unless $conn; my $call = $self->{call}; - for (@_) { -# chomp; - my @lines = split /\n/; - for (@lines) { - $conn->send_later("D$call|$_"); - dbg("-> D $call $_") if isdbg('chan'); + foreach my $l (@_) { + for (ref $l ? @$l : $l) { + my @lines = split /\n/; + for (@lines) { + $conn->send_later("D$call|$_"); + dbg("-> D $call $_") if isdbg('chan'); + } } } - $self->{t} = time; + $self->{t} = $main::systime; } # send a file (always later) @@ -452,7 +491,9 @@ 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(); @@ -460,7 +501,28 @@ 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)) 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(); + my $dxchan; + foreach $dxchan (@dxchan) { + next if $dxchan == $self; + next if $dxchan->{call} eq $main::mycall; + $dxchan->send($dxchan->msg($m, $call, $node)) if grep $_ eq $call, @{$dxchan->{user}->{buddies}} ; } } @@ -537,7 +599,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 @@ -557,7 +619,7 @@ 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 @@ -578,7 +640,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; @@ -622,11 +684,59 @@ 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"; + } + } + } +} + +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; +} #no strict; sub AUTOLOAD { - my $self = shift; no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; @@ -637,9 +747,7 @@ sub AUTOLOAD # 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}}; - &$AUTOLOAD($self, @_); -# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; -# @_ ? $self->{$name} = shift : $self->{$name} ; + goto &$AUTOLOAD; }