这是一个软件 PERL语言的接口，有可能把它改成VB接口

[ok48]

这是一个软件 PERL语言的接口，有可能把它改成VB接口么？？？









=head
Package for running Perl programs in a Genesis environment.

This file is included by Genesis.pm.
See Genesis.pm for general documentation.

=cut
require 5.003;
require Exporter;
require 'shellwords.pl';
my $version = '2.0';

use Socket;
@ISA = qw(Exporter);


$socketOpen = 0 ;
$DIR_PREFIX = '@%#%@' ;

END {
if ($socketOpen == 0 ) {
return ;
}
send(SOCK, "${DIR_PREFIX}CLOSEDOWN \n", 0);
close (SOCK) || warn "close: $!";
}

sub new {
local $class = shift; # name
local $remote = shift;
local $genesis;

$remote = 'localhost' unless defined $remote;

# If standard input is not a terminal then we are a pipe to csh, and hence
# presumably running under Genesis. In this case use stdin and stdout as is.
# If, on the other hand, stdin is a tty, then we are running remotely, in which case
# set up the communications, namely the socket, so that we communicate.

$genesis->{remote} = $remote;
$genesis->{port} = 'genesis';

bless $genesis, $class;

$genesis->{comms} = 'pipe';
if (-t STDIN) {
$genesis->{comms} = 'socket';
$genesis->openSocket();
$genesis->{socketOpen} = 1;
$genesis->inheritEnvironment();
}
binmode(STDOUT);
return $genesis;
}
sub closeDown {
local ($genesis) = shift;
$genesis->sendCommand("CLOSEDOWN","");
}

sub inheritEnvironment {
local ($genesis) = shift;
$genesis->sendCommand("GETENVIRONMENT","");
while (1) {
$reply = $genesis->getReply();
if ($reply eq 'END') {
last;
}
($var,$value) = split('=',$reply,2);
$ENV{$var} = $value;
}
# And here is a patch for LOCALE. IBM AIX defines LC_MESSAGES and LC__FASTMSG
# which are not right if you are running remotely
undef $ENV{LC_MESSAGES};
undef $ENV{LC__FASTMSG};
}

=head
sub DESTROY {
local ($genesis) = shift;
$socketOpen -- ; # reduce reference count
if ($socketOpen) {
return ;
}
if ($genesis->{socketOpen}) {
$genesis->closeDown() ;
close (SOCK) || warn "close: $!";;
}
}
=cut


sub openSocket {
local ($genesis) = shift;
local ($remote,$port, $iaddr, $paddr, $proto);
$socketOpen ++ ;
return if $socketOpen != 1 ;
$port = $genesis->{port} ;
$remote = $genesis->{remote};

if ($port =~ /\D/) {
$port = getservbyname($port, 'tcp');
}

if (! defined $port) {
$port = 56753;
# The port has not been defined. To define it you need to
# become root and add the following line in /etc/services
# genesis 56753/tcp # Genesis port for debugging perl scripts
}
$iaddr = inet_aton($remote) || die "no host: $remote";
$paddr = sockaddr_in($port, $iaddr);
$proto = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
connect(SOCK, $paddr) || die "connect: $!";
}



# remove excess white space
sub removeNewlines {
local($command) = shift;
$command =~ s/\n\s*/ /g;
return $command;
}

# send the command to be executed
sub sendCommand {
local($genesis) = shift;
local $commandType = shift;
local $command = shift;

$genesis->blankStatusResults();
if ($genesis->{comms} eq 'pipe') {
$genesis->sendCommandToPipe($commandType,$command);
} elsif ($genesis->{comms} eq 'socket') {
$genesis->sendCommandToSocket($commandType,$command);
}
}

sub sendCommandToPipe {
local($genesis) = shift;
local $commandType = shift;
local $command = shift;
local $old_select = select (STDOUT);
local $flush_status = $|; # save the flushing status
$| = 1; # force flushing of the io buffer
print $DIR_PREFIX, "$commandType $command\n";
$| = $flush_status; # restore the original flush status
select ($old_select);
}

sub sendCommandToSocket {
local($genesis) = shift;
local $commandType = shift;
local $command = shift;
send(SOCK, "${DIR_PREFIX}$commandType $command\n", 0);
# should check for errors here !!!
}

# wait for the reply
sub getReply {
local $reply;
if ($genesis->{comms} eq 'pipe') {
chomp ($reply = <STDIN>); # chop new line character
} elsif ($genesis->{comms} eq 'socket') {
chomp ($reply = <SOCK>); # chop new line character
}
return $reply;
}

# Checking is on. If a command fails, the script fail
sub VON {
local ($genesis) = shift;
$genesis->sendCommand("VON", "");
}


# Checking is off. If a command fails, the script continues
sub VOF {
local ($genesis) = shift;
$genesis->sendCommand("VOF", "");
}


# Allow Genesis privileged activities. Normally this is executed at the
# start of each script.
sub SU_ON {
local ($genesis) = shift;
$genesis->sendCommand("SU_ON", "");
}

sub SU_OFF {
local ($genesis) = shift;
$genesis->sendCommand("SU_OFF", "");
}
sub blankStatusResults {
local ($genesis) = shift;
undef $genesis->{STATUS};
undef $genesis->{READANS};
undef $genesis->{PAUSANS};
undef $genesis->{MOUSEANS};
undef $genesis->{COMANS};
}

# Wait for a reply from a popup
sub PAUSE {
local ($genesis) = shift;
local ($command) = @_;
$genesis->sendCommand("PAUSE", removeNewlines($command));
$genesis->{STATUS} = getReply();
$genesis->{READANS} = getReply();
$genesis->{PAUSANS} = getReply();
}

# Get the mouse position
sub MOUSE {
local ($genesis) = shift;
local ($command) = @_;
$genesis->sendCommand("MOUSE", removeNewlines($command));
$genesis->{STATUS} = getReply();
$genesis->{READANS} = getReply();
$genesis->{MOUSEANS} = getReply();
}

# Send a command
sub COM {
local ($genesis) = shift;
local $command;
if (@_ == 1) {
($command) = @_;
$genesis->sendCommand("COM",removeNewlines($command));
} else {
$command = shift;
local %args = @_;
foreach (keys %args) {
$command .= ",$_=$args{$_}";
}
$genesis->sendCommand("COM", $command);
}
$genesis->{STATUS} = getReply();
$genesis->{READANS} = getReply();
$genesis->{COMANS} = $genesis->{READANS};
}

# Send an auxiliary command
sub AUX {
local ($genesis) = shift;
local $command;
if (@_ == 1) {
($command) = @_;
$genesis->sendCommand("AUX", removeNewlines($command));
} else {
$command = shift;
local %args = @_;
foreach (keys %args) {
$command .= ",$_=$args{$_}";
}
$genesis->sendCommand("AUX", $command);
}
$genesis->{STATUS} = getReply();
$genesis->{READANS} = getReply();
$genesis->{COMANS} = $genesis->{READANS};
}

# Get some basic info
# It is received in the form of a csh script, so the information needs
# hacking to get into a form suitable for perl

sub DO_INFO {
local ($genesis) = shift;
local $info_pre = "info,out_file=\$csh_file,write_mode=replace,args=";
local $info_com = "$info_pre @_ -m SCRIPT";
$genesis->parse($info_com);
}


sub parse {
local ($genesis) = shift;
local($request) = shift;
local $csh_file = "$ENV{GENESIS_DIR}/share/tmp/info_csh.$$";
$request =~ s/\$csh_file/$csh_file/;

$genesis->COM ($request);

open (CSH_FILE, "$csh_file") or warn "Cannot open info file - $csh_file: $!\n";
while (<CSH_FILE>) {
chomp;
next if /^\s*$/; # ignore blank lines
($var,$value) = /set\s+(\S+)\s*=\s*(.*)\s*/; # extract the name and value

$value =~ s/^\s*|\s*$//g; # remove leading and trailing spaces from the value
$value =~ s/\cM/<^M>/g; # change ^M temporarily to something else
# This happens mainly in giSEP, and shellwords makes it disappear

@value = shellwords($_);

# Deal with an csh array differently from a csh scalar
if ($value =~ /^\(/ ) {
$value =~ s/^\(|\)$//g; # remove leading and trailing () from the value
@words = shellwords($value); # This is a standard part of the Perl library
grep {s/\Q<^M>/\cM/g} @words;
$genesis->{doinfo}{$var} = [@words];
} else {
$value =~ s/\Q<^M>/\cM/g;
$value =~ s/^'|'$//g;
$genesis->{doinfo}{$var} = $value;
}
}
close (CSH_FILE);
unlink ($csh_file);
}

sub INFO {
local ($genesis) = shift;
local %args = @_;
local ($entity_path, $data_type, $parameters,
$serial_number, $options, $help, $entity_type, $units) = ("","","","","","","","");
local $i;
foreach (keys %args) {
$i = $args{$_};
if ($_ eq "entity_type") {
$entity_type = "-t $i";
} elsif ($_ eq "entity_path") {
$entity_path = "-e $i";
} elsif ($_ eq "data_type") {
$data_type = "-d $i";
} elsif ($_ eq "parameters") {
$parameters = "-p $i";
} elsif ($_ eq "serial_number") {
$serial_number = "-s $i";
} elsif ($_ eq "options") {
$options = "-o $i";
} elsif ($_ eq "help") {
$help = "-help";
} elsif ($_ eq "units") {
$units = "units=$i,";
}
}

local $info_pre = "info,out_file=\$csh_file,write_mode=replace,${units}args=";
local $info_com = "$info_pre $entity_type $entity_path $data_type "
. "$parameters $serial_number $options $help";

$genesis->parse($info_com);
}


sub clearDoinfo {
local ($me) = shift;
undef $me->{doinfo};
}


1;

[ok48]

Genesis.pm 文件


=head
Package for running Perl programs in a Genesis/Enterprise environment.

Usage
use Genesis;
use Genesis('122.12.1.87');
$f = new Genesis;

$f->COM($command);

This module enables Genesis/Enterprise scripts in perl.
It also supports debugging from an xterm, or remote terminal. When running the perl
script from inside Genesis, simply choose the relevant script from the
"Script Run" screen.

To run or debugging a script from an xterm, go the "Script Run" screen,
and choose the script called server.pl. This script sets up a socket which waits
for commands from the perl script to be debugged.
Having started the script server.pl, open up an xterm and start debugging the script.

The conventions in the Perl script are slightly different from the csh equivalent.

The start of the each perl script must begin with

use Genesis;

To access this library do *one* of the following:
The options appear in the order of recommendation.

* Copy Genesis.pm into the normal Perl library
* Add the path of Genesis.pm to PERL5LIB
* Type "use lib qw(/pathname)" -- where /pathname must be the directory where the file
Genesis.pm resides -- in each of your genesis scripts.
The line 'use lib' must appear before the line 'use Genesis'.

The next line should be

$f = new Genesis;

$f is simply a variable that you can choose.

The public functions are:
VON, VOF, SU_ON, SU_OFF, PAUSE, MOUSE, COM, AUX, DO_INFO, and INFO

They are invoked in the object oriented way. Here is an example of the PAUSE command
$f->PAUSE($text);

Now let's deal with variables created when using DO_INFO.
Unlike the csh, the variables are put into the the structure
pointed to by $f.

A call to "DOINFO" which reutnrs a value of "gEXISTS" would be referenced as
$f->{doinfo}{gEXISTS}. If an array were to be received, the elements could be referenced as
$f->{doinfo}{gWIDTHS}[$i].

Similary, the return results are called STATUS, READANS, PAUSANS, MOUSEANS and COMANS.
For the meantime these can be read using $f->{STATUS} etc.

BUGS

1. In debug mode: If the Abort button is pressed in Pause, the script does not terminate.

2. Every time an external script is started the Apply button has to be pressed to
restart the server side.

3. During debugging of the Perl script the Genesis editor is not updated.

Split into two files & revamped: 3 July 1997, Ben Michelson
Hacked out of all reconition, Peter Gordon
Original Version: 8 Nov 1996, Herzl Rejwan
=cut
package Genesis;

if (defined $ENV{GENESIS_DIR}) {
$_genesis_root = $ENV{GENESIS_DIR};
} else {
$_genesis_root = "/genesis";
}

if (defined $ENV{GENESIS_EDIR}) {
$_genesis_edir = $ENV{GENESIS_EDIR};
} else {
$_genesis_edir = "e$ENV{GENESIS_VER}";
}

if ($_genesis_edir !~ m#^([A-Z]:)?[/\\]#i) {
$_genesis_edir = "$_genesis_root/$_genesis_edir";
}

require "$_genesis_edir/all/perl/Genesis.pl";