X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FRoute.pm;h=4e58b02b3894ac32bd435cf125c3b7e98e0b7964;hb=26cab5eb43ff7295e88d2129d8d8d5c1fe37a10a;hp=2e90703e039b70015007fe8f4b0885f714e2c2e1;hpb=0f840352db1ffbda3920aabba3d6eb45897e4f22;p=spider.git

diff --git a/perl/Route.pm b/perl/Route.pm
index 2e90703e..4e58b02b 100644
--- a/perl/Route.pm
+++ b/perl/Route.pm
@@ -15,20 +15,74 @@
 package Route;
 
 use DXDebug;
+use DXChannel;
+use Prefix;
 
 use strict;
 
-use vars qw(%list %valid);
+
+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 $filterdef $default_metric);
 
 %valid = (
 		  call => "0,Callsign",
+		  flags => "0,Flags,phex",
+		  dxcc => '0,Country Code',
+		  itu => '0,ITU Zone',
+		  cq => '0,CQ Zone',
+		  state => '0,State',
+		  city => '0,City',
+		  dxchan => '0,DXChans,parray',
+		  links => '0,Node Links,parray',
 		 );
 
+
+$filterdef = bless ([
+			  # tag, sort, field, priv, special parser 
+			  ['channel', 'c', 0],
+			  ['channel_dxcc', 'nc', 1],
+			  ['channel_itu', 'ni', 2],
+			  ['channel_zone', 'nz', 3],
+			  ['call', 'c', 4],
+			  ['by', 'c', 4],
+			  ['call_dxcc', 'nc', 5],
+			  ['by_dxcc', 'nc', 5],
+			  ['call_itu', 'ni', 6],
+			  ['by_itu', 'ni', 6],
+			  ['call_zone', 'nz', 7],
+			  ['by_zone', 'nz', 7],
+			  ['channel_state', 'ns', 8],
+			  ['call_state', 'ns', 9],
+			  ['by_state', 'ns', 9],
+			 ], 'Filter::Cmd');
+
+$default_metric = 10;
+
 sub new
 {
 	my ($pkg, $call) = @_;
-	dbg('route', "$pkg created $call");
-	return bless {call => $call}, $pkg;
+	$pkg = ref $pkg if ref $pkg;
+
+	my $self = bless {call => $call}, $pkg;
+	dbg("create $pkg with $call") if isdbg('routelow');
+
+	# 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->{state} = $dxcc[1]->state;
+		$self->{city} = $dxcc[1]->city;
+	}
+	$self->{flags} = here(1);
+	
+	return $self; 
 }
 
 #
@@ -53,26 +107,262 @@ sub _addlist
 {
 	my $self = shift;
 	my $field = shift;
+	my @out;
 	foreach my $c (@_) {
-		my $call = _getcall($c);
-		unless (grep {$_ eq $call} @{$self->{$field}}) {
+		confess "Need a ref here" unless ref($c);
+		
+		my $call = $c->{call};
+		unless (grep $_ eq $call, @{$self->{$field}}) {
 			push @{$self->{$field}}, $call;
-			dbg('route', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}");
+			dbg(ref($self) . " adding $call to " . $self->{call} . "->\{$field\}") if isdbg('routelow');
+			push @out, $c;
 		}
 	}
+	return @out;
 }
 
 sub _dellist
 {
 	my $self = shift;
 	my $field = shift;
+	my @out;
 	foreach my $c (@_) {
-		my $call = _getcall($c);
-		if (grep {$_ eq $call} @{$self->{$field}}) {
+		confess "Need a ref here" unless ref($c);
+		my $call = $c->{call};
+		if (grep $_ eq $call, @{$self->{$field}}) {
 			$self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
-			dbg('route', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}");
+			dbg(ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}") if isdbg('routelow');
+			push @out, $c;
+		}
+	}
+	return @out;
+}
+
+sub is_empty
+{
+	my $self = shift;
+	return @{$self->{$_[0]}} == 0;
+}
+
+#
+# flag field constructors/enquirers
+#
+# These can be called in various ways:-
+#
+# Route::here or $ref->here returns 1 or 0 depending on value of the here flag
+# Route::here(1) returns 2 (the bit value of the here flag)
+# $ref->here(1) or $ref->here(0) sets the here flag
+#
+
+sub here
+{
+	my $self = shift;
+	my $r = shift;
+	return $self ? 2 : 0 unless ref $self;
+	return ($self->{flags} & 2) ? 1 : 0 unless defined $r;
+	$self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0));
+	return $r ? 1 : 0;
+}
+
+sub conf
+{
+	my $self = shift;
+	my $r = shift;
+	return $self ? 1 : 0 unless ref $self;
+	return ($self->{flags} & 1) ? 1 : 0 unless defined $r;
+	$self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0));
+	return $r ? 1 : 0;
+}
+
+# 
+# display routines
+#
+
+sub user_call
+{
+	my $self = shift;
+	my $call = sprintf "%s", $self->{call};
+	return $self->here ? "$call" : "($call)";
+}
+
+sub config
+{
+	my $self = shift;
+	my $nodes_only = shift;
+	my $level = shift || 0;
+	my $seen = shift;
+	my @out;
+	my $line;
+	my $ucall = $self->user_call;
+	my $call = $self->{call};
+	my $printit = 1;
+	
+	return if $level > 1 && DXChannel->get($call);
+
+#	my @seen = @$seen || ();
+#	return if $level > 1 && grep $call eq $_, @seen;
+#	push @seen, @{$self->{links}};
+	
+
+	# allow ranges
+	if (@_) {
+		$printit = grep $call =~ m|$_|, @_;
+	}
+
+	if ($printit) {
+		$line = ' ' x ($level*3) . "$ucall";
+		push @out, $line;
+#		push @$seen, $call;
+		
+		foreach my $ncall (sort @{$self->{links}}) {
+			my $nref = Route::Node::get($ncall);
+			
+			if ($nref) {
+				my $c = $nref->user_call;
+				dbg("recursing from $call -> $c (" . (join ',', @$seen) . ")") if isdbg('routec');
+				
+				unless (grep $ncall eq $_, @$seen) {
+#					push @seen, $call;
+					push @$seen, $ncall;
+					push @out, $nref->config($nodes_only, $level+1, $seen, @_);
+#					pop @$seen;
+#					pop @seen;
+				} else {
+#					$line .= "->$ncall" if $line !~ $ncall;
+#					push @out, $line;
+				}
+			} else {
+				push @out, ' ' x (($level+1)*2)  . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_); 
+			}
+		}
+#		pop @$seen;
+	}
+
+	return @out;
+}
+
+sub cluster
+{
+	my $nodes = Route::Node::count();
+	my $tot = Route::User::count();
+	my $users = scalar DXCommandmode::get_all();
+	my $maxusers = Route::User::max();
+	my $uptime = main::uptime();
+	
+	return " $nodes nodes, $users local / $tot total users  Max users $maxusers  Uptime $uptime";
+}
+
+#
+# routing things
+#
+
+sub get
+{
+	my $call = shift;
+	return Route::Node::get($call) || Route::User::get($call);
+}
+
+sub _distance
+{
+	my $self = shift;
+	my $ah = shift;
+	my $call = $self->{call};
+	
+	if (DXChannel->get($call)) {
+		my $n = scalar @_ || 0;
+		my $o = $ah->{$call} || 9999;
+		$ah->{$call} = $n if $n < $o;
+		dbg("_distance hit: $call = $n") if isdbg('routech');
+		return;
+	} 
+
+	dbg("_distance miss $call: " . join(',', @_)) if isdbg('routech');
+	
+	foreach my $c (@{$self->{links}}) {
+		next if $c eq $call || $c eq $main::mycall;
+		next if grep $c eq $_, @_;
+		
+		my $n = get($c);
+		_distance($n, $ah, @_, $c);
+	}
+	return;
+}
+
+sub _ordered_routes
+{
+	my $self = shift;
+	my @routes;
+
+	if (exists $self->{dxchan}) {
+		dbg("stored routes for $self->{call}: " . join(',', @{$self->{dxchan}})) if isdbg('routech');
+		return @{$self->{dxchan}} if exists $self->{dxchan};
+	}
+
+	my %ah;
+	_distance($self, \%ah);
+	
+	@routes = sort {$ah{$a} <=> $ah{$b}} keys %ah;
+	$self->{dxchan} = \@routes;
+	dbg("new routes for $self->{call}: " . join(',', @routes)) if isdbg('routech');
+	return @routes;
+}
+
+# find all the possible dxchannels which this object might be on
+sub alldxchan
+{
+	my $self = shift;
+	my @dxchan;
+
+	my $dxchan = DXChannel->get($self->{call});
+	push @dxchan, $dxchan if $dxchan;
+
+	@dxchan = map {DXChannel->get($_)} _ordered_routes($self) unless @dxchan;
+	return @dxchan;
+}
+
+sub dxchan
+{
+	my $self = shift;
+	
+	# ALWAYS return the locally connected channel if present;
+	my $dxchan = DXChannel->get($self->call);
+	return $dxchan if $dxchan;
+	
+	my @dxchan = $self->alldxchan;
+	return undef unless @dxchan;
+	
+	# determine the minimum ping channel
+	my $minping = 99999999;
+	foreach my $dxc (@dxchan) {
+		my $p = $dxc->pingave;
+		if (defined $p  && $p < $minping) {
+			$minping = $p;
+			$dxchan = $dxc;
 		}
 	}
+	$dxchan = shift @dxchan unless $dxchan;
+	return $dxchan;
+}
+
+sub _addlink
+{
+	my $self = shift;
+	delete $self->{dxchan};
+    return $self->_addlist('links', @_);
+}
+
+sub _dellink
+{
+	my $self = shift;
+	delete $self->{dxchan};
+    return $self->_dellist('links', @_);
+}
+
+sub haslink
+{
+	my $self = shift;
+	my $other = shift->{call};
+	return grep $other eq $_, @{$self->{links}};
 }
 
 #
@@ -84,7 +374,7 @@ sub DESTROY
 	my $self = shift;
 	my $pkg = ref $self;
 	
-	dbg('route', "$pkg $self->{call} destroyed");
+	dbg("$pkg $self->{call} destroyed") if isdbg('routelow');
 }
 
 no strict;
@@ -95,7 +385,9 @@ no strict;
 sub fields
 {
 	my $pkg = shift;
-	my @out, keys %pkg::valid if ref $pkg;
+	$pkg = ref $pkg if ref $pkg;
+    my $val = "${pkg}::valid";
+	my @out = keys %$val;
 	push @out, keys %valid;
 	return @out;
 }
@@ -108,7 +400,8 @@ sub field_prompt
 { 
 	my ($self, $ele) = @_;
 	my $pkg = ref $self;
-	return $pkg::valid{$ele} || $valid{$ele};
+    my $val = "${pkg}::valid";
+	return $val->{$ele} || $valid{$ele};
 }
 
 #
@@ -116,16 +409,18 @@ sub field_prompt
 #
 sub AUTOLOAD
 {
-	my $self = shift;
-	my ($pkg, $name) = $AUTOLOAD =~ /^(.*)::([^:]*)$/;
-	return if $name eq 'DESTROY';
+	no strict;
+	my $name = $AUTOLOAD;
+	return if $name =~ /::DESTROY$/;
+	$name =~ s/^.*:://o;
   
-	confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $pkg::valid{$name};
+	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;
+
 }
 
 1;