--- /dev/null
+Programming Notes ($Id$)
+
+* Every command that can used on the command line lives in either this
+ directory ('cmd') or in a local version ('local_cmd'). You are cajoled or
+ ordered not to and generally discouraged from altering the commands in
+ the 'cmd' directory. You can put local copies in the 'local_cmd' directory
+ and they will override the standard ones.
+
+* If you want to play, do it in the 'local_cmd' directory. It's very easy and
+ reasonably safe. You can override a command whilst the cluster is running.
+ Compilation errors will simply give you error messages, it won't stop the
+ cluster running - this only happens if you mess with the internals to the
+ extent that it gets confused...
+
+* A command is a piece of perl, it is simply a small snippet of program
+ that is dynamically loaded into the cluster on invocation from the
+ command line. The last modification time is used to determine whether to
+ reload it.
+
+* New (or altered) commands are available for test the moment you save them.
+
+* A command is placed into the appropriate directory with a '.pl' appended
+ to the end. So the 'show/qra' command lives in 'cmd/show/qra.pl' (or a
+ local version would be in 'local_cmd/show/qra.pl'.
+
+* For the security conscious, potentially dubious characters (i.e. not
+ [A-Za-z0-9_/]) are converted to their hex equivalents. This will almost
+ certainly mean that the user will get an error message (unless you have
+ your secret squirrel hat on and have deliberately put such commands up
+ [in 'local_cmd' of course]).
+
+* The snippets of program you put here are wrapped in an eval { } and
+ are subroutines derived from the DXChannel class. They effectively
+ the following declaration :-
+
+ sub Emb_<cmdname>($self, $args)
+ {
+ ...
+ your code here
+ ...
+ }
+
+* slash characters are replaced by '_' so the equivalent name for 'show/qth'
+ is 'Emb_show_qth'.
+
+* you would normally do a 'my $self = shift;' as the first thing. There
+ are a complete set of accessors for DXUser, DXCommandmode and DXChannel
+ classes and these are the recommended way of getting at these classes.
+ A fairly standard start might be:-
+
+ $self = shift;
+ $call = $self->call;
+ $user = $self->user;
+
+* $args is the rest of the line after the command (as a string).
+
+* You are responsible for maintaining user security. If you have a command
+ that does something a normal system shouldn't be allowed to do or see,
+ there is $self->priv (using the above example) which gives you the running
+ privilege level of the channel. USE IT!
+
+* The normal privilege levels are:-
+ 0 - user privilege.
+ 5 - sysop privilege.
+ 9 - console privilege.
+
+ The sysop privilege is for things that you are prepared for remote
+ sysops and clusters to do or see.
+
+ A console privilege can only be executed locally (at least if you have
+ correctly installed the client program in inetd or ax25d).
+
+ The set/priv command can only be executed by a console privileged
+ session.
+
+* You must return a list with a 0 or 1 as the first element. 1 means
+ success and 0 means fail. Each element of the list which follows is
+ assumed to be one line for output. Don't put \n characters at the end
+ of an element (the client will put the correct one in if required
+ [but see below]).
+
+* Anything you output with a > as the last character is taken to mean
+ that this is a prompt and will not have a \r or \n appended to it.
+
+* help files can also be placed in the appropriate place. These files
+ have exactly the same naming conventions as commands except that they
+ have a '.hlp' appended to the command name rather than a '.pl'. All
+ in the help file are sent to the user except those starting with a '#'
+ character.
+++ /dev/null
-#
-# the bye command
-#
-# $Id$
-#
-
-my $self = shift;
-$self->state('bye');
-return (1);
--- /dev/null
+#
+# the bye command
+#
+# $Id$
+#
+
+my $self = shift;
+$self->state('bye');
+return (1);
--- /dev/null
+#
+# add a debug level
+#
+# $Id$
+#
+
+use DXDebug;
+
+$self = shift;
+return (0) if $self->priv < 9;
+
+dbgadd(split);
+my $set = join ' ', dbglist();
+
+return (1, "Debug Levels now: $set");
+++ /dev/null
-#
-# set the qra locator field
-#
-# $Id$
-#
-my ($self, $args) = @_;
-my $user = $self->user;
-return (1, "qra locator is now ", $user->qra($args));
--- /dev/null
+#
+# set the qra locator field
+#
+# $Id$
+#
+my ($self, $args) = @_;
+my $user = $self->user;
+return (1, "qra locator is now ", $user->qra($args));
+++ /dev/null
-#
-# set the qth field
-#
-# $Id$
-#
-my ($self, $args) = @_;
-my $user = $self->user;
-return (1, "qth is now ", $user->qth($args));
--- /dev/null
+#
+# set the qth field
+#
+# $Id$
+#
+my ($self, $args) = @_;
+my $user = $self->user;
+return (1, "qth is now ", $user->qth($args));
--- /dev/null
+#
+# show the channel status
+#
+# $Id$
+#
+
+my $self = shift;
+#return (0) if ($self->priv < 9); # only console users allowed
+my @list = split; # generate a list of callsigns
+@list = ($self->call) if !@list; # my channel if no callsigns
+
+my $call;
+my @out;
+foreach $call (@list) {
+ my $ref = DXChannel->get($call);
+ return (0, "Channel: $call not found") if !$ref;
+
+ my @fields = $ref->fields;
+ my $field;
+ push @out, "User Information $call";
+ foreach $field (@fields) {
+ my $prompt = $ref->field_prompt($field);
+ my $val = $ref->{$field};
+ push @out, "$prompt: $val";
+ }
+}
+
+return (1, @out);
+
+
--- /dev/null
+#
+# show the debug status
+#
+# $Id$
+#
+
+use DXDebug;
+
+my $self = shift;
+#return (0) if ($self->priv < 9); # only console users allowed
+
+my $set = join ' ', dbglist(); # generate space delimited list
+
+return (1, "debug levels: $set");
+
+
+++ /dev/null
-#
-# show either the current user or a nominated set
-#
-# $Id$
-#
-
-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
+#
+# show either the current user or a nominated set
+#
+# $Id$
+#
+
+my $self = shift;
+#return (0) if ($self->priv < 9); # only console users allowed
+my @list = split; # generate a list of callsigns
+@list = ($self->call) if !@list; # my channel if no callsigns
+
+my $call;
+my @out;
+foreach $call (@list) {
+ my $ref = DXUser->get($call);
+ return (0, "User: $call not found") if !$ref;
+
+ my @fields = $ref->fields;
+ my $field;
+ push @out, "User Information $call";
+ foreach $field (@fields) {
+ my $prompt = $ref->field_prompt($field);
+ my $val = $ref->{$field};
+ push @out, "$prompt: $val";
+ }
+}
+
+return (1, @out);
+
+
+
+
+++ /dev/null
-#
-# the shutdown command
-#
-# $Id$
-#
-&main::cease();
--- /dev/null
+#
+# the shutdown command
+#
+# $Id$
+#
+my $self = shift;
+if ($self->priv >= 5) {
+ &main::cease();
+}
+return (0);
--- /dev/null
+#
+# add a debug level
+#
+# $Id$
+#
+
+use DXDebug;
+
+$self = shift;
+return (0) if $self->priv < 9;
+
+dbgsub(split);
+my $set = join ' ', dbglist();
+
+return (1, "Debug Levels now: $set");
use Msg;
use DXUtil;
use DXM;
+use DXDebug;
%channels = undef;
oldstate => 'Last State',
list => 'Dependant DXChannels list',
name => 'User Name',
+ connsort => 'Connection Type'
);
-# create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
+# create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
sub new
{
my ($pkg, $call, $conn, $user) = @_;
return $channels{$call} = $self;
}
-# obtain a connection object by callsign [$obj = DXChannel->get($call)]
+# obtain a channel object by callsign [$obj = DXChannel->get($call)]
sub get
{
my ($pkg, $call) = @_;
- return $connect{$call};
+ return $channels{$call};
}
-# obtain all the connection objects
+# obtain all the channel objects
sub get_all
{
my ($pkg) = @_;
return values(%channels);
}
-# obtain a connection object by searching for its connection reference
+# obtain a channel object by searching for its connection reference
sub get_by_cnum
{
my ($pkg, $conn) = @_;
return undef;
}
-# get rid of a connection object [$obj->del()]
+# get rid of a channel object [$obj->del()]
sub del
{
my $self = shift;
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";
+ dbg('chan', "-> $sort $call $line\n");
$conn->send_now("$sort$call|$line");
}
}
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";
+ dbg('chan', "-> D $call $line\n");
$conn->send_later("D$call|$line");
}
}
my $self = shift;
$self->{oldstate} = $self->{state};
$self->{state} = shift;
- print "Db $self->{call} channel state $self->{oldstate} -> $self->{state}\n" if $main::debug;
+ dbg('state', "$self->{call} channel state $self->{oldstate} -> $self->{state}\n");
}
# various access routines
+
+#
+# return a list of valid elements
+#
+
+sub fields
+{
+ return keys(%valid);
+}
+
+#
+# return a prompt for a field
+#
+
+sub field_prompt
+{
+ my ($self, $ele) = @_;
+ return $valid{$ele};
+}
+
sub AUTOLOAD
{
my $self = shift;
use DXChannel;
use DXUser;
use DXVars;
+use DXDebug;
use strict;
use vars qw( %Cache $last_dir_mtime @cmd);
sub start
{
- my $self = shift;
+ my ($self, $line) = @_;
my $user = $self->{user};
my $call = $self->{call};
my $name = $self->{name};
$name = $call if !defined $name;
+
$self->msg('l2',$name);
$self->send_file($main::motd) if (-e $main::motd);
$self->msg('pr', $call);
$self->state('prompt'); # a bit of room for further expansion, passwords etc
- $self->{priv} = 0; # set the connection priv to 0 - can be upgraded later
+ $self->{priv} = $user->priv;
+ $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later
+ $self->{consort} = $line; # save the connection type
}
#
my $path = shift;
my $cmdname = shift;
my $package = valid_package_name($cmdname);
- my $filename = "$path/$cmdname";
+ my $filename = "$path/$cmdname.pl";
my $mtime = -M $filename;
# return if we can't find it
#wrap the code into a subroutine inside our unique package
my $eval = qq{package DXChannel; sub $package { $sub; }};
- print "eval $eval\n";
+ if (isdbg('eval')) {
+ my @list = split /\n/, $eval;
+ my $line;
+ foreach (@list) {
+ dbg('eval', $_, "\n");
+ }
+ }
+ #print "eval $eval\n";
{
#hide our variables within this block
my($filename,$mtime,$package,$sub);
my @r;
my $c = qq{ \@r = \$self->$package(\@_); };
- print "c = $c\n";
+ dbg('eval', "cluster cmd = $c\n");
eval $c; ;
if ($@) {
delete_package($package);
pr => '$_[0] de $main::mycall $main::cldate $main::ztime >',
e1 => 'Invalid command',
e2 => 'Error: $_[0]',
+ conother => 'Sorry $_[0] you are connected on another port',
+ concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster',
);
sub msg
use DXChannel;
use DXUser;
use DXM;
+use DXCluster;
# this is how a pc connection starts (for an incoming connection)
# issue a PC38 followed by a PC18, then wait for a PC20 (remembering
sub start
{
my $self = shift;
+ my $call = $self->call;
+
+ # do we have him connected on the cluster somewhere else?
+ if (DXCluster->get
+ $self->pc38();
+ $self->pc18();
+ $self->{state} = 'incoming';
}
#
{
}
+
+#
+# All the various PC routines
+#
1;
__END__
# return a list of valid elements
#
-sub elements
+sub fields
{
return keys(%valid);
}
# return a prompt for a field
#
-sub prompt
+sub field_prompt
{
my ($self, $ele) = @_;
return $valid{$ele};
$motd = "$data/motd";
# are we debugging ?
-$debug = 1;
+@debug = ('chan');
use Msg;
use DXVars;
-$mode = 1; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
+$mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
$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
+$mynl = "\n"; # standard terminator
# cease communications
sub cease
sub setmode
{
if ($mode == 1) {
- $nl = "\r";
+ $mynl = "\r";
} else {
- $nl = "\n";
- }
- $/ = $nl;
- if ($mode == 0) {
- $\ = undef;
- } else {
- $\ = $nl;
+ $mynl = "\n";
}
+ $/ = $mynl;
}
# handle incoming messages
my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
if ($sort eq 'D') {
- $nl = "" if $mode == 0;
+ my $snl = $mynl;
+ $snl = "" if $mode == 0;
+ $snl = ' ' if ($mode && $line =~ />$/);
$line =~ s/\n/\r/og if $mode == 1;
- print $line;
+ #my $p = qq($line$snl);
+ print $line, $snl;
} elsif ($sort eq 'M') {
$mode = $line; # set new mode from cluster
setmode();
}
}
-$call = uc $ARGV[0];
-die "client.pl <call> [<mode>]\r\n" if (!$call);
-$mode = $ARGV[1] if (@ARGV > 1);
+$call = uc shift @ARGV;
+$call = uc $mycall if !$call;
+$connsort = lc shift @ARGV;
+$connsort = 'local' if !$connsort;
+$mode = ($connsort =~ /^ax/) ? 1 : 2;
setmode();
-
#select STDOUT; $| = 1;
STDOUT->autoflush(1);
$SIG{'HUP'} = \&sig_term;
$conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
-$conn->send_now("A$call|start");
+$conn->send_now("A$call|$connsort");
Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin);
Msg->event_loop();
use DXM;
use DXCommandmode;
use DXProt;
+use DXCluster;
+use DXDebug;
package main;
$user = DXUser->new($call) if !defined $user;
$user->sort('U') if (!$user->sort());
my $sort = $user->sort();
+
+ # is there one already connected?
+ if (DXChannel->get($call)) {
+ my $mess = DXM::msg('conother', $call);
+ dbg('chan', "-> D $call $mess\n");
+ $conn->send_now("D$call|$mess");
+ dbg('chan', "-> Z $call bye\n");
+ $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect
+ return;
+ }
+
+ # is there one already connected elsewhere in the cluster?
+ if (DXCluster->get($call)) {
+ my $mess = DXM::msg('concluster', $call);
+ dbg('chan', "-> D $call $mess\n");
+ $conn->send_now("D$call|$mess");
+ dbg('chan', "-> Z $call bye\n");
+ $conn->send_now("Z$call|bye"); # this will cause 'client' to disconnect
+ return;
+ }
+
+ # create the channel
$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;
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;
- print "<- $sort $call $line\n";
+ dbg('chan', "<- $sort $call $line\n");
# handle A records
my $user = $dxchan->user;
#############################################################
# open the debug file, set various FHs to be unbuffered
-open(DEBUG, ">>$debugfn") or die "can't open $debugfn($!)";
-select DEBUG; $| = 1;
-select STDOUT; $| = 1;
+dbginit($debugfn);
+foreach(@debug) {
+ dbgadd($_);
+}
+STDOUT->autoflush(1);
# initialise User file system
DXUser->init($userfn);
$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->{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;
projects / spider.git / commitdiff