From 56b610b0ed32b6d10122bca7554ce7a11251cdaa Mon Sep 17 00:00:00 2001 From: djk Date: Thu, 18 Jun 1998 21:34:11 +0000 Subject: [PATCH] add the files I should have on the last commit! --- perl/DXCommandmode.pm | 198 ++++++++++++++++++++++++++++++++++++++++++ perl/DXProt.pm | 53 +++++++++++ 2 files changed, 251 insertions(+) create mode 100644 perl/DXCommandmode.pm create mode 100644 perl/DXProt.pm diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm new file mode 100644 index 00000000..fb2957da --- /dev/null +++ b/perl/DXCommandmode.pm @@ -0,0 +1,198 @@ +#!/usr/bin/perl +# +# This module impliments the user facing command mode for a dx cluster +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# + +package DXCommandmode; + +use DXUtil; +use DXChannel; +use DXUser; +use DXM; +use DXVars; + +$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) + +# this is how a a connection starts, you get a hello message and the motd with +# possibly some other messages asking you to set various things up if you are +# new (or nearly new and slacking) user. + +sub user_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); + $self->{state} = 10; # a bit of room for further expansion, passwords etc + $self->{priv} = 0; # set the connection priv to 0 - can be upgraded later +} + +# +# This is the normal command prompt driver +# +sub user_normal +{ + my $self = shift; + my $user = $self->{user}; + my $call = $self->{call}; + my $cmd = shift; + + # read in the list of valid commands, note that the commands themselves are cached elsewhere + scan_cmd_dirs if (!defined %cmd); + + # strip out any nasty characters like $@%&|. and double // etc. + $cmd =~ s/[\%\@\$\&\|\.\`\~]//og; + $cmd =~ s|//|/|og; + + # split the command up into parts + my @parts = split |[/\b]+|, $cmd; + + # first expand out the entry to a command, note that I will accept + # anything in any case with any (reasonable) seperator + $self->prompt(); +} + +# +# 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 +{ + +} + +# +# finish up a user context +# +sub user_finish +{ + +} + +# +# short cut to output a prompt +# + +sub prompt +{ + my $self = shift; + my $call = $self->{call}; + $self->msg('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 +# + +sub scan_cmd_dirs +{ + my $self = shift; + + +} + +# +# the persistant execution of things from the command directories +# +# +# This allows perl programs to call functions dynamically +# +# This has been nicked directly from the perlembed pages +# + +#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 "DXEmbed" . $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($self, $path, $cmdname) = @_; + my $package = valid_package_name($cmdname); + my $filename = "$path/$cmdname"; + my $mtime = -m $filename; + my @r; + + 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; + } + if ($@) { + $self->send("Eval err $@ on $package"); + delete_package($package); + return undef; + } + + #cache it unless we're cleaning out each time + $Cache{$package}{mtime} = $mtime unless $delete; + } + + @r = eval {$package->handler;}; + if ($@) { + $self->send("Eval err $@ on cached $package"); + delete_package($package); + return undef; + } + + #take a look if you want + #print Devel::Symdump->rnew($package)->as_string, $/; + return @r; +} + +1; +__END__ diff --git a/perl/DXProt.pm b/perl/DXProt.pm new file mode 100644 index 00000000..b21a4b58 --- /dev/null +++ b/perl/DXProt.pm @@ -0,0 +1,53 @@ +#!/usr/bin/perl +# +# This module impliments the protocal mode for a dx cluster +# +# Copyright (c) 1998 Dirk Koopman G1TLH +# +# $Id$ +# + +package DXProt; + +use DXUtil; +use DXChannel; +use DXUser; +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 +{ + my $self = shift; + $self->{normal} = \&pc_normal; + $self->{finish} = \&pc_finish; +} + +# +# This is the normal pcxx despatcher +# +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 +{ + +} + +# +# finish up a pc context +# +sub pc_clean +{ + +} + +1; +__END__ -- 2.34.1