sorted out inheritance

fixed dynamic executor (well it works)
added some commands

cmd/bye

@@ -0,0 +1,7 @@
+#
+# the bye command
+#
+
+my $self = shift;
+$self->state('bye');
+return (1);

cmd/set/qra

@@ -0,0 +1,6 @@
+#
+# set the qra locator field
+#
+my ($self, $args)  = @_;
+my $user = $self->user;
+return (1, "qra locator is now ", $user->qra($args));

cmd/set/qth

@@ -0,0 +1,6 @@
+#
+# set the qth field
+#
+my ($self, $args)  = @_;
+my $user = $self->user;
+return (1, "qth is now ", $user->qth($args));

cmd/show/user

@@ -0,0 +1,15 @@
+#
+# 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);
+}
+
+

cmd/shutdown

@@ -0,0 +1,4 @@
+#
+# the shutdown command
+#
+&main::cease();

perl/DXChannel.pm

@@ -25,15 +25,25 @@
 #
 package DXChannel;
 
-require Exporter;
-@ISA = qw(DXCommandmode DXProt Exporter);
-
 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
 {
@@ -173,5 +183,18 @@ sub state
   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} ;
+}
+
 1;
 __END__;

perl/DXCommandmode.pm

@@ -9,12 +9,16 @@
 
 package DXCommandmode;
 
+@ISA = qw(DXChannel);
+
 use DXUtil;
 use DXChannel;
 use DXUser;
-use DXM;
 use DXVars;
 
+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)
 
@@ -22,15 +26,13 @@ $last_dir_mtime = 0;          # the last time one of the cmd dirs was modified
 # possibly some other messages asking you to set various things up if you are
 # new (or nearly new and slacking) user.
 
-sub user_start
+sub start
 { 
   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);
@@ -41,40 +43,50 @@ sub user_start
 #
 # This is the normal command prompt driver
 #
-sub user_normal
+sub normal
 {
   my $self = shift;
   my $user = $self->{user};
   my $call = $self->{call};
-  my $cmd = shift; 
+  my $cmdline = shift; 
 
-  # 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;
+  # split the command line up into parts, the first part is the command
+  my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
 
-  # the bye command - temporary probably
-  if ($part[0] =~ /^b/io) {
-    $self->user_finish();
-	$self->state('bye');
-	return;
+  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
 #
-sub user_process
+sub process
 {
 
 }
@@ -82,7 +94,7 @@ sub user_process
 #
 # finish up a user context
 #
-sub user_finish
+sub finish
 {
 
 }
@@ -95,24 +107,18 @@ sub prompt
 {
   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
 #
 
-sub scan_cmd_dirs
+sub search
 {
-  my $self = shift;
-
-
-}
+  my $short_cmd = shift;
+  return $short_cmd;    # just return it for now
+}  
 
 #
 # the persistant execution of things from the command directories
@@ -124,8 +130,6 @@ sub scan_cmd_dirs
 #
 
 #require Devel::Symdump;  
-use strict;
-use vars '%Cache';
 
 sub valid_package_name {
   my($string) = @_;
@@ -135,8 +139,8 @@ sub valid_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;
 }
 
 #borrowed from Safe.pm
@@ -145,7 +149,7 @@ sub delete_package {
   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};
@@ -154,11 +158,15 @@ sub delete_package {
 }
 
 sub eval_file {
-  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 @r;
+  
+  # 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,
@@ -167,33 +175,37 @@ sub eval_file {
 	;
   } else {
 	local *FH;
-	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
-	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 ($@) {
-	  $self->send("Eval err $@ on $package");
 	  delete_package($package);
-	  return undef;
+	  return (0, "Syserr: Eval err $@ on $package");
 	}
 		
 	#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; ;
   if ($@) {
-    $self->send("Eval err $@ on cached $package");
     delete_package($package);
-	return undef;
+	return (0, "Syserr: Eval err $@ on cached $package");
   }
 
   #take a look if you want

perl/DXM.pm

@@ -24,6 +24,8 @@ require Exporter;
   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]',
 );
 
 sub msg

perl/DXProt.pm

@@ -9,6 +9,8 @@
 
 package DXProt;
 
+@ISA = qw(DXChannel);
+
 use DXUtil;
 use DXChannel;
 use DXUser;
@@ -17,17 +19,15 @@ use DXM;
 # 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).
-sub pc_start
+sub start
 {
   my $self = shift;
-  $self->{normal} = \&pc_normal;
-  $self->{finish} = \&pc_finish;
 }
 
 #
 # This is the normal pcxx despatcher
 #
-sub pc_normal
+sub normal
 {
 
 }
@@ -36,7 +36,7 @@ sub pc_normal
 # This is called from inside the main cluster processing loop and is used
 # for despatching commands that are doing some long processing job
 #
-sub pc_process
+sub process
 {
 
 }
@@ -44,7 +44,7 @@ sub pc_process
 #
 # finish up a pc context
 #
-sub pc_clean
+sub finish
 {
 
 }

perl/DXUser.pm

@@ -29,12 +29,24 @@ $filename = undef;
   qra => 'Locator',
   email => 'E-mail Address',
   priv => 'Privilege Level',
-  sort => 'Type of User',
   lastin => 'Last Time in',
   passwd => 'Password',
-  addr => 'Full Address'
+  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
 #
@@ -125,13 +137,13 @@ sub elements
 }
 
 #
-# return a prompt together with the existing value
+# return a prompt for a field
 #
 
 sub prompt
 { 
   my ($self, $ele) = @_;
-  return "$valid{$ele} [$self->{$ele}]";
+  return $valid{$ele};
 }
 
 #
@@ -167,5 +179,12 @@ sub enter
   }
   return 0;
 }
+
+# some variable accessors
+sub sort
+{
+  my $self = shift;
+  @_ ? $self->{sort} = shift : $self->{sort} ;
+}
 1;
 __END__

perl/cluster.pl

@@ -33,11 +33,7 @@ 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();
-  }
+  $dxchan->finish();
   $user->close() if defined $user;
   $conn->disconnect() if defined $conn;
   $dxchan->del();
@@ -59,7 +55,11 @@ sub rec
      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
@@ -102,21 +102,12 @@ sub process_inqueue
   print "<- $sort $call $line\n";
   
   # handle A records
-  my $user = $dxchan->{user};
+  my $user = $dxchan->user;
   if ($sort eq 'A') {
-	$user->{sort} = 'U' if !defined $user->{sort};
-    if ($user->{sort} eq 'A') {
-	  $dxchan->pc_start($line);  
-	} else {
-	  $dxchan->user_start($line);
-	}
+    $dxchan->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);
-	}
+	$dxchan->normal($line);  
     disconnect($dxchan) if ($dxchan->{state} eq 'bye');
   } elsif ($sort eq 'Z') {
     disconnect($dxchan);
@@ -158,7 +149,7 @@ for (;;) {
 	$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
 }