fixed dynamic executor (well it works)
added some commands
--- /dev/null
+#
+# the bye command
+#
+
+my $self = shift;
+$self->state('bye');
+return (1);
--- /dev/null
+#
+# set the qra locator field
+#
+my ($self, $args) = @_;
+my $user = $self->user;
+return (1, "qra locator is now ", $user->qra($args));
--- /dev/null
+#
+# set the qth field
+#
+my ($self, $args) = @_;
+my $user = $self->user;
+return (1, "qth is now ", $user->qth($args));
--- /dev/null
+#
+# show either the current user or a nominated set
+#
+my $self = shift;
+my @set = split; # the list of users you want listings (may be null)
+
+@set = ($self->call) if !@set; # my call if no args
+
+my ($call, $field);
+my @fields = DXUser->fields();
+foreach $call (@set) {
+ my $user = DXUser->get($call);
+}
+
+
--- /dev/null
+#
+# the shutdown command
+#
+&main::cease();
-require Exporter;
-@ISA = qw(DXCommandmode DXProt Exporter);
-
use Msg;
use DXUtil;
use DXM;
%channels = undef;
use Msg;
use DXUtil;
use DXM;
%channels = undef;
+%valid = (
+ call => 'Callsign',
+ conn => 'Msg Connection ref',
+ user => 'DXUser ref',
+ t => 'Time',
+ priv => 'Privilege',
+ state => 'Current State',
+ oldstate => 'Last State',
+ list => 'Dependant DXChannels list',
+ name => 'User Name',
+);
+
+
# create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
sub new
{
# create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
sub new
{
print "Db $self->{call} channel state $self->{oldstate} -> $self->{state}\n" if $main::debug;
}
print "Db $self->{call} channel state $self->{oldstate} -> $self->{state}\n" if $main::debug;
}
+# various access routines
+sub AUTOLOAD
+{
+ my $self = shift;
+ my $name = $AUTOLOAD;
+
+ return if $name =~ /::DESTROY$/;
+ $name =~ s/.*:://o;
+
+ die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+ @_ ? $self->{$name} = shift : $self->{$name} ;
+}
+
use DXUtil;
use DXChannel;
use DXUser;
use DXUtil;
use DXChannel;
use DXUser;
+use strict;
+use vars qw( %Cache $last_dir_mtime @cmd);
+
$last_dir_mtime = 0; # the last time one of the cmd dirs was modified
@cmd = undef; # a list of commands+path pairs (in alphabetical order)
$last_dir_mtime = 0; # the last time one of the cmd dirs was modified
@cmd = undef; # a list of commands+path pairs (in alphabetical order)
# possibly some other messages asking you to set various things up if you are
# new (or nearly new and slacking) user.
# possibly some other messages asking you to set various things up if you are
# new (or nearly new and slacking) user.
{
my $self = shift;
my $user = $self->{user};
my $call = $self->{call};
my $name = $self->{name};
$name = $call if !defined $name;
{
my $self = shift;
my $user = $self->{user};
my $call = $self->{call};
my $name = $self->{name};
$name = $call if !defined $name;
- $self->{normal} = \&user_normal; # rfu for now
- $self->{finish} = \&user_finish;
$self->msg('l2',$name);
$self->send_file($main::motd) if (-e $main::motd);
$self->msg('pr', $call);
$self->msg('l2',$name);
$self->send_file($main::motd) if (-e $main::motd);
$self->msg('pr', $call);
#
# This is the normal command prompt driver
#
#
# This is the normal command prompt driver
#
{
my $self = shift;
my $user = $self->{user};
my $call = $self->{call};
{
my $self = shift;
my $user = $self->{user};
my $call = $self->{call};
- # read in the list of valid commands, note that the commands themselves are cached elsewhere
- scan_cmd_dirs if (!defined %cmd);
+ # strip out //
+ $cmdline =~ s|//|/|og;
- # strip out any nasty characters like $@%&|. and double // etc.
- $cmd =~ s/[%\@\$&\\.`~]//og;
- $cmd =~ s|//|/|og;
-
- # split the command up into parts
- my @part = split /[\/\b]+/, $cmd;
-
- # the bye command - temporary probably
- if ($part[0] =~ /^b/io) {
- $self->user_finish();
- $self->state('bye');
- return;
+ # split the command line up into parts, the first part is the command
+ my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
+
+ if ($cmd) {
+
+ # first expand out the entry to a command
+ $cmd = search($cmd);
+
+ my @ans = $self->eval_file($main::localcmd, $cmd, $args);
+ @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
+ if ($ans[0]) {
+ shift @ans;
+ $self->send(@ans) if @ans > 0;
+ } else {
+ shift @ans;
+ if (@ans > 0) {
+ $self->msg('e2', @ans);
+ } else {
+ $self->msg('e1');
+ }
+ }
+ } else {
+ $self->msg('e1');
-
- # first expand out the entry to a command, note that I will accept
- # anything in any case with any (reasonable) seperator
- $self->prompt();
+
+ # send a prompt only if we are in a prompt state
+ $self->prompt() if $self->{state} =~ /^prompt/o;
}
#
# This is called from inside the main cluster processing loop and is used
# for despatching commands that are doing some long processing job
#
}
#
# This is called from inside the main cluster processing loop and is used
# for despatching commands that are doing some long processing job
#
#
# finish up a user context
#
#
# finish up a user context
#
{
my $self = shift;
my $call = $self->{call};
{
my $self = shift;
my $call = $self->{call};
- $self->msg('pr', $call);
+ DXChannel::msg($self, 'pr', $call);
-# scan the command directories to see if things have changed
-#
-# If they have remake the command list
-#
-# There are two command directories a) the standard one and b) the local one
-# The local one overides the standard one
+# search for the command in the cache of short->long form commands
- my $self = shift;
-
-
-}
+ my $short_cmd = shift;
+ return $short_cmd; # just return it for now
+}
#
# the persistant execution of things from the command directories
#
# the persistant execution of things from the command directories
#
#require Devel::Symdump;
#
#require Devel::Symdump;
-use strict;
-use vars '%Cache';
sub valid_package_name {
my($string) = @_;
sub valid_package_name {
my($string) = @_;
$string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
#Dress it up as a real package name
$string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
#Dress it up as a real package name
- $string =~ s|/|::|g;
- return "DXEmbed" . $string;
+ $string =~ s|/|_|g;
+ return "Emb_" . $string;
my ($stem, $leaf);
no strict 'refs';
my ($stem, $leaf);
no strict 'refs';
- $pkg = "main::$pkg\::"; # expand to full symbol table name
+ $pkg = "DXChannel::$pkg\::"; # expand to full symbol table name
($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
my $stem_symtab = *{$stem}{HASH};
($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
my $stem_symtab = *{$stem}{HASH};
- my($self, $path, $cmdname) = @_;
+ my $self = shift;
+ my $path = shift;
+ my $cmdname = shift;
my $package = valid_package_name($cmdname);
my $filename = "$path/$cmdname";
my $mtime = -M $filename;
my $package = valid_package_name($cmdname);
my $filename = "$path/$cmdname";
my $mtime = -M $filename;
+
+ # return if we can't find it
+ return (0, DXM::msg('e1')) if !defined $mtime;
if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
#we have compiled this subroutine already,
if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
#we have compiled this subroutine already,
- open FH, $filename or die "open '$filename' $!";
+ if (!open FH, $filename) {
+ return (0, "Syserr: can't open '$filename' $!");
+ };
local($/) = undef;
my $sub = <FH>;
close FH;
#wrap the code into a subroutine inside our unique package
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; }};
+ my $eval = qq{package DXChannel; sub $package { $sub; }};
+ print "eval $eval\n";
{
#hide our variables within this block
my($filename,$mtime,$package,$sub);
eval $eval;
}
if ($@) {
{
#hide our variables within this block
my($filename,$mtime,$package,$sub);
eval $eval;
}
if ($@) {
- $self->send("Eval err $@ on $package");
delete_package($package);
delete_package($package);
+ return (0, "Syserr: Eval err $@ on $package");
}
#cache it unless we're cleaning out each time
$Cache{$package}{mtime} = $mtime;
}
}
#cache it unless we're cleaning out each time
$Cache{$package}{mtime} = $mtime;
}
-
- @r = eval {$package->handler;};
+
+ my @r;
+ my $c = qq{ \@r = \$self->$package(\@_); };
+ print "c = $c\n";
+ eval $c; ;
- $self->send("Eval err $@ on cached $package");
delete_package($package);
delete_package($package);
+ return (0, "Syserr: Eval err $@ on cached $package");
}
#take a look if you want
}
#take a look if you want
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 >',
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 >',
+ e1 => 'Invalid command',
+ e2 => 'Error: $_[0]',
use DXUtil;
use DXChannel;
use DXUser;
use DXUtil;
use DXChannel;
use DXUser;
# this is how a pc connection starts (for an incoming connection)
# issue a PC38 followed by a PC18, then wait for a PC20 (remembering
# all the crap that comes between).
# this is how a pc connection starts (for an incoming connection)
# issue a PC38 followed by a PC18, then wait for a PC20 (remembering
# all the crap that comes between).
- $self->{normal} = \&pc_normal;
- $self->{finish} = \&pc_finish;
}
#
# This is the normal pcxx despatcher
#
}
#
# This is the normal pcxx despatcher
#
# This is called from inside the main cluster processing loop and is used
# for despatching commands that are doing some long processing job
#
# This is called from inside the main cluster processing loop and is used
# for despatching commands that are doing some long processing job
#
#
# finish up a pc context
#
#
# finish up a pc context
#
qra => 'Locator',
email => 'E-mail Address',
priv => 'Privilege Level',
qra => 'Locator',
email => 'E-mail Address',
priv => 'Privilege Level',
- sort => 'Type of User',
lastin => 'Last Time in',
passwd => 'Password',
lastin => 'Last Time in',
passwd => 'Password',
+ addr => 'Full Address',
+ 'sort' => 'Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
+sub AUTOLOAD
+{
+ my $self = shift;
+ my $name = $AUTOLOAD;
+
+ return if $name =~ /::DESTROY$/;
+ $name =~ s/.*:://o;
+
+ die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+ @_ ? $self->{$name} = shift : $self->{$name} ;
+}
+
#
# initialise the system
#
#
# initialise the system
#
-# return a prompt together with the existing value
+# return a prompt for a field
#
sub prompt
{
my ($self, $ele) = @_;
#
sub prompt
{
my ($self, $ele) = @_;
- return "$valid{$ele} [$self->{$ele}]";
+
+# some variable accessors
+sub sort
+{
+ my $self = shift;
+ @_ ? $self->{sort} = shift : $self->{sort} ;
+}
return if !defined $dxchan;
my $user = $dxchan->{user};
my $conn = $dxchan->{conn};
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();
$user->close() if defined $user;
$conn->disconnect() if defined $conn;
$dxchan->del();
my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
my $user = DXUser->get($call);
$user = DXUser->new($call) if !defined $user;
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);
+ $user->sort('U') if (!$user->sort());
+ my $sort = $user->sort();
+ $dxchan = DXCommandmode->new($call, $conn, $user) if ($sort eq 'U');
+ $dxchan = DXProt->new($call, $conn, $user) if ($sort eq 'A');
+ die "Invalid sort of user on $call = $sort" if !$dxchan;
}
# queue the message and the channel object for later processing
}
# queue the message and the channel object for later processing
print "<- $sort $call $line\n";
# handle A records
print "<- $sort $call $line\n";
# handle A records
- my $user = $dxchan->{user};
+ my $user = $dxchan->user;
- $user->{sort} = 'U' if !defined $user->{sort};
- 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;
} 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);
- }
+ $dxchan->normal($line);
disconnect($dxchan) if ($dxchan->{state} eq 'bye');
} elsif ($sort eq 'Z') {
disconnect($dxchan);
disconnect($dxchan) if ($dxchan->{state} eq 'bye');
} elsif ($sort eq 'Z') {
disconnect($dxchan);
$ztime = &ztime();
}
process_inqueue(); # read in lines from the input queue and despatch them
$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
+ DXCommandmode::process(); # process ongoing command mode stuff
+ DXProt::process(); # process ongoing ak1a pcxx stuff