perl/Thingy/Ping.pm

   1 #
   2 # Ping Thingy handling
   3 #
   4 # $Id$
   5 #
   6 # Copyright (c) 2005 Dirk Koopman G1TLH
   7 #
   8
   9 use strict;
  10
  11 package Thingy::Ping;
  12
  13 use vars qw($VERSION $BRANCH);
  14
  15 main::mkver($VERSION = q$Revision$);
  16
  17 use DXChannel;
  18 use DXDebug;
  19 use DXUtil;
  20 use Thingy;
  21 use Spot;
  22 use Time::HiRes qw(gettimeofday tv_interval);
  23
  24
  25 use vars qw(@ISA %ping);
  26 @ISA = qw(Thingy);
  27
  28 my $id;
  29
  30 sub gen_Aranea
  31 {
  32         my $thing = shift;
  33         unless ($thing->{Aranea}) {
  34                 $thing->{Aranea} = Aranea::genmsg($thing, qw(id));
  35         }
  36         return $thing->{Aranea};
  37 }
  38
  39 sub from_Aranea
  40 {
  41         my $thing = shift;
  42         return unless $thing;
  43         return $thing;
  44 }
  45
  46 sub gen_DXProt
  47 {
  48         my $thing = shift;
  49         my $dxchan = shift;
  50         return $thing->{DXProt};
  51 }
  52
  53 sub gen_DXCommandmode
  54 {
  55         my $thing = shift;
  56         my $dxchan = shift;
  57         my $buf;
  58
  59         return $buf;
  60 }
  61
  62 sub from_DXProt
  63 {
  64         my $thing = ref $_[0] ? shift : $_[0]->SUPER::new();
  65
  66         while (@_) {
  67                 my $k = shift;
  68                 $thing->{$k} = shift;
  69         }
  70         return $thing;
  71 }
  72
  73 sub handle
  74 {
  75         my $thing = shift;
  76         my $dxchan = shift;
  77
  78         # is it for us?
  79         if ($thing->{group} eq $main::mycall) {
  80                 if ($thing->{out} == 1) {
  81                         my $repthing = $thing->new_reply;
  82                         $repthing->{out} = 0;
  83                         $repthing->{id} = $thing->{id};
  84                         $repthing->send($dxchan) if $repthing;
  85                 } else {
  86
  87                         # it's a reply, look in the ping list for this one
  88                         my $ref = $ping{$thing->{id}} || $thing->find;
  89                         if ($ref) {
  90                                 my $t = tv_interval($thing->{t}, [ gettimeofday ]);
  91                                 if (my $dxc = DXChannel::get($thing->{user} || $thing->{origin})) {
  92
  93                                         my $tochan = DXChannel::get($thing->{touser} || $thing->{group});
  94
  95                                         if ($dxc->is_user) {
  96                                                 my $s = sprintf "%.2f", $t;
  97                                                 my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t;
  98                                                 $dxc->send($dxc->msg('pingi', ($thing->{touser} || $thing->{group}), $s, $ave))
  99                                         } elsif ($dxc->is_node) {
 100                                                 if ($tochan ) {
 101                                                         my $nopings = $tochan->user->nopings || $DXProt::obscount;
 102                                                         push @{$tochan->{pingtime}}, $t;
 103                                                         shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6;
 104
 105                                                         # cope with a missed ping, this means you must set the pingint large enough
 106                                                         if ($t > $tochan->{pingint}  && $t < 2 * $tochan->{pingint} ) {
 107                                                                 $t -= $tochan->{pingint};
 108                                                         }
 109
 110                                                         # calc smoothed RTT a la TCP
 111                                                         if (@{$tochan->{pingtime}} == 1) {
 112                                                                 $tochan->{pingave} = $t;
 113                                                         } else {
 114                                                                 $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6);
 115                                                         }
 116                                                         $tochan->{nopings} = $nopings; # pump up the timer
 117                                                 }
 118                                         }
 119                                 }
 120                         }
 121                 }
 122         } else {
 123                 $thing->broadcast($dxchan);
 124         }
 125 }
 126
 127 # this just creates a ping for onward transmission
 128 # remember it if you want to ping someone from here
 129 sub new_ping
 130 {
 131         my $pkg = shift;
 132         my $thing = $pkg->SUPER::new(@_);
 133 }
 134
 135 # do this for pings we generate ourselves
 136 sub remember
 137 {
 138         my $thing = shift;
 139         $thing->{t} = [ gettimeofday ];
 140         $thing->{out} = 1;
 141         $thing->{id} = ++$id;
 142         my $u = DXUser->get_current($thing->{to});
 143         if ($u) {
 144                 $u->lastping(($thing->{user} || $thing->{group}), $main::systime);
 145                 $u->put;
 146         }
 147         $ping{$id} = $thing;
 148 }
 149
 150 # remove any pings outstanding that we have remembered for this
 151 # callsign, return the number of forgotten pings
 152 sub forget
 153 {
 154         my $call = shift;
 155         my $count = 0;
 156         my @out;
 157         foreach my $thing (values %ping) {
 158                 if (($thing->{user} || $thing->{group}) eq $call) {
 159                         $count++;
 160                         delete $ping{$thing->{id}};
 161                 }
 162         }
 163         return $count;
 164 }
 165
 166 sub find
 167 {
 168         my $call = shift;
 169         foreach my $thing (values %ping) {
 170                 if (($thing->{user} || $thing->{origin}) eq $call) {
 171                         return $thing;
 172                 }
 173         }
 174         return undef;
 175 }
 176 1;