From f46017e7bef9ee062cd5a8648d214eabe585da25 Mon Sep 17 00:00:00 2001 From: djk Date: Thu, 18 Jun 1998 21:33:15 +0000 Subject: [PATCH] started the command processor code. fixed some more of the connection bugs --- perl/DXChannel.pm | 117 ++++++++++++++++++++++++++++++------------- perl/DXM.pm | 1 + perl/DXUtil.pm | 26 +++++++++- perl/DXVars.pm | 10 +++- perl/client.pl | 27 +++++++--- perl/cluster.pl | 41 ++++++++++++--- perl/create_sysop.pl | 18 +++++++ perl/persist.c | 48 ------------------ perl/persistent.pl | 81 ------------------------------ 9 files changed, 187 insertions(+), 182 deletions(-) delete mode 100644 perl/persist.c delete mode 100644 perl/persistent.pl diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index b6615100..065a78c8 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -1,6 +1,24 @@ # # module to manage channel lists & data # +# This is the base class for all channel operations, which is everything to do +# with input and output really. +# +# The instance variable in the outside world will be generally be called $dxchann +# +# This class is 'inherited' (if that is the goobledegook for what I am doing) +# by various other modules. The point to understand is that the 'instance variable' +# is in fact what normal people would call the state vector and all useful info +# about a connection goes in there. +# +# Another point to note is that a vector may contain a list of other vectors. +# I have simply added another variable to the vector for 'simplicity' (or laziness +# as it is more commonly called) +# +# PLEASE NOTE - I am a C programmer using this as a method of learning perl +# firstly and OO about ninthly (if you don't like the design and you can't +# improve it with better OO by make it smaller and more efficient, then tough). +# # Copyright (c) 1998 - Dirk Koopman G1TLH # # $Id$ @@ -8,30 +26,31 @@ package DXChannel; require Exporter; -@ISA = qw(Exporter); +@ISA = qw(DXCommandmode DXProt Exporter); use Msg; use DXUtil; +use DXM; -%connects = undef; +%channels = undef; -# create a new connection object [$obj = Connect->new($call, $msg_conn_obj, $user_obj)] +# create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] sub new { my ($pkg, $call, $conn, $user) = @_; my $self = {}; - die "trying to create a duplicate channel for $call" if $connects{$call}; + die "trying to create a duplicate channel for $call" if $channels{$call}; $self->{call} = $call; - $self->{conn} = $conn; - $self->{user} = $user; + $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list + $self->{user} = $user if defined $user; $self->{t} = time; $self->{state} = 0; bless $self, $pkg; - return $connects{$call} = $self; + return $channels{$call} = $self; } -# obtain a connection object by callsign [$obj = Connect->get($call)] +# obtain a connection object by callsign [$obj = DXChannel->get($call)] sub get { my ($pkg, $call) = @_; @@ -42,7 +61,7 @@ sub get sub get_all { my ($pkg) = @_; - return values(%connects); + return values(%channels); } # obtain a connection object by searching for its connection reference @@ -51,7 +70,7 @@ sub get_by_cnum my ($pkg, $conn) = @_; my $self; - foreach $self (values(%connects)) { + foreach $self (values(%channels)) { return $self if ($self->{conn} == $conn); } return undef; @@ -61,42 +80,65 @@ sub get_by_cnum sub del { my $self = shift; - delete $connects{$self->{call}}; + delete $channels{$self->{call}}; } -# handle out going messages +# handle out going messages, immediately without waiting for the select to drop +# this could, in theory, block sub send_now { my $self = shift; - my $sort = shift; - my $call = $self->{call}; my $conn = $self->{conn}; - my $line; - - foreach $line (@_) { - 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"); + + # is this a list of channels ? + if (!defined $conn) { + die "tried to send_now to an invalid channel list" if !defined $self->{list}; + my $lself; + foreach $lself (@$self->{list}) { + $lself->send_now(@_); # it's recursive :-) + } + } else { + my $sort = shift; + my $call = $self->{call}; + my $line; + + foreach $line (@_) { + 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"); + } } } -sub send_later +# +# the normal output routine +# +sub send # this is always later and always data { my $self = shift; - my $sort = shift; - my $call = $self->{call}; my $conn = $self->{conn}; - my $line; - - foreach $line (@_) { - 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"); + + # is this a list of channels ? + if (!defined $conn) { + die "tried to send to an invalid channel list" if !defined $self->{list}; + my $lself; + foreach $lself (@$self->{list}) { + $lself->send(@_); # here as well :-) :-) + } + } else { + my $call = $self->{call}; + my $line; + + foreach $line (@_) { + my $t = atime; + chomp $line; + print main::DEBUG "$t > D $call $line\n" if defined DEBUG; + print "> D $call $line\n"; + $conn->send_later("D$call|$line"); + } } } @@ -111,7 +153,14 @@ sub send_file open(F, $fn) or die "can't open $fn for sending file ($!)"; @buf = ; close(F); - $self->send_later('D', @buf); + $self->send(@buf); +} + +# just a shortcut for $dxchan->send(msg(...)); +sub msg +{ + my $self = shift; + $self->send(DXM::msg(@_)); } 1; diff --git a/perl/DXM.pm b/perl/DXM.pm index 99fd3773..41c2bbff 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -23,6 +23,7 @@ require Exporter; %msgs = ( l1 => 'Sorry $_[0], you are already logged on on another channel', l2 => 'Hello $_[0], this is $main::mycall located in $main::myqth', + pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', ); sub msg diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 638a2bce..3ce68498 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -10,18 +10,40 @@ package DXUtil; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(atime +@EXPORT = qw(atime ztime cldate ); @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +# a full time for logging and other purposes sub atime { - my ($sec,$min,$hour,$mday,$mon,$year) = gmtime(time); + my $t = shift; + my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time); $year += 1900; my $buf = sprintf "%02d%s%04d\@%02d:%02d:%02d", $mday, $month[$mon], $year, $hour, $min, $sec; return $buf; } +# get a zulu time in cluster format (2300Z) +sub ztime +{ + my $t = shift; + my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time); + $year += 1900; + my $buf = sprintf "%02d%02dZ", $hour, $min; + return $buf; + +} + +# get a cluster format date (23-Jun-1998) +sub cldate +{ + my $t = shift; + my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time); + $year += 1900; + my $buf = sprintf "%02d-%s-%04d", $mday, $month[$mon], $year; + return $buf; +} diff --git a/perl/DXVars.pm b/perl/DXVars.pm index fced1ffb..11c26012 100644 --- a/perl/DXVars.pm +++ b/perl/DXVars.pm @@ -16,12 +16,12 @@ require Exporter; $myqth $myemail $myprot $clusterport $clusteraddr $debugfn $def_hopcount $root $data $system $cmd - $userfn $motd + $userfn $motd $local_cmd $mybbsaddr ); # this really does need to change for your system!!!! -$mycall = "GB7TLH"; +$mycall = "GB7DJK"; # your name $myname = "Dirk"; @@ -44,6 +44,9 @@ $myqth = "East Dereham, Norfolk"; # Your e-mail address $myemail = "djk\@tobit.co.uk"; +# Your BBS addr +$mybbsaddr = "G1TLH\@GB7TLH.#35.GBR.EU"; + # the tcp address of the cluster and so does this !!! $clusteraddr = "dirk1.tobit.co.uk"; @@ -71,6 +74,9 @@ $system = "$root/sys"; # command files live in $cmd = "$root/cmd"; +# local command files live in (and overide $cmd) +$localcmd = "$root/local_cmd"; + # where the user data lives $userfn = "$data/users"; diff --git a/perl/client.pl b/perl/client.pl index a5caec45..b2dcfa3a 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -25,7 +25,6 @@ $call = ""; # the callsign being used @stdoutq = (); # the queue of stuff to send out to the user $conn = 0; # the connection object for the cluster $lastbit = ""; # the last bit of an incomplete input line -$nl = "\r"; # cease communications sub cease @@ -43,6 +42,21 @@ sub sig_term cease(1); } +sub setmode +{ + if ($mode == 1) { + $nl = "\r"; + } else { + $nl = "\n"; + } + $/ = $nl; + if ($mode == 0) { + $\ = undef; + } else { + $\ = $nl; + } +} + # handle incoming messages sub rec_socket { @@ -59,7 +73,8 @@ sub rec_socket print $line; } elsif ($sort eq 'M') { $mode = $line; # set new mode from cluster - } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... + setmode(); + } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... cease(0); } } @@ -103,13 +118,11 @@ sub rec_stdin $call = uc $ARGV[0]; die "client.pl []\r\n" if (!$call); $mode = $ARGV[1] if (@ARGV > 1); +setmode(); -if ($mode != 1) { - $nl = "\n"; - $\ = $nl; -} -select STDOUT; $| = 1; +#select STDOUT; $| = 1; +STDOUT->autoflush(1); $SIG{'INT'} = \&sig_term; $SIG{'TERM'} = \&sig_term; diff --git a/perl/cluster.pl b/perl/cluster.pl index 8097f6cd..bdd1f7d9 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -18,10 +18,13 @@ use DXUtil; use DXChannel; use DXUser; use DXM; +use DXCommandmode; +use DXProt; package main; -@inqueue = (); # the main input queue, an array of hashes +@inqueue = (); # the main input queue, an array of hashes +$systime = 0; # the time now (in seconds) # handle disconnections sub disconnect @@ -30,6 +33,11 @@ sub disconnect return if !defined $dxchan; my $user = $dxchan->{user}; my $conn = $dxchan->{conn}; + if ($user->{sort} eq 'A') { # and here (when I find out how to write it!) + $dxchan->pc_finish(); + } else { + $dxchan->user_finish(); + } $user->close() if defined $user; $conn->disconnect() if defined $conn; $dxchan->del(); @@ -94,17 +102,25 @@ sub process_inqueue print "< $sort $call $line\n"; # handle A records + my $user = $dxchan->{user}; if ($sort eq 'A') { - my $user = $dxchan->{user}; $user->{sort} = 'U' if !defined $user->{sort}; - if ($user->{sort} eq 'U') { - $dxchan->send_now('D', msg('l2', $call, $mycall, $myqth)); - $dxchan->send_file($motd) if (-e $motd); + if ($user->{sort} eq 'A') { + $dxchan->pc_start($line); + } else { + $dxchan->user_start($line); + } + } elsif ($sort eq 'D') { + die "\$user not defined for $call" if !defined $user; + if ($user->{sort} eq 'A') { # we will have a symbolic ref to a proc here + $dxchan->pc_normal($line); + } else { + $dxchan->user_normal($line); } - } elsif (sort eq 'D') { - ; } elsif ($sort eq 'Z') { disconnect($dxchan); + } else { + print STDERR atime, " Unknown command letter ($sort) received from $call\n"; } } @@ -132,7 +148,16 @@ $SIG{'HUP'} = 'IGNORE'; # this, such as it is, is the main loop! for (;;) { + my $timenow; Msg->event_loop(1, 0.001); - process_inqueue(); + $timenow = time; + if ($timenow != $systime) { + $systime = $timenow; + $cldate = &cldate(); + $ztime = &ztime(); + } + process_inqueue(); # read in lines from the input queue and despatch them + DXCommandmode::user_process(); # process ongoing command mode stuff + DXProt::pc_process(); # process ongoing ak1a pcxx stuff } diff --git a/perl/create_sysop.pl b/perl/create_sysop.pl index dcab2f15..43d59785 100755 --- a/perl/create_sysop.pl +++ b/perl/create_sysop.pl @@ -24,12 +24,30 @@ sub create_it $self->{lat} = $mylatitude; $self->{long} = $mylongtitude; $self->{email} = $myemail; + $self->{bbsaddr} = $mybbsaddr; $self->{sort} = 'C'; # C - Console user, S - Spider cluster, A - AK1A, U - User, B - BBS $self->{priv} = 9; # 0 - 9 - with 9 being the highest $self->{lastin} = 0; # write it away $self->close(); + + # now do one for the alias + $self = DXUser->new($myalias); + $self->{name} = $myname; + $self->{qth} = $myqth; + $self->{qra} = $mylocator; + $self->{lat} = $mylatitude; + $self->{long} = $mylongtitude; + $self->{email} = $myemail; + $self->{bbsaddr} = $mybbsaddr; + $self->{sort} = 'U'; # C - Console user, S - Spider cluster, A - AK1A, U - User, B - BBS + $self->{priv} = 9; # 0 - 9 - with 9 being the highest + $self->{lastin} = 0; + + # write it away + $self->close(); + DXUser->finish(); print "New user database created as $userfn\n"; } diff --git a/perl/persist.c b/perl/persist.c deleted file mode 100644 index d0839e0d..00000000 --- a/perl/persist.c +++ /dev/null @@ -1,48 +0,0 @@ - - /* persistent.c */ -#include -#include - - /* 1 = clean out filename's symbol table after each request, 0 = don't */ -#ifndef DO_CLEAN -# define DO_CLEAN 0 -#endif - -static PerlInterpreter *perl = NULL; - -int main(int argc, char **argv, char **env) -{ - char *embedding[] = { "", "persistent.pl"}; - char *args[] = { "", DO_CLEAN, NULL }; - char filename [1024]; - int exitstatus = 0; - - if ((perl = perl_alloc()) == NULL) { - fprintf(stderr, "no memory!"); - exit(1); - } - perl_construct(perl); - - exitstatus = perl_parse(perl, NULL, 2, embedding, NULL); - - if(!exitstatus) { - exitstatus = perl_run(perl); - - while(printf("Enter file name: ") && gets(filename)) { - - /* call the subroutine, passing it the filename as an argument */ - args[0] = filename; - perl_call_argv("Embed::Persistent::eval_file", - G_DISCARD | G_EVAL, args); - - /* check $@ */ - if(SvTRUE(GvSV(errgv))) - fprintf(stderr, "eval error: %s\n", SvPV(GvSV(errgv),na)); - } - } - - perl_destruct_level = 0; - perl_destruct(perl); - perl_free(perl); - exit(exitstatus); -} diff --git a/perl/persistent.pl b/perl/persistent.pl deleted file mode 100644 index 23b302eb..00000000 --- a/perl/persistent.pl +++ /dev/null @@ -1,81 +0,0 @@ -# -# This allows perl programs to call functions dynamically -# -# This has been nicked directly from the perlembed pages -# so has the perl copyright -# -# $Id$ -# - -package Embed::Persistent; -#persistent.pl - -#require Devel::Symdump; -use strict; -use vars '%Cache'; - -sub valid_package_name { - my($string) = @_; - $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; -#second pass only for words starting with a digit - $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; - -#Dress it up as a real package name - $string =~ s|/|::|g; - return "Embed" . $string; -} - -#borrowed from Safe.pm -sub delete_package { - my $pkg = shift; - my ($stem, $leaf); - - no strict 'refs'; - $pkg = "main::$pkg\::"; # expand to full symbol table name - ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - my $stem_symtab = *{$stem}{HASH }; - - delete $stem_symtab->{$leaf }; - } - -sub eval_file { - my($filename, $delete) = @_; - my $package = valid_package_name($filename); - my $mtime = -M $filename; - if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) { -#we have compiled this subroutine already, -#it has not been updated on disk, nothing left to do - print STDERR "already compiled $package->handler\n"; - } else { - local *FH; - open FH, $filename or die "open '$filename' $!"; - local($/) = undef; - my $sub = ; - close FH; - -#wrap the code into a subroutine inside our unique package - my $eval = qq{package $package; sub handler { $sub; }}; - { -#hide our variables within this block - my($filename,$mtime,$package,$sub); - eval $eval; - } - die $@ if $@; - -#cache it unless we're cleaning out each time - $Cache{$package}{mtime} = $mtime unless $delete; -} - -eval {$package->handler;}; -die $@ if $@; - -delete_package($package) if $delete; - -#take a look if you want -#print Devel::Symdump->rnew($package)->as_string, $/; -} - -1; - -__END__ -- 2.34.1