From: djk Date: Wed, 17 Jun 1998 19:54:30 +0000 (+0000) Subject: we have a initial working loging in version. Doesn't do much, but its X-Git-Tag: SPIDER_1_5~58 X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=f77b59f4fcceb428142461972e94345419cbda28;p=spider.git we have a initial working loging in version. Doesn't do much, but its OK. --- diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 6a867bb9..b6615100 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -11,6 +11,7 @@ require Exporter; @ISA = qw(Exporter); use Msg; +use DXUtil; %connects = undef; @@ -20,7 +21,7 @@ sub new 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; @@ -74,7 +75,9 @@ sub send_now 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"); } @@ -89,7 +92,9 @@ sub send_later 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"); } diff --git a/perl/DXM.pm b/perl/DXM.pm index e1579fab..99fd3773 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -1,6 +1,14 @@ # # 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$ @@ -10,19 +18,19 @@ package DXM; 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 . '"'; } diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 60abaeda..7ce853c6 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -42,8 +42,8 @@ sub init { 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; } @@ -78,7 +78,7 @@ sub new sub get { - my $call = shift; + my ($pkg, $call) = @_; return $u{$call}; } diff --git a/perl/client.pl b/perl/client.pl index f7912ad7..a5caec45 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -51,12 +51,12 @@ sub rec_socket 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 ..... @@ -78,7 +78,7 @@ sub rec_stdin # 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 @@ -113,7 +113,7 @@ select STDOUT; $| = 1; $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"); diff --git a/perl/cluster.pl b/perl/cluster.pl index fc2a0973..8097f6cd 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -28,8 +28,8 @@ sub disconnect { 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(); @@ -46,8 +46,9 @@ sub rec 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); @@ -74,6 +75,7 @@ sub cease 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 @@ -85,7 +87,7 @@ sub process_inqueue 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; @@ -96,7 +98,7 @@ sub process_inqueue 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') { @@ -113,7 +115,7 @@ sub process_inqueue ############################################################# # 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; diff --git a/perl/msgdemo.pl b/perl/msgdemo.pl deleted file mode 100644 index 9ea40566..00000000 --- a/perl/msgdemo.pl +++ /dev/null @@ -1,57 +0,0 @@ - -# -# 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(); - } -} - diff --git a/perl/spiderd.pl b/perl/spiderd.pl deleted file mode 100755 index bc63ff18..00000000 --- a/perl/spiderd.pl +++ /dev/null @@ -1,196 +0,0 @@ -#!/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||| - $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; -