OK.
@ISA = qw(Exporter);
use Msg;
+use DXUtil;
%connects = undef;
my ($pkg, $call, $conn, $user) = @_;
my $self = {};
- die "trying to create a duplicate Connect for call $call\n" if $connects{$call};
+ die "trying to create a duplicate channel for $call" if $connects{$call};
$self->{call} = $call;
$self->{conn} = $conn;
$self->{user} = $user;
my $line;
foreach $line (@_) {
- print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ my $t = atime;
+ chomp $line;
+ print main::DEBUG "$t > $sort $call $line\n" if defined DEBUG;
print "> $sort $call $line\n";
$conn->send_now("$sort$call|$line");
}
my $line;
foreach $line (@_) {
- print DEBUG "$t > $sort $call $line\n" if defined DEBUG;
+ my $t = atime;
+ chomp $line;
+ print main::DEBUG "$t > $sort $call $line\n" if defined DEBUG;
print "> $sort $call $line\n";
$conn->send_later("$sort$call|$line");
}
#
# DX cluster message strings for output
#
+# Each message string will substitute $_[x] positionally. What this means is
+# that if you don't like the order in which fields in each message is output then
+# you can change it. Also you can include various globally accessible variables
+# in the string if you want.
+#
+# Largely because I don't particularly want to have to change all these messages
+# in every upgrade I shall attempt to add new field to the END of the list :-)
+#
# Copyright (c) 1998 - Dirk Koopman G1TLH
#
# $Id$
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(m);
+@EXPORT = qw(msg);
%msgs = (
- l1 => "Sorry $a[0], you are already logged on on another channel",
- l2 => "Hello $a[0], this is $a[1] located in $a[2]",
+ l1 => 'Sorry $_[0], you are already logged on on another channel',
+ l2 => 'Hello $_[0], this is $main::mycall located in $main::myqth',
);
-sub m
+sub msg
{
my $self = shift;
- local @a = @_;
- my $s = $msg{$self};
+ my $s = $msgs{$self};
return "unknown message '$self'" if !defined $s;
- return eval $s;
+
+ return eval '"'. $s . '"';
}
{
my ($pkg, $fn) = @_;
- die "need a filename in User\n" if !$fn;
- $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)\n";
+ die "need a filename in User" if !$fn;
+ $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)";
$filename = $fn;
}
sub get
{
- my $call = shift;
+ my ($pkg, $call) = @_;
return $u{$call};
}
cease(1);
}
if (defined $msg) {
- my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)|(.*)$/;
+ my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
if ($sort eq 'D') {
$nl = "" if $mode == 0;
- $line =~ s/\n/\r/o if $mode == 1;
- print $line, $nl;
+ $line =~ s/\n/\r/og if $mode == 1;
+ print $line;
} elsif ($sort eq 'M') {
$mode = $line; # set new mode from cluster
} elsif ($sort eq 'Z') { # end, disconnect, go, away .....
# print "sys: $r $buf";
if ($r > 0) {
if ($mode) {
- $buf =~ s/\r/\n/o if $mode == 1;
+ $buf =~ s/\r/\n/og if $mode == 1;
$dangle = !($buf =~ /\n$/);
@lines = split /\n/, $buf;
if ($dangle) { # pull off any dangly bits
$SIG{'INT'} = \&sig_term;
$SIG{'TERM'} = \&sig_term;
-#$SIG{'HUP'} = \&sig_term;
+$SIG{'HUP'} = \&sig_term;
$conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
$conn->send_now("A$call|start");
{
my $dxchan = shift;
return if !defined $dxchan;
- my ($user) = $dxchan->{user};
- my ($conn) = $dxchan->{conn};
+ my $user = $dxchan->{user};
+ my $conn = $dxchan->{conn};
$user->close() if defined $user;
$conn->disconnect() if defined $conn;
$dxchan->del();
return;
}
- # set up the basic channel info
+ # set up the basic channel info - this needs a bit more thought - there is duplication here
if (!defined $dxchan) {
+ my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
my $user = DXUser->get($call);
$user = DXUser->new($call) if !defined $user;
$dxchan = DXChannel->new($call, $conn, $user);
foreach $dxchan (DXChannel->get_all()) {
disconnect($dxchan);
}
+ exit(0);
}
# this is where the input queue is dealt with and things are dispatched off to other parts of
my $data = $self->{data};
my $dxchan = $self->{dxchan};
- my ($sort, $call, $line) = $data =~ /^(\w)(\S+)|(.*)$/;
+ my ($sort, $call, $line) = $data =~ /^(\w)(\S+)\|(.*)$/;
# do the really sexy console interface bit! (Who is going to do the TK interface then?)
print DEBUG atime, " < $sort $call $line\n" if defined DEBUG;
my $user = $dxchan->{user};
$user->{sort} = 'U' if !defined $user->{sort};
if ($user->{sort} eq 'U') {
- $dxchan->send_later('D', m('l2', $call, $mycall, $myqth));
+ $dxchan->send_now('D', msg('l2', $call, $mycall, $myqth));
$dxchan->send_file($motd) if (-e $motd);
}
} elsif (sort eq 'D') {
#############################################################
# open the debug file, set various FHs to be unbuffered
-open(DEBUG, ">>$debugfn") or die "can't open $debugfn($!)\n";
+open(DEBUG, ">>$debugfn") or die "can't open $debugfn($!)";
select DEBUG; $| = 1;
select STDOUT; $| = 1;
+++ /dev/null
-
-#
-# testmsg.pl - Used for testing the Msg.pm module
-# Invoke as testmsg.pl {-client|-server}
-#
-use Msg;
-use strict;
-
-my $i = 0;
-sub rcvd_msg_from_server {
- my ($conn, $msg, $err) = @_;
- if (defined $msg) {
- die "Strange... shouldn't really be coming here\n";
- }
-}
-
-my $incoming_msg_count=0;
-
-sub rcvd_msg_from_client {
- my ($conn, $msg, $err) = @_;
- if (defined $msg) {
- ++$i;
- my $len = length ($msg);
- print "$i ($len)\n";
- }
-}
-
-sub login_proc {
- # Unconditionally accept
- \&rcvd_msg_from_client;
-}
-
-my $host = 'localhost';
-my $port = 8080;
-my $prog;
-foreach $prog (@ARGV) {
- if ($prog eq '-server') {
- Msg->new_server($host, $port, \&login_proc);
- print "Server created. Waiting for events";
- Msg->event_loop();
- } elsif ($prog eq '-client') {
- my $conn = Msg->connect($host, $port,
- \&rcvd_msg_from_server);
-
- die "Client could not connect to $host:$port\n" unless $conn;
- print "Connection successful.\n";
- my $i;
- my $msg = " " x 10000;
- for ($i = 0; $i < 100; $i++) {
- print "Sending msg $i\n";
- $conn->send_now($msg);
- }
- $conn->disconnect();
- Msg->event_loop();
- }
-}
-
+++ /dev/null
-#!/usr/bin/perl -w
-#
-# A text message handling demon
-#
-# Copyright (c) 1997 Dirk Koopman G1TLH
-#
-# $Id$
-#
-# $Log$
-# Revision 1.1 1997-11-26 00:55:39 djk
-# initial version
-#
-#
-
-require 5.003;
-use Socket;
-use FileHandle;
-use Carp;
-
-$mycall = "GB7DJK";
-$listenport = 5072;
-
-#
-# system variables
-#
-
-$version = "1";
-@port = (); # the list of active ports (filehandle, $name, $sort, $device, $port, $ibufp, $ibuf, $obufp, $obuf, $prog)
-@msg = (); # the list of messages
-
-
-#
-# stop everything and exit
-#
-sub terminate
-{
- print "closing spiderd\n";
- exit(0);
-}
-
-#
-# start the tcp listener
-#
-sub startlisten
-{
- my $proto = getprotobyname('tcp');
- my $h = new FileHandle;
-
- socket($h, PF_INET, SOCK_STREAM, $proto) or die "Can't open listener socket: $!";
- setsockopt($h, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "Can't set SO_REUSEADDR: $!";
- bind($h, sockaddr_in($listenport, INADDR_ANY)) or die "Can't bind listener socket: $!";
- listen($h, SOMAXCONN) or die "Error on listen: $!";
- push @port, [ $h, "Listener", "listen", "localhost", $listenport, 0, "", 0, "", "spider" ];
- print "listening on port $listenport\n";
-}
-
-#
-# close a tcp connection
-#
-sub close_con
-{
- my ($p) = @_;
- close($port[$p][0]);
- print "closing ", $port[$p][3], $port[$p][4];
- splice @port, $p, 1; # remove it from the list
- my $n = @port;
- print ", there are $n connections\n";
-}
-
-#
-# the main select loop for incoming data
-#
-sub doselect
-{
- my $rin = "";
- my $i;
- my $r;
- my $h;
- my $maxport = 0;
-
- # set up the bit mask(s)
- for $i (0 .. $#port) {
- $h = fileno($port[$i][0]);
- vec($rin, $h, 1) = 1;
- $maxport = $h if $h > $maxport;
- }
-
- $r = select($rin, undef, undef, 0.001);
- die "Error $! during select" if ($r < 0);
- if ($r > 0) {
-# print "input $r handles\n";
- for $i (0 .. $#port) {
- $h = $port[$i][0];
- if (vec($rin, fileno($h), 1)) { # we have some input!
- my $sort = $port[$i][2];
-
- if ($sort eq "listen") {
- my @entry;
- my $ch = new FileHandle;
- my $paddr = accept($ch, $h);
- my ($port, $iaddr) = sockaddr_in($paddr);
- my $name = gethostbyaddr($iaddr, AF_INET);
- my $dotquad = inet_ntoa($iaddr);
- my @rec = ( $ch, "unknown", "tcp", $name, $port, 0, "", 0, "", "unknown" );
-
- push @port, [ @rec ]; # add a new entry to be selected on
- my $n = @port;
- print "new connection from $name ($dotquad) port: $port, there are $n connections\n";
- my $hello = join('|', ("HELLO",$mycall,"spiderd",$version)) . "\n";
- $ch->autoflush(1);
- print $ch $hello;
- } else {
- my $buf;
- $r = sysread($h, $buf, 128);
- if ($r == 0) { # close the filehandle and remove it from the list of ports
- close_con($i);
- last; # return, 'cos we will get the array subscripts in a muddle
- } elsif ($r > 0) {
- # we have a buffer full, search for a terminating character, cut it out
- # and add it to the saved buffer, write the saved buffer away to the message
- # list
- $buf =~ /^(.*)[\r\n]+$/s;
- if ($buf =~ /[\r\n]+$/) {
- $buf =~ s/[\r\n]+$//;
- push @msg, [ $i, $port[$i][6] . $buf ];
- $port[$i][6] = "";
- } else {
- $port[$i][6] .= $buf;
- }
- }
- }
- }
- }
- }
-}
-
-#
-# process each message on the queue
-#
-
-sub processmsg
-{
- return if @msg == 0;
-
- my $list = shift @msg;
- my ($p, $msg) = @$list;
- my @m = split /\|/, $msg;
- my $hand = $port[$p][0];
- print "msg (port $p) = ", join(':', @m), "\n";
-
- # handle basic cases
- $m[0] = uc $m[0];
-
- if ($m[0] eq "QUIT" || $m[0] eq "BYE") {
- close_con($p);
- return;
- }
- if ($m[0] eq "HELLO") { # HELLO|<call>|<prog>|<version>
- $port[$p][1] = uc $m[1] if $m[1];
- $port[$p][9] = $m[2] if $m[2];
- print uc $m[1], " has just joined the message switch\n";
- return;
- }
- if ($m[0] eq "CONFIG") {
- my $i;
- for $i ( 0 .. $#port ) {
- my ($h, $call, $sort, $addr, $pt) = @{$port[$i]};
- my $p = join('|', ("CONFIG",$mycall,$i,$call,$sort,$addr,$pt,$port[$i][9])) . "\n";
- print $hand $p;
- }
- return;
- }
-}
-
-
-#
-# the main loop, this impliments the select which drives the whole thing round
-#
-sub main
-{
- for (;;) {
- doselect;
- processmsg;
- }
-}
-
-#
-# main program
-#
-
-$SIG{TERM} = \&terminate;
-$SIG{INT} = \&terminate;
-
-startlisten;
-main;
-
projects / spider.git / commitdiff