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