X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXChannel.pm;h=c2358c3dd2366f56e1d7018c23fde7d474bb288d;hb=4b207544da78b182bd12e94eab01451694749012;hp=e3878ecf719f6fe2c8181a2d11c8323821d59c0f;hpb=6aca4e461103870de99b0ce452f21cf7fedeb54b;p=spider.git diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index e3878ecf..c2358c3d 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -4,7 +4,7 @@ # This is the base class for all channel operations, which is everything to do # with input and output really. # -# The instance variable in the outside world will be generally be called $dxchann +# The instance variable in the outside world will be generally be called $dxchan # # This class is 'inherited' (if that is the goobledegook for what I am doing) # by various other modules. The point to understand is that the 'instance variable' @@ -17,24 +17,28 @@ # # PLEASE NOTE - I am a C programmer using this as a method of learning perl # firstly and OO about ninthly (if you don't like the design and you can't -# improve it with better OO by make it smaller and more efficient, then tough). +# improve it with better OO and thus make it smaller and more efficient, then tough). +# +# Copyright (c) 1998-2016 - Dirk Koopman G1TLH # -# Copyright (c) 1998 - Dirk Koopman G1TLH # -# $Id$ # package DXChannel; use Msg; use DXM; use DXUtil; +use DXVars; use DXDebug; -use Carp; +use Filter; +use Prefix; +use Route; use strict; -use vars qw(%channels %valid); +use vars qw(%channels %valid @ISA $count $maxerrors); %channels = (); +$count = 0; %valid = ( call => '0,Callsign', @@ -42,40 +46,107 @@ use vars qw(%channels %valid); user => '9,DXUser ref', startt => '0,Start Time,atime', t => '9,Time,atime', - pc50_t => '9,Last PC50 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 => '9,Connection Type', - 'sort' => '9,Type of Channel', + 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', - confmode => '0,In Conference?,yesno', + conf => '0,In Conference?,yesno', dx => '0,DX Spots,yesno', redirect => '0,Redirect messages to', lang => '0,Language', - func => '9,Function', + func => '5,Function', loc => '9,Local Vars', # used by func to store local variables in beep => '0,Want Beeps,yesno', - lastread => '9,Last Msg Read', - outbound => '9,outbound?,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 => '9,Isolate network,yesno', - delayed => '9,Delayed messages,parray', - annfilter => '9,Announce Filter', - wwvfilter => '9,WWV Filter', - spotfilter => '9,Spot Filter', - passwd => '9,Passwd List,parray', + 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', + rbnfilter => '5,RBN 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', + inrbnfilter => '5,RBN Filt-inp', + inpc92filter => '5,PC92 Route Filt-inp', + passwd => '9,Passwd List,yesno', + 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', + route => '9,Route Data', + dxcc => '0,Country Code', + 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', + 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', + 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', + isslugged => '9,Still Slugged,yesno', + sluggedpcs => '9,Slugged PCxx Queue,parray', ); +$maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection + +# object destruction +sub DESTROY +{ + my $self = shift; + for (keys %$self) { + if (ref($self->{$_})) { + delete $self->{$_}; + } + } + dbg("DXChannel $self->{call} destroyed ($count)") if isdbg('chan'); + $count--; +} + # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] sub alloc { @@ -84,36 +155,133 @@ sub alloc die "trying to create a duplicate channel for $call" if $channels{$call}; $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 $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; + $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->{inqueue} = []; + + $count++; + dbg("DXChannel $self->{call} created ($count)") if isdbg('chan'); bless $self, $pkg; return $channels{$call} = $self; } -# obtain a channel object by callsign [$obj = DXChannel->get($call)] +# 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; +} + +sub rec +{ + my ($self, $msg) = @_; + + # queue the message and the channel object for later processing + if (defined $msg) { + push @{$self->{inqueue}}, $msg; + } + $self->process_one; +} + +# 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); } +# +# gimme all the ak1a nodes +# +sub get_all_nodes +{ + my $ref; + my @out; + foreach $ref (values %channels) { + push @out, $ref if $ref->is_node; + } + 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 +{ + my $ref; + my @out; + foreach $ref (values %channels) { + push @out, $ref if $ref->is_user; + } + return @out; +} + +# return a list of all user callsigns +sub get_all_user_calls +{ + my $ref; + my @out; + foreach $ref (values %channels) { + push @out, $ref->{call} if $ref->is_user; + } + return @out; +} + # obtain a channel object by searching for its connection reference sub get_by_cnum { @@ -135,25 +303,82 @@ sub del delete $channels{$self->{call}}; } -# is it an ak1a cluster ? +# is it a bbs +sub is_bbs +{ + return $_[0]->{sort} eq 'B'; +} + +sub is_node +{ + 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 +{ + return $_[0]->{sort} =~ /^[UW]$/; +} + +# is it a clx node +sub is_clx +{ + return $_[0]->{sort} eq 'C'; +} + +# it is a Web connected user +sub is_web +{ + return $_[0]->{sort} eq 'W'; +} + +# is it a spider node +sub is_spider +{ + return $_[0]->{sort} eq 'S'; +} + +# is it a DXNet node +sub is_dxnet +{ + return $_[0]->{sort} eq 'X'; +} + +# is it a ar-cluster node +sub is_arcluster +{ + 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'} eq 'U'; + return @_ ? $self->{sort} = shift : $self->{sort} ; } -# is it a connect type -sub is_connect +# find out whether we are prepared to believe this callsign on this interface +sub is_believed { my $self = shift; - return $self->{'sort'} eq 'C'; + my $call = shift; + + return grep $call eq $_, $self->user->believe; } # handle out going messages, immediately without waiting for the select to drop @@ -162,13 +387,42 @@ sub send_now { my $self = shift; my $conn = $self->{conn}; + return unless $conn; + my $sort = shift; + my $call = $self->{call}; + + for (@_) { +# chomp; + my @lines = split /\n/; + for (@lines) { + $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; +} + +# +# send later with letter (more control) +# + +sub send_later +{ + my $self = shift; + my $conn = $self->{conn}; + return unless $conn; my $sort = shift; my $call = $self->{call}; for (@_) { - chomp; - $conn->send_now("$sort$call|$_") if $conn; - dbg('chan', "-> $sort $call $_") if $conn; +# chomp; + my @lines = split /\n/; + for (@lines) { + $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; } @@ -180,14 +434,19 @@ sub send # this is always later and always data { my $self = shift; my $conn = $self->{conn}; + return unless $conn; my $call = $self->{call}; - for (@_) { - chomp; - $conn->send_later("D$call|$_") if $conn; - dbg('chan', "-> D $call $_") if $conn; + 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) @@ -211,7 +470,7 @@ sub msg return DXM::msg($self->{lang}, @_); } -# stick a broadcast on the delayed queue +# stick a broadcast on the delayed queue (but only up to 20 items) sub delay { my $self = shift; @@ -219,6 +478,9 @@ sub delay $self->{delayed} = [] unless $self->{delayed}; push @{$self->{delayed}}, $s; + if (@{$self->{delayed}} >= 20) { + shift @{$self->{delayed}}; # lose oldest one + } } # change the state of the channel - lots of scope for debugging here :-) @@ -229,13 +491,11 @@ sub state $self->{oldstate} = $self->{state}; $self->{state} = shift; $self->{func} = '' unless defined $self->{func}; - dbg('state', "$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n"); + dbg("$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n") if isdbg('state'); # if there is any queued up broadcasts then splurge them out here - if ($self->{delayed} && ($self->{state} eq 'prompt' || $self->{state} eq 'convers')) { - for (@{$self->{delayed}}) { - $self->send($_); - } + if ($self->{delayed} && ($self->{state} eq 'prompt' || $self->{state} eq 'talk')) { + $self->send (@{$self->{delayed}}); delete $self->{delayed}; } } @@ -247,13 +507,9 @@ sub disconnect { my $self = shift; my $user = $self->{user}; - my $conn = $self->{conn}; - my $call = $self->{call}; - $self->finish(); - $conn->send_now("Z$call|bye") if $conn; # this will cause 'client' to disconnect - $user->close() if defined $user; - $conn->disconnect() if $conn; + $user->close($self->{startt}, $self->{hostname}) if defined $user; + $self->{conn}->disconnect if $self->{conn}; $self->del(); } @@ -273,6 +529,46 @@ sub closeall } } +# +# Tell all the users that we have come in or out (if they want to know) +# +sub tell_login +{ + 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(); + 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}} ; + } +} + # various access routines # @@ -294,17 +590,216 @@ sub field_prompt return $valid{$ele}; } -no strict; -sub AUTOLOAD +# take a standard input message and decode it into its standard parts +sub decode_input +{ + my $dxchan = shift; + my $data = shift; + my ($sort, $call, $line) = $data =~ /^([A-Z])(#?[A-Z0-9\/\-]{3,25})\|(.*)$/; + + my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN"; + + # 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"); + return (); + } + + if(ref($dxchan) && $call ne $chcall) { + dbg("DUFF Line come in for $call on wrong channel $chcall"); + return(); + } + + return ($sort, $call, $line); +} + +# broadcast a message to all clusters taking into account isolation +# [except those mentioned after buffer] +sub broadcast_nodes +{ + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + 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 + foreach $dxchan (@dxchan) { + next if grep $dxchan == $_, @except; + next if $dxchan == $main::me; + + my $routeit = $dxchan->can('adjust_hops') ? $dxchan->adjust_hops($s) : $s; # adjust its hop count by node name + + $dxchan->send($routeit) unless $dxchan->{isolate} || !$routeit; + } +} + +# broadcast a message to all clusters ignoring isolation +# [except those mentioned after buffer] +sub broadcast_all_nodes +{ + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + 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 + foreach $dxchan (@dxchan) { + next if grep $dxchan == $_, @except; + next if $dxchan == $main::me; + + my $routeit = $dxchan->can('adjust_hops') ? $dxchan->adjust_hops($s) : $s; # adjust its hop count by node name + $dxchan->send($routeit); + } +} + +# broadcast to all users +# storing the spot or whatever until it is in a state to receive it +sub broadcast_users +{ + my $s = shift; # the line to be rebroadcast + 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 = get_all_users(); + my $dxchan; + my @out; + + foreach $dxchan (@dxchan) { + next if grep $dxchan == $_, @except; + push @out, $dxchan; + } + broadcast_list($s, $sort, $fref, @out); +} + + +# broadcast to a list of users +sub broadcast_list +{ + my $s = shift; + my $sort = shift; + my $fref = shift; + my $dxchan; + + foreach $dxchan (@_) { + my $filter = 1; + next if $dxchan == $main::me; + + if ($sort eq 'dx') { + next unless $dxchan->{dx}; + ($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; + next if $sort eq 'wwv' && !$dxchan->{wwv}; + next if $sort eq 'wcy' && !$dxchan->{wcy}; + next if $sort eq 'wx' && !$dxchan->{wx}; + + $s =~ s/\a//og unless $dxchan->{beep}; + + if ($dxchan->{state} eq 'prompt' || $dxchan->{state} eq 'talk') { + $dxchan->send($s); + } else { + $dxchan->delay($s); + } + } +} + +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 (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); +} + + +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; + } +} + +#no strict; +sub AUTOLOAD +{ + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; - @_ ? $self->{$name} = shift : $self->{$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}}; + goto &$AUTOLOAD; } + 1; __END__;