From: minima <minima>
Date: Tue, 15 May 2001 16:27:24 +0000 (+0000)
Subject: dd Route!
X-Git-Tag: OLDROUTE_1_48~12
X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f840352db1ffbda3920aabba3d6eb45897e4f22;p=spider.git

dd Route!
---

diff --git a/perl/Route.pm b/perl/Route.pm
new file mode 100644
index 00000000..2e90703e
--- /dev/null
+++ b/perl/Route.pm
@@ -0,0 +1,131 @@
+#!/usr/bin/perl
+#
+# This module impliments the abstracted routing for all protocols and
+# is probably what I SHOULD have done the first time. 
+#
+# Heyho.
+#
+# This is just a container class which I expect to subclass 
+#
+# Copyright (c) 2001 Dirk Koopman G1TLH
+#
+# $Id$
+# 
+
+package Route;
+
+use DXDebug;
+
+use strict;
+
+use vars qw(%list %valid);
+
+%valid = (
+		  call => "0,Callsign",
+		 );
+
+sub new
+{
+	my ($pkg, $call) = @_;
+	dbg('route', "$pkg created $call");
+	return bless {call => $call}, $pkg;
+}
+
+#
+# get a callsign from a passed reference or a string
+#
+
+sub _getcall
+{
+	my $self = shift;
+	my $thingy = shift;
+	$thingy = $self unless $thingy;
+	$thingy = $thingy->call if ref $thingy;
+	$thingy = uc $thingy if $thingy;
+	return $thingy;
+}
+
+# 
+# add and delete a callsign to/from a list
+#
+
+sub _addlist
+{
+	my $self = shift;
+	my $field = shift;
+	foreach my $c (@_) {
+		my $call = _getcall($c);
+		unless (grep {$_ eq $call} @{$self->{$field}}) {
+			push @{$self->{$field}}, $call;
+			dbg('route', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}");
+		}
+	}
+}
+
+sub _dellist
+{
+	my $self = shift;
+	my $field = shift;
+	foreach my $c (@_) {
+		my $call = _getcall($c);
+		if (grep {$_ eq $call} @{$self->{$field}}) {
+			$self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
+			dbg('route', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}");
+		}
+	}
+}
+
+#
+# track destruction
+#
+
+sub DESTROY
+{
+	my $self = shift;
+	my $pkg = ref $self;
+	
+	dbg('route', "$pkg $self->{call} destroyed");
+}
+
+no strict;
+#
+# return a list of valid elements 
+# 
+
+sub fields
+{
+	my $pkg = shift;
+	my @out, keys %pkg::valid if ref $pkg;
+	push @out, keys %valid;
+	return @out;
+}
+
+#
+# return a prompt for a field
+#
+
+sub field_prompt
+{ 
+	my ($self, $ele) = @_;
+	my $pkg = ref $self;
+	return $pkg::valid{$ele} || $valid{$ele};
+}
+
+#
+# generic AUTOLOAD for accessors
+#
+sub AUTOLOAD
+{
+	my $self = shift;
+	my ($pkg, $name) = $AUTOLOAD =~ /^(.*)::([^:]*)$/;
+	return if $name eq 'DESTROY';
+  
+	confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $pkg::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} ;
+}
+
+1;