perl/QXProt.pm

   1 #
   2 # This module impliments the new protocal mode for a dx cluster
   3 #
   4 # Copyright (c) 2001 Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package QXProt;
  10
  11 @ISA = qw(DXChannel DXProt);
  12
  13 use DXUtil;
  14 use DXChannel;
  15 use DXUser;
  16 use DXM;
  17 use DXLog;
  18 use Spot;
  19 use DXDebug;
  20 use Filter;
  21 use DXDb;
  22 use AnnTalk;
  23 use Geomag;
  24 use WCY;
  25 use Time::HiRes qw(gettimeofday tv_interval);
  26 use BadWords;
  27 use DXHash;
  28 use Route;
  29 use Route::Node;
  30 use Script;
  31 use DXProt;
  32 use Verify;
  33 use Thingy;
  34
  35 use strict;
  36
  37 use vars qw($VERSION $BRANCH);
  38 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  39 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/,(0,0));
  40 $main::build += $VERSION;
  41 $main::branch += $BRANCH;
  42
  43 sub init
  44 {
  45         my $user = DXUser->get($main::mycall);
  46         $DXProt::myprot_version += ($main::version - 1 + 0.52)*100;
  47         $main::me = QXProt->new($main::mycall, 0, $user);
  48         $main::me->{here} = 1;
  49         $main::me->{state} = "indifferent";
  50         $main::me->{sort} = 'S';    # S for spider
  51         $main::me->{priv} = 9;
  52         $main::me->{metric} = 0;
  53         $main::me->{pingave} = 0;
  54         $main::me->{registered} = 1;
  55         $main::me->{version} = $main::version;
  56         $main::me->{build} = $main::build;
  57
  58 #       $Route::Node::me->adddxchan($main::me);
  59 }
  60
  61 sub start
  62 {
  63         my $self = shift;
  64         $self->SUPER::start(@_);
  65 }
  66
  67 sub sendinit
  68 {
  69         my $self = shift;
  70
  71         $self->node_update;
  72 }
  73
  74 sub normal
  75 {
  76         if ($_[1] =~ /^PC\d\d\^/) {
  77                 DXProt::normal(@_);
  78                 return;
  79         }
  80
  81         # Although this is called the 'QX' Protocol, this is historical
  82         # I am simply using this module to save a bit of time.
  83         #
  84
  85         return unless my ($tonode, $fromnode, $class, $msgid, $hoptime, $rest) =
  86                 $_[1] =~ /^([^;]+;){5,5}\|(.*)$/;
  87
  88         my $self = shift;
  89
  90         # add this interface's hop time to the one passed
  91         my $newhoptime = $self->{pingave} >= 999 ?
  92                 $hoptime+10 : ($hoptime + int($self->{pingave}*10));
  93
  94         # split up the 'rest' which are 'a=b' pairs separated by commas
  95     # and create a new thingy based on the class passed (if known)
  96         # ignore pairs with a leading '_'.
  97
  98         my @par;
  99
 100         for (split /;/, $rest) {
 101                 next if /^_/;
 102                 next unless /^\w+=/;
 103                 s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
 104                 push @par, split(/=/,$_,2);
 105         }
 106
 107         no strict 'refs';
 108         my $pkg = 'Thingy::' . lcfirst $class;
 109         my $t = $pkg->new(_tonode=>$tonode, _fromnode=>$fromnode,
 110                                           _msgid=>$msgid, _hoptime=>$newhoptime,
 111                                           _newdata=>$rest, _inon=>$self->{call},
 112                                           @par) if defined *$pkg && $pkg->can('new');
 113         $t->queue if $t;
 114         return;
 115 }
 116
 117 my $last_node_update = 0;
 118 my $node_update_interval = 60*60;
 119
 120 sub process
 121 {
 122         if ($main::systime >= $last_node_update+$node_update_interval) {
 123                 $last_node_update = $main::systime;
 124         }
 125 }
 126
 127 sub disconnect
 128 {
 129         my $self = shift;
 130         my $t = Thingy::Route->new_node_disconnect($main::mycall, $main::mycall, $self->{call});
 131         $t->queue;
 132         $self->DXProt::disconnect(@_);
 133 }
 134
 135 my $msgid = 1;
 136
 137 sub nextmsgid
 138 {
 139         my $r = $msgid;
 140         $msgid = 1 if ++$msgid > 99999;
 141         return $r;
 142 }
 143
 144 sub node_update
 145 {
 146         my $t = Thingy::Route->new_node_update();
 147         $t->queue if $t;
 148 }
 149
 150 sub t_send
 151 {
 152         my $self = shift;
 153         my $t = shift;
 154         confess('$t is not a Thingy') unless $t->isa('Thingy');
 155
 156         # manufacture the protocol line if required
 157         unless (exists $t->{_newprot}) {
 158                 my ($class) = ref $self =~ /::(\w+)$/;
 159                 unless (exists $t->{_rest}) {
 160                         $t->{_rest} = "";
 161                         while (my ($k,$v) = each %$t) {
 162                                 next if $k =~ /^_/;
 163                                 if (ref $v && @$v) {
 164                                         my $val = "";
 165                                         for(@$v) {
 166                                                 my $vv = $_;
 167                                                 $vv =~ s/([\%;=,\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 168                                                 $val .= $vv . ',';
 169                                         }
 170                                         if (length $val) {
 171                                                 chop $val;
 172                                                 $t->{_rest} .= "$k=$val;";
 173                                         }
 174                                 } elsif (length $v) {
 175                                         $v =~ s/([\%;=\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 176                                         $t->{_rest} .= "$k=$v;";
 177                                 }
 178                         }
 179                         chop $t->{_rest} if length $t->{_rest};
 180                 }
 181
 182                 $t->{_hoptime} ||= 1;
 183                 $t->{_msgid} = nextmsgid() unless $t->{_msgid};
 184                 $t->{_newprot} = join(';', $t->{_tonode}, $t->{_fromnode}, uc $class,
 185                                                           $t->{_msgid}, $t->{_hoptime}) . '|' . $t->{_rest};
 186         }
 187         $self->SUPER::send($t->{_newprot});
 188 }
 189
 190 1;