X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FMsg.pm;h=ceace3ca774c62603b22f2ab8577f8907c4af5f4;hb=0bca43685143e42a93bdcdaa9e34e115b22552e9;hp=e13be8f31d90f00329ff08a628c66fa79ac5cffb;hpb=b953903f1c33ae35ce24bad344e46ab17b0b5d95;p=spider.git diff --git a/perl/Msg.pm b/perl/Msg.pm index e13be8f3..ceace3ca 100644 --- a/perl/Msg.pm +++ b/perl/Msg.pm @@ -5,25 +5,20 @@ # # I have modified it to suit my devious purposes (Dirk Koopman G1TLH) # -# $Id$ +# # package Msg; use strict; -use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; +use DXUtil; use IO::Select; -use IO::Socket; use DXDebug; use Timer; -use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum $total_in $total_out); +use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum $total_in $total_out $io_socket); %rd_callbacks = (); %wt_callbacks = (); @@ -41,10 +36,25 @@ BEGIN { local $^W; require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL)) }; + + eval { + local $^W; + require IO::Socket::INET6; + }; + + if ($@) { + dbg($@); + require IO::Socket; + $io_socket = 'IO::Socket::INET'; + } else { + $io_socket = 'IO::Socket::INET6'; + } + $io_socket->import; + if ($@ || $main::is_win) { - $blocking_supported = IO::Socket->can('blocking') ? 2 : 0; + $blocking_supported = $io_socket->can('blocking') ? 2 : 0; } else { - $blocking_supported = IO::Socket->can('blocking') ? 2 : 1; + $blocking_supported = $io_socket->can('blocking') ? 2 : 1; } @@ -70,12 +80,12 @@ BEGIN { # defines EINPROGRESS as 10035. We provide it here because some # Win32 users report POSIX::EINPROGRESS is not vendor-supported. if ($^O eq 'MSWin32') { - eval '*EINPROGRESS = sub { 10036 };'; - eval '*EWOULDBLOCK = *EAGAIN = sub { 10035 };'; - eval '*F_GETFL = sub { 0 };'; - eval '*F_SETFL = sub { 0 };'; - eval '*IPPROTO_TCP = sub { 6 };'; - eval '*TCP_NODELAY = sub { 1 };'; + eval '*EINPROGRESS = sub { 10036 };' unless defined *EINPROGRESS; + eval '*EWOULDBLOCK = *EAGAIN = sub { 10035 };' unless defined *EWOULDBLOCK; + eval '*F_GETFL = sub { 0 };' unless defined *F_GETFL; + eval '*F_SETFL = sub { 0 };' unless defined *F_SETFL; + eval 'sub IPPROTO_TCP { 6 };'; + eval 'sub TCP_NODELAY { 1 };'; $blocking_supported = 0; # it appears that this DOESN'T work :-( } } @@ -113,7 +123,7 @@ sub new $noconns++; - dbg("Connection created ($noconns)") if isdbg('connll'); + dbg("$class Connection $conn->{cnum} created (total $noconns)") if isdbg('connll'); return bless $conn, $class; } @@ -160,11 +170,11 @@ sub conns if (ref $pkg) { $call = $pkg->{call} unless $call; return undef unless $call; - dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call}; + dbg((ref $pkg) . " changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call}; delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call; $pkg->{call} = $call; $ref = $conns{$call} = $pkg; - dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll'); + dbg((ref $pkg) . " Connection $pkg->{cnum} $call stored") if isdbg('connll'); } else { $ref = $conns{$call}; } @@ -183,6 +193,22 @@ sub pid_gone } } +sub ax25 +{ + my $conn = shift; + return $conn->{csort} eq 'ax25'; +} + +sub peerhost +{ + my $conn = shift; + $conn->{peerhost} ||= 'ax25' if $conn->ax25; + $conn->{peerhost} ||= $conn->{sock}->peerhost if $conn->{sock} && $conn->{sock}->isa('IO::Socket::INET'); + $conn->{peerhost} ||= 'UNKNOWN'; + $conn->{peerhost} =~ s/^::ffff://; + return $conn->{peerhost}; +} + #----------------------------------------------------------------- # Send side routines sub connect { @@ -196,26 +222,36 @@ sub connect { $conn->{peerhost} = $to_host; $conn->{peerport} = $to_port; $conn->{sort} = 'Outgoing'; - - # Create a new internet socket - my $sock = IO::Socket::INET->new(); - return undef unless $sock; - - my $proto = getprotobyname('tcp'); - $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef; - - blocking($sock, 0); - $conn->{blocking} = 0; - # does the host resolve? - my $ip = gethostbyname($to_host); - return undef unless $ip; + dbg((ref $conn) . " connecting $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); - my $r = connect($sock, pack_sockaddr_in($to_port, $ip)); - return undef unless $r || _err_will_block($!); + my $sock; + if ($blocking_supported) { + $sock = $io_socket->new(PeerAddr => $to_host, PeerPort => $to_port, Proto => 'tcp', Blocking =>0) or return undef; + } else { + # Create a new internet socket + $sock = $io_socket->new(); + return undef unless $sock; + + my $proto = getprotobyname('tcp'); + $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef; + + blocking($sock, 0); + $conn->{blocking} = 0; + + # does the host resolve? + my $ip = gethostbyname($to_host); + return undef unless $ip; + + my $r = connect($sock, pack_sockaddr_in($to_port, $ip)); + return undef unless $r || _err_will_block($!); + } $conn->{sock} = $sock; - +# $conn->{peerhost} = $sock->peerhost; # for consistency + + dbg((ref $conn) . " connected $conn->{cnum} to $to_host:$to_port") if isdbg('connll'); + if ($conn->{rproc}) { my $callback = sub {$conn->_rcv}; set_event_handler ($sock, read => $callback); @@ -229,7 +265,7 @@ sub start_program my $pid; local $^F = 10000; # make sure it ain't closed on exec - my ($a, $b) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC); + my ($a, $b) = $io_socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC); if ($a && $b) { $a->autoflush(1); $b->autoflush(1); @@ -289,7 +325,7 @@ sub disconnect delete $conns{$call} if $ref && $ref == $conn; } $call ||= 'unallocated'; - dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll'); + dbg((ref $conn) . " Connection $conn->{cnum} $call disconnected") if isdbg('connll'); # get rid of any references for (keys %$conn) { @@ -300,7 +336,7 @@ sub disconnect if (defined($sock)) { set_event_handler ($sock, read => undef, write => undef, error => undef); - shutdown($sock, 3); + shutdown($sock, 2); close($sock); } @@ -428,9 +464,9 @@ sub new_server { my ($pkg, $my_host, $my_port, $login_proc) = @_; my $self = $pkg->new($login_proc); - $self->{sock} = IO::Socket::INET->new ( - LocalAddr => "$my_host:$my_port", -# LocalPort => $my_port, + $self->{sock} = $io_socket->new ( + LocalAddr => $my_host, + LocalPort => $my_port, Listen => SOMAXCONN, Proto => 'tcp', Reuse => 1); @@ -469,15 +505,17 @@ sub nolinger sub dequeue { my $conn = shift; - - if ($conn->{msg} =~ /\n/) { - my @lines = split /\r?\n/, $conn->{msg}; - if ($conn->{msg} =~ /\n$/) { + return if $conn->{disconnecting}; + + if ($conn->{msg} =~ /\cJ/) { + my @lines = split /\cM?\cJ/, $conn->{msg}; + if ($conn->{msg} =~ /\cM?\cJ$/) { delete $conn->{msg}; } else { $conn->{msg} = pop @lines; } for (@lines) { + last if $conn->{disconnecting}; &{$conn->{rproc}}($conn, defined $_ ? $_ : ''); } } @@ -491,10 +529,10 @@ sub _rcv { # Complement to _send return unless defined($sock); my @lines; - if ($conn->{blocking}) { - blocking($sock, 0); - $conn->{blocking} = 0; - } +# if ($conn->{blocking}) { +# blocking($sock, 0); +# $conn->{blocking} = 0; +# } $bytes_read = sysread ($sock, $msg, 1024, 0); if (defined ($bytes_read)) { if ($bytes_read > 0) { @@ -686,8 +724,8 @@ sub DESTROY my $call = $conn->{call} || 'unallocated'; my $host = $conn->{peerhost} || ''; my $port = $conn->{peerport} || ''; - dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll'); $noconns--; + dbg((ref $conn) . " Connection $conn->{cnum} $call [$host $port] being destroyed (total $noconns)") if isdbg('connll'); } 1;