#
# 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$
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) = @_;
sub get_all
{
my ($pkg) = @_;
- return values(%connects);
+ return values(%channels);
}
# obtain a connection object by searching for its connection reference
my ($pkg, $conn) = @_;
my $self;
- foreach $self (values(%connects)) {
+ foreach $self (values(%channels)) {
return $self if ($self->{conn} == $conn);
}
return undef;
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");
+ }
}
}
open(F, $fn) or die "can't open $fn for sending file ($!)";
@buf = <F>;
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;
%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
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;
+}
$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";
# 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";
# 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";
@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
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
{
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);
}
}
$call = uc $ARGV[0];
die "client.pl <call> [<mode>]\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;
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
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();
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";
}
}
# 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
}
$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";
}
+++ /dev/null
-
- /* persistent.c */
-#include <EXTERN.h>
-#include <perl.h>
-
- /* 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);
-}
+++ /dev/null
-#
-# 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 = <FH>;
- 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__
projects / spider.git / commitdiff