Menu
▾
▴
net-script-commits
|
From: Jan T. <de...@us...> - 2002-05-29 20:26:21
|
Update of /cvsroot/net-script/netscript2/src/perl/NetScript/Engine
In directory usw-pr-cvs1:/tmp/cvs-serv7957
Modified Files:
Class.pm State.pm StatementEvaluator.pm
Added Files:
Function.pm Member.pm
Log Message:
* added Member, Function and Class - classes
* added support for member-variables
--- NEW FILE: Function.pm ---
#--------------------------------------------------------
# $Id: Function.pm,v 1.1 2002/05/29 20:26:17 derkork Exp $
#
# NetScript and all related materials, such as documentation,
# are protected under the terms and conditions of the Artistic License.
# (C) 2000-2002 by Jan Thomä, insOMnia
# mailto: ko...@in...
#--------------------------------------------------------
use strict;
#/**
# This class represents a Function.
# @abstract
#*/
package NetScript::Engine::Function;
#--------------------------------------------------------
# Globals
#--------------------------------------------------------
#/**
# Ctor.
# @param the parent class object
#*/
sub new {
my ($proto, $parent) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
my $this = {};
bless( $this, $class ); # create Object
$this -> { m_Parent } = $parent; # parent class
return $this; # return Object
}
#/**
# Returns the parent class of this sub.
# @return an instance of <code>NetScript::Engine::Class</code>
#*/
sub parent {
my ( $this ) = @_;
$this -> { m_Parent };
}
#/**
# Sets the parent class of this sub.
# @param an instance of <code>NetScript::Engine::Class</code>
#*/
sub setParent {
my ( $this, $parent ) = @_;
$this -> { m_Parent } = $parent;
}
#/**
# Invokes this sub. A list of parameters is given as argument
# @optional one or more parameters
# @not-implemented
#*/
sub invoke {
}
1; # make "require" happy
--- NEW FILE: Member.pm ---
#--------------------------------------------------------
# $Id: Member.pm,v 1.1 2002/05/29 20:26:17 derkork Exp $
#
# NetScript and all related materials, such as documentation,
# are protected under the terms and conditions of the Artistic License.
# (C) 2000-2002 by Jan Thomä, insOMnia
# mailto: ko...@in...
#--------------------------------------------------------
use strict;
#/**
# This class represents a Member.
#*/
package NetScript::Engine::Member;
#--------------------------------------------------------
# Globals
#--------------------------------------------------------
#/**
# Ctor.
# @param the parent class object of this class
#*/
sub new {
my ($proto, $parent) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
my $this = {};
bless( $this, $class ); # create Object
$this -> { m_Parent } = $parent; # parent class
$this -> { m_Value } = "";
return $this; # return Object
}
#/**
# Returns the parent class of this sub.
# @return an instance of <code>NetScript::Engine::Class</code>
#*/
sub parent {
my ( $this ) = @_;
$this -> { m_Parent };
}
#/**
# Sets the parent class of this sub.
# @param an instance of <code>NetScript::Engine::Class</code>
#*/
sub setParent {
my ( $this, $parent ) = @_;
$this -> { m_Parent } = $parent;
}
#/**
# Returns the value of this member
#*/
sub value {
my ( $this ) = @_;
$this -> { m_Value };
}
#/**
# Sets the value of this member.
# @param a scalar holding the value of this member.
#*/
sub setValue {
my ( $this, $value ) = @_;
$this -> { m_Value } = $value;
}
1; # make "require" happy
Index: Class.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/Class.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Class.pm 15 May 2002 18:21:37 -0000 1.4
--- Class.pm 29 May 2002 20:26:17 -0000 1.5
***************
*** 11,14 ****
--- 11,15 ----
#/**
# This class represents a Class.
+ # @abstract
#*/
package NetScript::Engine::Class;
***************
*** 41,69 ****
#/**
! # Returns the given function, or sets it.
# @param function name
- # @optional an instance of Netscript::Engine::Function
# @return an instance of NetScript::Engine::Function
#*/
sub function {
! my ($this, $name, $function ) = @_;
! if ( defined( $function ) ) {
! $this -> { m_Functions } -> { $name } = $function;
! }
$this -> { m_Functions } -> { $name };
}
#/**
! # Returns the given member or sets it.
# @param member name
! # @optional an instance if Netscript::Engine::Variable
! # @return an instance of Netscript::Engine::Variable
#*/
sub member {
! my ($this, $name, $member) = @_;
! if ( defined( $member ) ) {
! $this -> { m_Members } -> { $name } = $member;
! }
$this -> { m_Functions } -> { $name };
}
--- 42,104 ----
#/**
! # Returns the given function.
# @param function name
# @return an instance of NetScript::Engine::Function
#*/
sub function {
! my ($this, $name ) = @_;
$this -> { m_Functions } -> { $name };
}
#/**
! # Sets the given function.
! # @param an instance of Netscript::Engine::Function
! #*/
! sub setFunction {
! my ($this, $function ) = @_;
! $this -> { m_Functions } -> { $function -> name() } = $function;
! $function -> setParent( $this );
! }
!
!
! #/**
! # Returns the given member.
# @param member name
! # @return an instance NetScript::Engine::Member
#*/
sub member {
! my ($this, $name) = @_;
$this -> { m_Functions } -> { $name };
+ }
+
+ #/**
+ # Sets the given member.
+ # @param an instance of NetScript::Engine::Member
+ #*/
+ sub setMember {
+ my ($this, $member) = @_;
+ $this -> { m_Members } -> { $member -> name() } = $member;
+ $member -> setParent( $this );
+ }
+
+
+ #/**
+ # Returns a reference to an array holding all functions
+ # defined in this class.
+ # @public
+ #*/
+ sub functions {
+ my ( $this ) = @_;
+ $this -> { m_Functions };
+ }
+
+ #/**
+ # Returns a reference to an array holding all members
+ # defined in this class
+ # @public
+ #*/
+ sub members {
+ my ( $this ) = @_;
+ $this -> { m_Members };
}
Index: State.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/State.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** State.pm 15 May 2002 18:21:37 -0000 1.4
--- State.pm 29 May 2002 20:26:17 -0000 1.5
***************
*** 39,49 ****
my %variables = ();
my %arrays = ();
$this -> { m_Variables } = \%variables;
$this -> { m_Arrays } = \%arrays;
# Set parent if parent is defined.
if (defined( $parent ) ) {
$this -> setParent( $parent );
}
!
return $this; # return Object
}
--- 39,52 ----
my %variables = ();
my %arrays = ();
+ my %objects = ();
$this -> { m_Variables } = \%variables;
$this -> { m_Arrays } = \%arrays;
+ $this -> { m_Objects } = \%objects;
+
# Set parent if parent is defined.
if (defined( $parent ) ) {
$this -> setParent( $parent );
}
!
return $this; # return Object
}
***************
*** 64,68 ****
sub getParent {
my ($this) = @_;
-
return $this -> { m_ParentState };
}
--- 67,70 ----
***************
*** 114,121 ****
return $parent -> arrayExists( $array );
}
! else {
! # no more parent state, so the array does not exist.
! return undef;
! }
}
# array exists in this state so return yourself.
--- 116,121 ----
return $parent -> arrayExists( $array );
}
! # no more parent state, so the array does not exist.
! return undef;
}
# array exists in this state so return yourself.
***************
*** 124,127 ****
--- 124,152 ----
#/**
+ # Checks if the object exists in current state. If not
+ # the check will be performed on the parent state.
+ # @param a string containing the object name
+ # @return a reference to the State which holds the object
+ # or undef, if the object is currently not known.
+ #*/
+ sub objectExists {
+ my ($this, $object) = @_;
+ my $parent = $this -> { m_ParentState };
+ my $result = $this -> { m_Objects } -> {$object};
+
+ # check if object exists in this state
+ if ( !defined( $result ) ) { # no it doesn't
+ if ( defined( $parent ) ) { # check for parent state
+ # try to get it from there
+ return $parent -> objectExists( $object );
+ }
+ # no more parent state, so the object does not exist.
+ return undef;
+ }
+ # object exists in this state so return yourself.
+ return $this;
+ }
+
+ #/**
# Sets the value of the given variable. Variable is
# first looked up in parent state, if it does exist there
***************
*** 132,136 ****
sub setVariableValue {
my ($this, $variable, $value) = @_;
-
# check if a parent state already knows this
# variable.
--- 157,160 ----
***************
*** 161,167 ****
return $variableHolder -> { m_Variables } -> { $variable };
}
! else {
! return undef;
! }
}
--- 185,190 ----
return $variableHolder -> { m_Variables } -> { $variable };
}
!
! return undef;
}
***************
*** 212,219 ****
return $variableHolder -> { m_Arrays } -> { $array } -> [$index];
}
! else {
! return undef;
}
}
1; # make "require" happy
--- 235,299 ----
return $variableHolder -> { m_Arrays } -> { $array } -> [$index];
}
! return undef;
! }
!
! #/**
! # Returns the largest index of the given array or undef, if no such
! # array exists.
! # @param the name of the array.
! # @return the largest valid index within the array.
! #*/
! sub getLargestArrayIndex {
! my ( $this, $array ) = @_;
! my $variableHolder = $this -> arrayExists( $array );
! if ( defined( $variableHolder ) ) {
! return scalar( @{$variableHolder -> { m_Arrays } -> { $array }} )-1;
! }
! undef;
! }
!
! #/**
! # Sets an object for the given name.The name
! # first looked up in parent state, if it does exist there
! # then it is set there, else it is set in current state.
! # @param a string containing the object name.
! # @param a scalar containing the value
! #
! #*/
! sub setObjectValue {
! my ($this, $object, $value) = @_;
!
! # check if a parent state already knows this
! # object
! my $variableHolder = $this -> objectExists( $object );
!
! if (defined( $variableHolder ) && $variableHolder != $this) {
! # Yes another one has it.
! $variableHolder -> setObjectValue( $object, $value );
! }
! else { # object is in this state or not defined at all
! $this -> { m_Objects } -> { $object } = $value;
! }
! }
!
! #/**
! # Returns the value of the given object . If this state
! # does not contain the object, parent states will be checked until the
! # object is found there, or the topmost state is reached.
! # @param a string containing the name of the object to look up.
! # @return a scalar holding the object or undef, if the
! # object is not defined.
! #*/
! sub getObjectValue {
! my ( $this, $object ) = @_;
!
! my $variableHolder = $this -> objectExists( $object );
! if ( defined( $variableHolder ) ) {
! return $variableHolder -> { m_Objects } -> { $object };
}
+ return undef;
}
+
+
1; # make "require" happy
Index: StatementEvaluator.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/StatementEvaluator.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** StatementEvaluator.pm 15 May 2002 18:21:37 -0000 1.5
--- StatementEvaluator.pm 29 May 2002 20:26:17 -0000 1.6
***************
*** 17,20 ****
--- 17,21 ----
use NetScript::Interpreter;
+ use NetScript::Libraries::DebugLibrary;
***************
*** 31,37 ****
# @final
#*/
! sub STRING_FILTER {
! "STRING";
! }
#/**
--- 32,36 ----
# @final
#*/
! our $STRING_FILTER = "STRING";
#/**
***************
*** 40,46 ****
# @final
#*/
! sub XML_FILTER {
! "XML";
! }
#/**
--- 39,43 ----
# @final
#*/
! our $XML_FILTER = "XML";
#/**
***************
*** 56,60 ****
my $this = {};
bless( $this, $class ); # create Object
! $this -> { m_interpreter } = @_;
return $this; # return Object
}
--- 53,57 ----
my $this = {};
bless( $this, $class ); # create Object
! $this -> { m_interpreter } = $interpreter;
return $this; # return Object
}
***************
*** 70,74 ****
my $aString = $statement;
my $stringBef = $statement;
-
#
# Look if this string consists of more than spaces
--- 67,70 ----
***************
*** 85,89 ****
# Quite hefty regexp. Does find the innermost pair parentheses which is not quoted.
! while ( $aString =~ /^(.*[^\\])\(((\\\(|\\\)|[^\(\)])*[^\\\)])?\)((\\\(|[^\(])*)$/ ) {
# Search for the innermost pair of parentheses.
my $pref = $1; # save string prefix
--- 81,87 ----
# Quite hefty regexp. Does find the innermost pair parentheses which is not quoted.
! # while ( $aString =~ /^(.*[^\\])\(((\\\(|\\\)|[^\(\)])*[^\\\)])?\)((\\\(|[^\(])*)$/ ) {
!
! while ( $aString =~ /^(.*[^\\])\(((\\\(|\\\)|[^\(\)])*[^\\\)]?)?\)((\\\(|[^\(])*)$/ ) {
# Search for the innermost pair of parentheses.
my $pref = $1; # save string prefix
***************
*** 92,143 ****
my $suff = $4; # save the string suffix
my $result = "";
-
# Unquote quoted parentheses
$param =~ s/\\\(/\(/g;
$param =~ s/\\\)/\)/g;
!
! # Find reserved words
! if ($pref =~ /^(.*)(\$|eval|@|str|\#)$/) {
! $pref = $1;
! $action = $2;
! }
! # Find quoted reserved words.
! if ($action ne '' && $pref =~ /^(.*)(\\)$/) {
! $action = $2.$action;
! $pref = $1;
}
! # now evaluate the action and generate a result.
! if ($action eq '$' ) { # a variable or array statement
! if ($param =~ /^([^:]+):(.*$)/) { # array statement
! $result = $this -> getArrayValue($1, $2);
! }
! else {
! $result = $this -> getVariableValue( $param );
# if (! defined($result)) {
# die "[standardlib] Error: undefined variable ", $param, "\n";
# }
}
! }
! elsif ($action eq 'eval') { # an eval-statement
! $result = eval($param);
! }
! elsif ($action eq '@') { #last index of an array
! $result = $this -> getLargestArrayIndex( $param );
! }
! elsif ($action eq '#') { #length of string
! $result = $this -> getStringLength( $param );
! }
! elsif ($action eq 'str') { # string-filter
! $result = $this -> filter( $param, $this -> STRING_FILTER() );
! }
! elsif ($action eq 'xml') { # xml-filter
! $result = $this -> filter( $param, $this -> XML_FILTER() );
! }
! elsif ($action =~ /^\\(.*)$/) { # requote
! $result = $1."\(".$param."\)";
}
else {
! $result = "\(".$param."\)";
}
# Requote remaining parentheses.
--- 90,135 ----
my $suff = $4; # save the string suffix
my $result = "";
# Unquote quoted parentheses
$param =~ s/\\\(/\(/g;
$param =~ s/\\\)/\)/g;
!
! # find a first dot representing a class
! if ( $param =~/^(.*?)\.(.*)$/ ) {
! $action = $1;
! $param = $2;
}
+
+ $this -> debug( "Pref: |$pref| Action: |$action| Param: |$param| Suff: |$suff|" );
! if ( $pref =~ /^(.*?[^\\]?)\$$/ ) {
! $pref = $1;
! # now evaluate the action and generate a result.
! if ($action eq '' ) { # a variable or array statement
! if ($param =~ /^([^:]+):(.*)$/) { # array statement
! $result = $this -> getArrayValue($1, $2);
! }
! else {
! $result = $this -> getVariableValue( $param );
# if (! defined($result)) {
# die "[standardlib] Error: undefined variable ", $param, "\n";
# }
}
! }
! elsif ($action eq 'eval') { # an eval-statement
! $result = eval($param);
! }
! elsif ($action eq '@') { #last index of an array
! $result = $this -> getLargestArrayIndex( $param );
! }
! elsif ($action eq '#') { #length of string
! $result = $this -> getStringLength( $param );
! }
! else {
! # return the member value of the given object
! $result = $this -> getMember( $action, $param );
! }
}
else {
! $result = "(".$param.")";
}
# Requote remaining parentheses.
***************
*** 162,166 ****
sub getVariableValue {
my ($this, $variable) = @_;
! "Wert: " . $variable;
}
--- 154,161 ----
sub getVariableValue {
my ($this, $variable) = @_;
! my $result = $this -> interpreter() -> getState() ->
! getVariableValue( $variable );
! # TODO: check for undef
! $result;
}
***************
*** 173,177 ****
sub getArrayValue {
my ($this, $array, $index) = @_;
! "Array [$index]: ". $array;
}
--- 168,176 ----
sub getArrayValue {
my ($this, $array, $index) = @_;
! my $result = $this -> interpreter() -> getState() ->
! getArrayValue( $array, $index );
! $this -> debug( "Getting array index: $array:$index = $result" );
! # TODO: check for undef
! $result;
}
***************
*** 183,211 ****
sub getLargestArrayIndex {
my ( $this, $array ) = @_;
! "10";
}
#/**
! # Returns the result of a function
! # @param the name of the function
! # @param the argument to the function
! # @return the value of the function.
! # @protected
#*/
! sub getFunctionResult {
! my ($this, $function, $arg ) = @_;
}
#/**
! # Filters the given scalar.
! # @param a scalar to filter.
! # @param a filter mode
! # @return the filtered string
! # @protected
#*/
! sub filter {
! my ($this, $toFilter, $mode) = @_;
! "Filtered ($mode): $toFilter";
}
--- 182,248 ----
sub getLargestArrayIndex {
my ( $this, $array ) = @_;
! my $result = $this -> interpreter() -> getState() ->
! getLargestArrayIndex( $array );
! # TODO: check for undef
! $result;
}
#/**
! # Returns the member of the given object.
! # @param the name of the object
! # @param the name of the member
#*/
! sub getMember {
! my ( $this, $object, $member ) = @_;
! my $object = $this -> interpreter() -> getState() ->
! getObjectValue( $object );
!
! $this -> debug( "Getting member: $member of $object..." );
! # $object is an instance of Class
! return undef unless $object ;
! my $memberObject = $object -> member( $member );
! return undef unless $memberObject;
! $memberObject -> value();
! }
!
! #/**
! # Creates the given variable (array).
! # @param string describing the variable name
! # @param string holding the variable value
! #*/
! sub createVariable {
! my ( $this, $name, $value ) = @_;
!
! if ( $name =~ /(^.*):(.*$)/ ) { # its an array
! $this -> interpreter() -> getState() ->
! setArrayValue( $1, $2, $value );
! }
! else {
! $this -> interpreter() -> getState() ->
! setVariableValue( $name, $value );
! }
}
+ #/**
+ # Returns an instance of <code>NetScript.:Interpreter</code>
+ #*/
+ sub interpreter {
+ my ( $this ) = @_;
+ $this -> { m_interpreter };
+ }
#/**
! # Sends a debug event.
! # @param the debug message
! # @private
#*/
! sub debug {
! my ($this, $message) = @_;
! $this -> interpreter() -> getEventRelay() ->
! createAndRaiseEvent(
! $NetScript::Libraries::DebugLibrary::DEBUG_EVENT,
! $message,
! "Control"
! );
}
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X