From 85ea68ecce028876ab0d60d622c1d92c95bb8747 Mon Sep 17 00:00:00 2001
From: minima <minima>
Date: Mon, 23 Aug 2004 20:26:00 +0000
Subject: [PATCH] add laerned route stuff

---
 perl/DXProt.pm  |  52 +++++++++++++++++-
 perl/RouteDB.pm | 139 ++++++++++++++++++++++++++++++++++++++++++++++++
 perl/cluster.pl |   1 +
 3 files changed, 190 insertions(+), 2 deletions(-)
 create mode 100644 perl/RouteDB.pm

diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index d4d5491a..33c69f23 100644
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -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
index 00000000..9a63d368
--- /dev/null
+++ b/perl/RouteDB.pm
@@ -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;
diff --git a/perl/cluster.pl b/perl/cluster.pl
index 68f40e1a..295fad8d 100755
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -100,6 +100,7 @@ use USDB;
 use UDPMsg;
 use QSL;
 use Thingy;
+use RouteDB;
 
 use Data::Dumper;
 use IO::File;
-- 
2.34.1