add laerned route stuff
authorminima <minima>
Mon, 23 Aug 2004 20:26:00 +0000 (20:26 +0000)
committerminima <minima>
Mon, 23 Aug 2004 20:26:00 +0000 (20:26 +0000)
perl/DXProt.pm
perl/RouteDB.pm [new file with mode: 0644]
perl/cluster.pl

index d4d5491aaed7d24144ea21e195d691c10baa59c6..33c69f234bd9c5b00fd516df0de2adacb79a9d3e 100644 (file)
@@ -34,6 +34,8 @@ use Route;
 use Route::Node;
 use Script;
 use Investigate;
+use RouteDB;
+
 
 use strict;
 
@@ -415,6 +417,10 @@ sub handle_10
                }
        }
 
+       # remember a route to this node and also the node on which this user is
+       RouteDB::update($_[6], $self->{call});
+#      RouteDB::update($to, $_[6]);
+
        # it is here and logged on
        $dxchan = DXChannel->get($main::myalias) if $to eq $main::mycall;
        $dxchan = DXChannel->get($to) unless $dxchan;
@@ -435,6 +441,8 @@ sub handle_10
                return;
        }
 
+       # can we see an interface to send it down?
+       
        # not visible here, send a message of condolence
        $vref = undef;
        $ref = Route::get($from);
@@ -507,7 +515,10 @@ sub handle_11
                }
        }
 
-
+       # remember a route
+       RouteDB::update($_[7], $self->{call});
+#      RouteDB::update($_[6], $_[7]);
+       
        my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $_[6], $_[7]);
        # global spot filtering on INPUT
        if ($self->{inspotsfilter}) {
@@ -633,12 +644,17 @@ sub handle_12
                return;
        }
 
+
        my $dxchan;
        
        if ((($dxchan = DXChannel->get($_[2])) && $dxchan->is_user) || $_[4] =~ /^[\#\w.]+$/){
                $self->send_chat($line, @_[1..6]);
        } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) {
 
+               # remember a route
+               RouteDB::update($_[5], $self->{call});
+#              RouteDB::update($_[1], $_[5]);
+
                # ignore something that looks like a chat line coming in with sysop
                # flag - this is a kludge...
                if ($_[3] =~ /^\#\d+ / && $_[4] eq '*') {
@@ -691,6 +707,8 @@ sub handle_16
                return;
        }
 
+       RouteDB::update($ncall, $self->{call});
+
        # do we believe this call? 
        unless ($ncall eq $self->{call} || $self->is_believed($ncall)) {
                if (my $ivp = Investigate::get($ncall, $self->{call})) {
@@ -845,6 +863,8 @@ sub handle_17
                return;
        }
 
+       RouteDB::delete($ncall, $self->{call});
+
        # do we believe this call? 
        unless ($ncall eq $self->{call} || $self->is_believed($ncall)) {
                if (my $ivp = Investigate::get($ncall, $self->{call})) {
@@ -997,6 +1017,8 @@ sub handle_19
                }
                $user->sort('A') unless $user->is_node;
 
+               RouteDB::update($call, $self->{call});
+
                # do we believe this call?
                my $genline = "PC19^$here^$call^$conf^$ver^$_[-1]^"; 
                unless ($call eq $self->{call} || $self->is_believed($call)) {
@@ -1099,6 +1121,8 @@ sub handle_21
                return;
        }
 
+       RouteDB::delete($call, $self->{call});
+
        # check if we believe this
        unless ($call eq $self->{call} || $self->is_believed($call)) {
                if (my $ivp = Investigate::get($call, $self->{call})) {
@@ -1474,6 +1498,9 @@ sub handle_50
        my $origin = shift;
 
        my $call = $_[1];
+
+       RouteDB::update($call, $self->{call});
+
        my $node = Route::Node::get($call);
        if ($node) {
                return unless $node->call eq $self->{call};
@@ -1547,6 +1574,9 @@ sub handle_51
                        }
                }
        } else {
+
+               RouteDB::update($from, $self->{call});
+
                if (eph_dup($line)) {
                        dbg("PCPROT: dup PC51 detected") if isdbg('chanerr');
                        return;
@@ -2026,6 +2056,7 @@ sub send_local_config
 #
 # is called route(to, pcline);
 #
+
 sub route
 {
        my ($self, $call, $line) = @_;
@@ -2037,7 +2068,9 @@ sub route
 
        # always send it down the local interface if available
        my $dxchan = DXChannel->get($call);
-       unless ($dxchan) {
+       if ($dxchan) {
+               dbg("route: $call -> $dxchan->{call} direct" ) if isdbg('route');
+       } else {
                my $cl = Route::get($call);
                $dxchan = $cl->dxchan if $cl;
                if (ref $dxchan) {
@@ -2045,8 +2078,23 @@ sub route
                                dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr');
                                return;
                        }
+                       dbg("route: $call -> $dxchan->{call} using normal route" ) if isdbg('route');
                }
        }
+
+       # try the backstop method
+       unless ($dxchan) {
+               my $rcall = RouteDB::get($call);
+               if ($rcall) {
+                       if ($rcall eq $self->{call}) {
+                               dbg("PCPROT: Trying to route back to source, dropped") if isdbg('chanerr');
+                               return;
+                       }
+                       $dxchan = DXChannel->get($call);
+                       dbg("route: $call -> $dxchan->{call} using RouteDB" ) if isdbg('route') && $dxchan;
+               }
+       }
+
        if ($dxchan) {
                my $routeit = adjust_hops($dxchan, $line);   # adjust its hop count by node name
                if ($routeit) {
diff --git a/perl/RouteDB.pm b/perl/RouteDB.pm
new file mode 100644 (file)
index 0000000..9a63d36
--- /dev/null
@@ -0,0 +1,139 @@
+# This module is used to keep a list of where things come from
+#
+# all interfaces add/update entries in here to allow casual
+# routing to occur.
+# 
+# It is up to the protocol handlers in here to make sure that 
+# this information makes sense. 
+#
+# This is (for now) just an adjunct to the normal routing
+# and is experimental. It will override filtering for
+# things that are explicitly routed (pings, talks and
+# such like).
+#
+# Copyright (c) 2004 Dirk Koopman G1TLH
+#
+# $Id$
+# 
+
+package RouteDB;
+
+use DXDebug;
+use DXChannel;
+use Prefix;
+
+use strict;
+
+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;
+
+use vars qw(%list %valid $default);
+
+%list = ();
+$default = 99;                                 # the number of hops to use if we don't know
+%valid = (
+                 call => "0,Callsign",
+                 items => "0,Interfaces,parray",
+                 t => '0,Last Seen,atime',
+                 hops => '0,Hops',
+                 count => '0,Times Seen',
+                );
+
+sub new
+{
+       my $pkg = shift;
+       my $call = shift;
+       return bless {call => $call, items => {}}, (ref $pkg || $pkg);
+}
+
+# get the best one
+sub get
+{
+       my @out = _sorted(shift);
+       return @out ? $out[0]->{call} : undef;
+}
+
+# get all of them in sorted order
+sub get_all
+{
+       my @out = _sorted(shift);
+       return @out ? map { $_->{call} } @out : ();
+}
+
+# get them all, sorted into reverse occurance order (latest first)
+# with the smallest hops
+sub _sorted
+{
+       my $call = shift;
+       my $ref = $list{$call};
+       return () unless $ref;
+       return sort {
+               if ($a->{hops} == $b->{hops}) {
+                       $b->{t} <=> $a->{t};
+               } else {
+                       $a->{hops} <=> $b->{hops};
+               } 
+       } values %{$ref->{items}};
+}
+
+
+# add or update this call on this interface
+#
+# RouteDB::update($call, $interface, $hops, time);
+#
+sub update
+{
+       my $call = shift;
+       my $interface = shift;
+       my $hops = shift || $default;
+       my $ref = $list{$call} || RouteDB->new($call);
+       my $iref = $ref->{list}->{$interface} ||= RouteDB::Item->new($call, $interface);
+       $iref->{count}++;
+       $iref->{hops} = $hops if $hops < $iref->{hops};
+       $iref->{t} = shift || $main::systime;
+       $ref->{list}->{$interface} ||= $iref;
+}
+
+sub delete
+{
+       my $call = shift;
+       my $interface = shift;
+       my $ref = $list{$call};
+       delete $ref->{list}->{$interface} if $ref;
+}
+
+#
+# generic AUTOLOAD for accessors
+#
+sub AUTOLOAD
+{
+       no strict;
+       my $name = $AUTOLOAD;
+       return if $name =~ /::DESTROY$/;
+       $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}};
+       goto &$AUTOLOAD;
+
+}
+
+package RouteDB::Item;
+
+use vars qw(@ISA);
+@ISA = qw(RouteDB);
+
+sub new
+{
+       my $pkg = shift;
+       my $call = shift;
+       return bless {call => $call, hops => $RouteDB::default}, (ref $pkg || $pkg);
+}
+
+1;
index 68f40e1aa83eff76c8b11aad87c49cb7a00718be..295fad8d5284ebd8f4d6c06218bdf479bb1a3b85 100755 (executable)
@@ -100,6 +100,7 @@ use USDB;
 use UDPMsg;
 use QSL;
 use Thingy;
+use RouteDB;
 
 use Data::Dumper;
 use IO::File;