added more routing code

diff --git a/perl/Aranea.pm b/perl/Aranea.pm
index 7f0134c33e32bb0b8061d18684245b514d51f6a4..f4d9a1ec1a33af09c959304c67e8e2ff0b2007d8 100644 (file)
--- a/perl/Aranea.pm
+++ b/perl/Aranea.pm
@@ -197,6 +197,23 @@ sub disconnect
 # because it has to be used before a channel is fully initialised).
 #
 
+sub formathead
+{
+       my $mycall = shift;
+       my $dts = shift;
+       my $hop = shift;
+       my $user = shift;
+       my $group = shift;
+       
+       my $s = "$mycall,$dts,$hop";
+       $s .= ",$user" if $user;
+       if ($group) {
+               $s .= "," unless $user;
+               $s .= ",$group" if $group;
+       } 
+       return $s;
+}
+
 sub genheader
 {
        my $mycall = shift;
@@ -204,10 +221,7 @@ sub genheader
        my $from = shift;
        
        my $date = ((($dayno << 1) | $ntpflag) << 18) |  ($main::systime % 86400);
-       my $r = "$mycall," . sprintf('%6X%04X,0', $date, $seqno);
-       $r .= ",$to" if $to;
-       $r .= "," if $from && !$to;
-       $r .= ",$from" if $from;
+       my $r = formathead($mycall, sprintf('%6X%04X', $date, $seqno), 0, $from, $to);
        $seqno++;
        $seqno = 0 if $seqno > 0x0ffff;
        return $r;
@@ -285,7 +299,7 @@ sub input
        my ($head, $data) = split /\|/, $line, 2;
        return unless $head && $data;
 
-       my ($origin, $dts, $hop, $group, $user) = split /,/, $head;
+       my ($origin, $dts, $hop, $user, $group) = split /,/, $head;
        return if DXDupe::check("Ara,$origin,$dts", $dupeage);
        my $err;
        $err .= "incomplete header," unless $origin && $dts && defined $hop;
@@ -313,9 +327,7 @@ sub input
                $thing = $class->new();
 
                # reconstitute the header but wth hop increased by one
-               $head = join(',', $origin, $dts, ++$hop);
-               $head .= ",$group" if $group;
-               $head .= ",$user" if $user;
+               $head = formathead($origin, $dts, ++$hop, $user, $group);
                $thing->{Aranea} = "$head|$data";
 
                # store useful data

diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index 62f262907fc6fa0ba6a48750766d95632e555b8f..d2a0a12a31d51b4a519bbd6e4283dac8a0818c2b 100644 (file)
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -726,6 +726,12 @@ sub is_node
        return $self->{sort} =~ /[ACRSX]/;
 }
 
+sub is_aranea
+{
+       my $self = shift;
+       return $self->{sort} eq 'W';
+}
+
 sub is_user
 {
        my $self = shift;

diff --git a/perl/Thingy.pm b/perl/Thingy.pm
index 7bbf3edb1568673e265769b36926ea0068dea786..ed33fde027491b84b041187d6e464aedcfc8771c 100644 (file)
--- a/perl/Thingy.pm
+++ b/perl/Thingy.pm
@@ -65,15 +65,13 @@ sub send
        }
 
        # generate the line which may (or not) be cached
-       my @out;
-       if (my $ref = $thing->{class}) {
-               push @out, ref $ref ? @$ref : $ref;
-       } else {
+       my $ref;
+       unless ($ref = $thing->{class}) {
                no strict 'refs';
                my $sub = "gen_$class";
-               push @out, $thing->$sub($dxchan) if $thing->can($sub);
+               $ref = $thing->$sub($dxchan) if $thing->can($sub);
        }
-       $dxchan->send(@out) if @out;
+       $dxchan->send(ref $ref ? @$ref : $ref) if $ref;
 }
 
 # broadcast to all except @_

diff --git a/perl/Thingy/Hello.pm b/perl/Thingy/Hello.pm
index 9c1e30804fedac8caee24e48a27b03d9fb854e57..c098ca944edfb97825184cf8ab6543107826dbf5 100644 (file)
--- a/perl/Thingy/Hello.pm
+++ b/perl/Thingy/Hello.pm
@@ -49,7 +49,9 @@ sub handle
        my $dxchan = shift;
        
        # verify authenticity
-       if ($dxchan->call eq $thing->{origin}) {
+       if ($dxchan->{call} eq $thing->{origin}) {
+
+               # for directly connected calls
                if ($verify_on_login) {
                        my $pp = $dxchan->user->passphrase;
                        unless ($pp) {
@@ -71,7 +73,30 @@ sub handle
                                $thing->send($dxchan);
                        }
                }
+       } else {
+               
+               # for otherwise connected calls, that come in relayed from other nodes
+               # note that we cannot do any connections at this point
+               my $nref = Route::Node::get($thing->{origin});
+               unless ($nref) {
+                       my $v = $thing->{user} ? undef : $thing->{v};
+                       $nref = Route::Node->new($thing->{origin}, $v, 1);
+               }
+               if (my $user = $thing->{user}) {
+                       my $ur = Route::get($user);
+                       unless ($ur) {
+                               my $uref = DXUser->get_current($user);
+                               if ($uref->is_node || $uref->is_aranea) {
+                                       $nref->add($user, $thing->{v}, 1);
+                               } else {
+                                       $nref->add_user($user, 1);
+                               }
+                       }
+               }
        }
+       RouteDB::update($thing->{origin}, $dxchan->{call}, $thing->{hopsaway});
+       RouteDB::update($thing->{user}, $dxchan->{call}, $thing->{hopsaway}) if $thing->{user};
+               
        $thing->broadcast($dxchan);
 }
 

diff --git a/perl/Thingy/Rt.pm b/perl/Thingy/Rt.pm
index 7f4072358f90cf45baa64ef47f7abd7174df13ca..f7c503acfa019af5335fb333bb62e12cc9ef4a54 100644 (file)
--- a/perl/Thingy/Rt.pm
+++ b/perl/Thingy/Rt.pm
@@ -28,8 +28,10 @@ sub gen_Aranea
        my $thing = shift;
        unless ($thing->{Aranea}) {
                my @items;
-               push @items, 't', $thing->{t} if $thing->{t};
-               push @items, 'd', $thing->{d} if $thing->{d};
+               push @items, 's', $thing->{'s'} if $thing->{'s'};
+               push @items, 'n', $thing->{n} if $thing->{n};
+               push @items, 'v', $thing->{v} if $thing->{v};
+               push @items, 'u', $thing->{u} if $thing->{u};
                $thing->{Aranea} = Aranea::genmsg($thing, 'RT', @items) if @items;
        }
        return $thing->{Aranea};
@@ -46,6 +48,33 @@ sub gen_DXProt
 {
        my $thing = shift;
        my $dxchan = shift;
+       my $s = $thing->{'s'};
+       if ($s eq 'au') {
+               my $n = $thing->{n} || $thing->{user};
+               my @out;
+               if ($n && (my $u = $thing->{u})) {
+                       my $s = '';
+                       for (split /:/, $u) {
+                               my ($here, $call) = unpack "A1 A*", $_;
+                               my $str = sprintf "^%s * %d", $call, $here;
+                               if (length($s) + length($str) > $DXProt::sentencelth) {
+                                       push @out, "PC16^$n" . $s . sprintf "^%s^", DXProt::get_hops(16);
+                                       $s = '';
+                               }
+                               $s .= $str;
+                       }
+                       push @out, "PC16^$n" . $s . sprintf "^%s^", DXProt::get_hops(16);
+                       $thing->{DXProt} = @out > 1 ? \@out : $out[0];
+               }
+       } elsif ($s eq 'du') {
+               my $n = $thing->{n} || $thing->{user};
+               my $hops = DXProt::get_hops(17);
+               if ($n && (my $u = $thing->{u})) {
+                       $thing->{DXProt} = "PC17^$u^$n^$hops^"; 
+               }
+       } elsif ($s eq 'an') {
+       } elsif ($s eq 'dn') {
+       }
        return $thing->{DXProt};
 }
 
@@ -85,74 +114,58 @@ sub handle
        }
 }
 
-sub handle_eau
+# these contain users and either a node (for externals) or the from address 
+sub handle_au
 {
        my $thing = shift;
        my $dxchan = shift;
 
-       if (my $d = $thing->{d}) {
-               my $nref;
-               for (split /:/, $d) {
-                       my ($type, $here, $call) = unpack "A1 A1 A*", $_;
-                       if ($type eq 'U') {
-                               unless ($nref) {
-                                       dbg("Thingy::Rt::ea need a node before $call");
-                                       return;
-                               }
+       my $node = $thing->{n} || $thing->{user};
+       my $nref = Route::Node::get($node);
+
+       if ($nref) {
+               if (my $u = $thing->{u}) {
+                       for (split /:/, $u) {
+                               my ($here, $call) = unpack "A1 A*", $_;
                                add_user($nref, $call, $here);
                                my $h = $dxchan->{call} eq $nref->{call} ? 3 : ($thing->{hops} || 99);
                                RouteDB::update($call, $dxchan->{call}, $h);
-                       } elsif ($type eq 'N') {
-                               $nref = Route::Node::get($call);
-                               unless ($nref) {
-                                       dbg("Thingy::Rt::ea need a definition for $call");
-                                       return;
-                               }
-                               my $h = $dxchan->{call} eq $nref->{call} ? 2 : ($thing->{hops} || 99);
-                               RouteDB::update($nref->{call}, $dxchan->{call}, $h);
-                       } else {
-                               dbg("Thingy::Rt::ea invalid type $type");
-                               return;
                        }
                }
+       } else {
+               dbg("Thingy::Rt::au: $node not found") if isdbg('chanerr');
+               return;
        }
        return $thing;
 }
 
-sub handle_edu
+sub handle_du
 {
        my $thing = shift;
        my $dxchan = shift;
 
-       if (my $d = $thing->{d}) {
-               my $nref;
-               for (split /:/, $d) {
-                       my ($type, $here, $call) = unpack "A1 A1 A*", $_;
-                       if ($type eq 'U') {
-                               unless ($nref) {
-                                       dbg("Thingy::Rt::edu need a node before $call");
-                                       return;
-                               }
+       my $node = $thing->{n} || $thing->{user};
+       my $nref = Route::Node::get($node);
+
+       if ($nref) {
+               if (my $u = $thing->{u}) {
+                       for (split /:/, $u) {
+                               my ($here, $call) = unpack "A1 A*", $_;
                                my $uref = Route::User::get($call);
                                unless ($uref) {
-                                       dbg("Thingy::Rt::edu $call not a user") if isdbg('chanerr');
+                                       dbg("Thingy::Rt::du $call not a user") if isdbg('chanerr');
                                        next;
                                }
                                $nref->del_user($uref);
                                RouteDB::delete($call, $dxchan->{call});
-                       } elsif ($type eq 'N') {
-                               $nref = Route::Node::get($call);
-                               unless ($nref) {
-                                       dbg("Thingy::Rt::ed need a definition for $call");
-                                       return;
-                               }
-                               RouteDB::update($nref->{call}, $dxchan->{call}, $dxchan->{call} eq $nref->{call} ? 2 : ($thing->{hops} || 99));
-                       } else {
-                               dbg("Thingy::Rt::ed invalid type $type");
-                               return;
                        }
+                       RouteDB::update($nref->{call}, $dxchan->{call}, $dxchan->{call} eq $nref->{call} ? 2 : ($thing->{hops} || 99));
                }
+       } else {
+               dbg("Thingy::Rt::du: $node not found") if isdbg('chanerr');
+               return;
        }
+
        return $thing;
 }