]> dxcluster.net Git - spider.git/blob - perl/UDPMsg.pm
fixed rounding errors on two digit decimal places entries for frequency
[spider.git] / 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