perl/UDPMsg.pm

   1 #
   2 # This class is the internal subclass that deals with UDP Engine connections
   3 #
   4 # The complication here is that there may be just a multicast address with
   5 # one shared connection or there may be several 'connections' which have no
   6 # real defined start or end.
   7 #
   8 # This class will morph into (and is the test bed for) Multicasts
   9 #
  10 #
  11 #
  12 # Copyright (c) 2002 - Dirk Koopman G1TLH
  13 #
  14
  15 package UDPMsg;
  16
  17 use strict;
  18 use IO::Socket;
  19 use Msg;
  20 use DXDebug;
  21
  22 use vars qw(@ISA @sock @outqueue $send_offset $inmsg $rproc $noports
  23                         %circuit $total_in $total_out $enable);
  24
  25 @ISA = qw(Msg ExtMsg);
  26 @sock = ();
  27 @outqueue = ();
  28 $send_offset = 0;
  29 $inmsg = '';
  30 $rproc = undef;
  31 $noports = 0;
  32 %circuit = ();
  33 $total_in = $total_out = 0;
  34
  35 sub init
  36 {
  37         return unless $enable;
  38         return unless @main::listen;
  39
  40         $rproc = shift;
  41
  42         foreach my $sock (@main::listen) {
  43                 dbg("UDP initialising and connecting to $_->[0]/$_->[1] ...");
  44                 $sock = IO::Socket::INET->new(LocalAddr => $_->[0], LocalPort => $_->[1], Proto=>'udp', Type => SOCK_DGRAM);
  45
  46                 unless ($sock) {
  47                         dbg("Cannot connect to UDP Engine at $_->[0]/$_->[1] $!");
  48                         return;
  49                 }
  50                 Msg::blocking($sock, 0);
  51                 Msg::set_event_handler($sock, read=>\&_rcv, error=>\&_error);
  52         }
  53         finish();
  54 }
  55
  56 my $finishing = 0;
  57
  58 sub finish
  59 {
  60         return if $finishing;
  61         foreach my $sock (@sock) {
  62                 $finishing = 1;
  63                 dbg("UDP ending...");
  64                 for (values %circuit) {
  65                         &{$_->{eproc}}() if $_->{eproc};
  66                         $_->disconnect;
  67                 }
  68                 Msg::set_event_handler($sock, read=>undef, write=>undef, error=>undef);
  69                 $sock->close;
  70         }
  71 }
  72
  73 sub active
  74 {
  75         return scalar @sock;
  76 }
  77
  78 sub _sendf
  79 {
  80         my $sort = shift || confess "need a valid UDP command letter";
  81         my $from = shift || '';
  82         my $to   = shift || '';
  83         my $port = shift || 0;
  84         my $pid  = shift || 0;
  85         my $data = shift || '';
  86         my $len  = 0;
  87
  88         $len = length $data;
  89
  90         # do it
  91
  92         # Msg::set_event_handler($sock, write=>\&_send);
  93 }
  94
  95 sub _send
  96 {
  97     return unless @sock;
  98
  99     # If $flush is set, set the socket to blocking, and send all
 100     # messages in the queue - return only if there's an error
 101     # If $flush is 0 (deferred mode) make the socket non-blocking, and
 102     # return to the event loop only after every message, or if it
 103     # is likely to block in the middle of a message.
 104
 105     my $offset = $send_offset;
 106
 107     while (@outqueue) {
 108         my $msg            = $outqueue[0];
 109                 my $mlth           = length($msg);
 110         my $bytes_to_write = $mlth - $offset;
 111         my $bytes_written  = 0;
 112                 confess("Negative Length! msg: '$msg' lth: $mlth offset: $offset") if $bytes_to_write < 0;
 113         while ($bytes_to_write > 0) {
 114 #            $bytes_written = syswrite ($sock, $msg,
 115 #                                       $bytes_to_write, $offset);
 116             if (!defined($bytes_written)) {
 117                 if (Msg::_err_will_block($!)) {
 118                     # Should happen only in deferred mode. Record how
 119                     # much we have already sent.
 120                     $send_offset = $offset;
 121                     # Event handler should already be set, so we will
 122                     # be called back eventually, and will resume sending
 123                     return 1;
 124                 } else {    # Uh, oh
 125                                         _error();
 126                     return 0; # fail. Message remains in queue ..
 127                 }
 128             }
 129                         if (isdbg('raw')) {
 130                                 dbgdump('raw', "UDP send $bytes_written: ", $msg);
 131                         }
 132             $total_out      += $bytes_written;
 133             $offset         += $bytes_written;
 134             $bytes_to_write -= $bytes_written;
 135         }
 136         $send_offset = $offset = 0;
 137         shift @outqueue;
 138         last;  # Go back to select and wait
 139                        # for it to fire again.
 140     }
 141
 142     # Call me back if queue has not been drained.
 143     if (@outqueue) {
 144 #        Msg::set_event_handler ($sock, write => \&_send);
 145     } else {
 146 #        Msg::set_event_handler ($sock, write => undef);
 147     }
 148     1;  # Success
 149 }
 150
 151 sub _rcv {                     # Complement to _send
 152     return unless @sock;
 153
 154     my ($msg, $offset, $bytes_read);
 155
 156 #       $bytes_read = sysread ($sock, $msg, 1024, 0);
 157         if (defined ($bytes_read)) {
 158                 if ($bytes_read > 0) {
 159             $total_in += $bytes_read;
 160                         $inmsg .= $msg;
 161                         if (isdbg('raw')) {
 162                                 dbgdump('raw', "UDP read $bytes_read: ", $msg);
 163                         }
 164                 }
 165         } else {
 166                 if (Msg::_err_will_block($!)) {
 167                         return;
 168                 } else {
 169                         $bytes_read = 0;
 170                 }
 171     }
 172
 173 FINISH:
 174     if (defined $bytes_read && $bytes_read == 0) {
 175                 finish();
 176     } else {
 177                 _decode() if length $inmsg >= 36;
 178         }
 179 }
 180
 181 sub _error
 182 {
 183 #       dbg("error on UDP connection $addr/$port $!");
 184 #       Msg::set_event_handler($sock, read=>undef, write=>undef, error=>undef);
 185 #       $sock = undef;
 186         for (%circuit) {
 187                 &{$_->{eproc}}() if $_->{eproc};
 188                 $_->disconnect;
 189         }
 190 }
 191
 192 sub _decode
 193 {
 194         return unless @sock;
 195
 196 }
 197
 198 sub _find
 199 {
 200         my $call = shift;
 201         return $circuit{$call};
 202 }
 203
 204 sub peerhost
 205 {
 206         my $conn = shift;
 207         $conn->{peerhost} ||= 'ax25';
 208         return $conn->{peerhost};
 209 }
 210
 211 sub connect
 212 {
 213         my ($conn, $line) = @_;
 214
 215         my ($port, $call) = split /\s+/, $line;
 216         $conn->{udppid} = ord "\xF0";
 217         $conn->{udpport} = $port - 1;
 218         $conn->{lineend} = "\cM";
 219         $conn->{incoming} = 0;
 220         $conn->{csort} = 'ax25';
 221         $conn->{udpcall} = uc $call;
 222         $circuit{$conn->{udpcall}} = $conn;
 223         $conn->{state} = 'WC';
 224         return 1;
 225 }
 226
 227 sub in_disconnect
 228 {
 229         my $conn = shift;
 230         delete $circuit{$conn->{udpcall}};
 231         $conn->SUPER::disconnect;
 232 }
 233
 234 sub disconnect
 235 {
 236         my $conn = shift;
 237         delete $circuit{$conn->{udpcall}};
 238         if ($conn->{incoming}) {
 239         }
 240         $conn->SUPER::disconnect;
 241 }
 242
 243 sub enqueue
 244 {
 245         my ($conn, $msg) = @_;
 246         if ($msg =~ /^D/) {
 247                 $msg =~ s/^[-\w]+\|//;
 248                 my $len = length($msg) + 1;
 249                 dbg("UDP Data Out port: $conn->{udpport} pid: $conn->{udppid} '$main::mycall'->'$conn->{udpcall}' length: $len \"$msg\"") if isdbg('udp');
 250         }
 251 }
 252
 253 sub process
 254 {
 255         return unless @sock;
 256 }
 257
 258 1;
 259