Menu
▾
▴
[NetScript CVS] CVS: netscript2/src/perl/NetScript/Engine ClassWrapper.pm,1.1,1.2 Function.pm,1.2,1.3 FunctionWrapper.pm,1.1,1.2 MemberWrapper.pm,1.2,1.3 StatementEvaluator.pm,1.10,1.11
|
From: Jan T. <de...@us...> - 2002-08-07 20:13:52
|
Update of /cvsroot/net-script/netscript2/src/perl/NetScript/Engine
In directory usw-pr-cvs1:/tmp/cvs-serv15655
Modified Files:
ClassWrapper.pm Function.pm FunctionWrapper.pm
MemberWrapper.pm StatementEvaluator.pm
Log Message:
* added database library
Index: ClassWrapper.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/ClassWrapper.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** ClassWrapper.pm 2 Jun 2002 19:31:23 -0000 1.1
--- ClassWrapper.pm 7 Aug 2002 20:13:48 -0000 1.2
***************
*** 35,41 ****
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
!
my $this = $class -> SUPER::new();
$this -> { m_Object } = $object;
return $this; # return Object
}
--- 35,42 ----
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
! my %userValues = ();
my $this = $class -> SUPER::new();
$this -> { m_Object } = $object;
+ $this -> { m_userValues } = \%userValues;
return $this; # return Object
}
***************
*** 49,58 ****
# @param the name of the sub which should be called upon invocation
# of the function.
#*/
sub setFunction {
! my ($this, $function, $subToCall ) = @_;
! my $wrapper = NetScript::Engine::FunctionWrapper -> new(
! $this -> object(), $function, $subToCall );
$this -> functions() -> { $function } = $wrapper;
}
--- 50,61 ----
# @param the name of the sub which should be called upon invocation
# of the function.
+ # @return the created functionWrapper object
#*/
sub setFunction {
! my ($this, $function, $subToCall, @paramNames ) = @_;
! my $wrapper = NetScript::Engine::FunctionWrapper -> new( $this,
! $this -> object(), $function, $subToCall, @paramNames );
$this -> functions() -> { $function } = $wrapper;
+ $wrapper;
}
***************
*** 67,70 ****
--- 70,74 ----
# @param the name of the sub to be called on setting of the member
# @param the name of the sub to be called on retrieval of the member.
+ # @return the created memberwrapper object
# @public
#*/
***************
*** 74,81 ****
$this -> object(), $subOnSetting, $subOnRetrieval );
$this -> members() -> { $member } = $memberWrapper;
}
! sub member {
my ( $this, $member ) = @_;
for ( keys( %{$this -> members() } ) ) {
--- 78,89 ----
$this -> object(), $subOnSetting, $subOnRetrieval );
$this -> members() -> { $member } = $memberWrapper;
+ $memberWrapper;
}
! #/**
! # Returns the member value or undef, if there is no such member...
! #*/
! sub getMember {
my ( $this, $member ) = @_;
for ( keys( %{$this -> members() } ) ) {
***************
*** 96,99 ****
--- 104,127 ----
my ( $this ) = @_;
$this -> { m_Object };
+ }
+
+
+ #/**
+ # This can be used to store user values in the object
+ # @param the name of the value
+ # @param the value of the value ;)
+ #*/
+ sub setUserValue {
+ my ( $this, $name, $value ) = @_;
+ $this -> { m_userValues } -> { $name } = $value;
+ }
+
+ #/**
+ # Retrieves a previously stored user value from the object.
+ # @param the name of the value to retrieve
+ #*/
+ sub getUserValue {
+ my ( $this, $name ) = @_;
+ $this -> { m_userValues } -> { $name };
}
Index: Function.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/Function.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Function.pm 11 Jul 2002 22:03:09 -0000 1.2
--- Function.pm 7 Aug 2002 20:13:49 -0000 1.3
***************
*** 26,30 ****
#*/
sub new {
! my ($proto, $parent) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
--- 26,30 ----
#*/
sub new {
! my ($proto, $parent, $name) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
***************
*** 34,38 ****
my @valueParameters = ();
my @referenceParameters = ();
! $this -> { m_Name } = "";
$this -> { m_Parent } = $parent; # parent class
$this -> { m_Code } = undef; # executable code
--- 34,38 ----
my @valueParameters = ();
my @referenceParameters = ();
! $this -> { m_Name } = $name;
$this -> { m_Parent } = $parent; # parent class
$this -> { m_Code } = undef; # executable code
Index: FunctionWrapper.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/FunctionWrapper.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** FunctionWrapper.pm 2 Jun 2002 19:31:23 -0000 1.1
--- FunctionWrapper.pm 7 Aug 2002 20:13:49 -0000 1.2
***************
*** 14,19 ****
#*/
package NetScript::Engine::FunctionWrapper;
! use base qw(NetScript::Engine::Function);
!
#--------------------------------------------------------
--- 14,18 ----
#*/
package NetScript::Engine::FunctionWrapper;
! use base qw(NetScript::Engine::Function);
#--------------------------------------------------------
***************
*** 24,53 ****
#/**
# Ctor.
- # @param the parent class object of this function.
# @param the object on which the sub should be invocated
# @param the sub to be called upon invocation of this function.
#*/
sub new {
! my ($proto, $parent, $object, $subToCall ) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
!
! my $this = $class -> SUPER::new( $parent );
$this -> { m_Object } = $object;
$this -> { m_SubToCall } = $subToCall;
return $this; # return Object
}
!
#/**
! # Invokes this sub. A list of parameters is given as argument
# @optional one or more parameters
#*/
sub invoke {
! my ( $this, @args ) = @_;
my $sub = $this -> { m_SubToCall };
! $this -> { m_Object } -> $sub( @args );
}
1; # make "require" happy
--- 23,81 ----
#/**
# Ctor.
# @param the object on which the sub should be invocated
# @param the sub to be called upon invocation of this function.
+ # @param the names of the parameters
#*/
sub new {
! my ($proto, $parent, $object, $name, $subToCall, @paramNames ) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
! my %userValues = ();
! my $this = $class -> SUPER::new( $parent, $name );
!
! $this -> { m_userValues } = \%userValues;
$this -> { m_Object } = $object;
$this -> { m_SubToCall } = $subToCall;
+ $this -> { m_paramNames } = \@paramNames;
return $this; # return Object
}
! #/**
! # Returns a reference to list of parameter names for this function.
! #*/
! sub getParameters {
! my ( $this ) = @_;
! return $this -> { m_paramNames };
! }
#/**
! # Invokes this sub. A hash of parameters is given as argument
# @optional one or more parameters
#*/
sub invoke {
! my ( $this, %args ) = @_;
my $sub = $this -> { m_SubToCall };
! $this -> { m_Object } -> $sub( $this, %args );
! }
!
! #/**
! # This can be used to store user values in the object
! # @param the name of the value
! # @param the value of the value ;)
! #*/
! sub setUserValue {
! my ( $this, $name, $value ) = @_;
! $this -> { m_userValues } -> { $name } = $value;
! }
!
! #/**
! # Retrieves a previously stored user value from the object.
! # @param the name of the value to retrieve
! #*/
! sub getUserValue {
! my ( $this, $name ) = @_;
! $this -> { m_userValues } -> { $name };
}
+
1; # make "require" happy
Index: MemberWrapper.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/MemberWrapper.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** MemberWrapper.pm 11 Jul 2002 22:03:09 -0000 1.2
--- MemberWrapper.pm 7 Aug 2002 20:13:49 -0000 1.3
***************
*** 35,40 ****
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
!
my $this = $class -> SUPER::new( $parent );
$this -> { m_Name } = "";
$this -> { m_SubOnSetting } = $subOnSetting;
--- 35,41 ----
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
! my %userValues = ();
my $this = $class -> SUPER::new( $parent );
+ $this -> { m_userValues } = \%userValues;
$this -> { m_Name } = "";
$this -> { m_SubOnSetting } = $subOnSetting;
***************
*** 60,64 ****
my ( $this ) = @_;
my $sub = $this -> { m_SubOnRetrieval };
! $this -> { m_Object } -> $sub ( $this -> { m_Name } );
}
--- 61,65 ----
my ( $this ) = @_;
my $sub = $this -> { m_SubOnRetrieval };
! $this -> { m_Object } -> $sub ( $this, $this -> { m_Name } );
}
***************
*** 70,74 ****
my ( $this, $value ) = @_;
my $sub = $this -> { m_SubOnSetting };
! $this -> { m_Object } -> $sub( $this -> { m_Name }, $value );
}
--- 71,75 ----
my ( $this, $value ) = @_;
my $sub = $this -> { m_SubOnSetting };
! $this -> { m_Object } -> $sub( $this, $this -> { m_Name }, $value );
}
***************
*** 81,89 ****
my ( $this ) = @_;
my $clone = NetScript::Engine::MemberWrapper -> new (
! $this -> parent(), $this -> { m_Object },
$this -> { m_SubOnSetting }, $this -> { m_SubOnRetrieval }
);
$clone;
}
1; # make "require" happy
--- 82,110 ----
my ( $this ) = @_;
my $clone = NetScript::Engine::MemberWrapper -> new (
! $this -> getParent(), $this -> { m_Object },
$this -> { m_SubOnSetting }, $this -> { m_SubOnRetrieval }
);
$clone;
}
+
+ #/**
+ # This can be used to store user values in the object
+ # @param the name of the value
+ # @param the value of the value ;)
+ #*/
+ sub setUserValue {
+ my ( $this, $name, $value ) = @_;
+ $this -> { m_userValues } -> { $name } = $value;
+ }
+
+ #/**
+ # Retrieves a previously stored user value from the object.
+ # @param the name of the value to retrieve
+ #*/
+ sub getUserValue {
+ my ( $this, $name ) = @_;
+ $this -> { m_userValues } -> { $name };
+ }
+
1; # make "require" happy
Index: StatementEvaluator.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/StatementEvaluator.pm,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** StatementEvaluator.pm 11 Jul 2002 22:03:09 -0000 1.10
--- StatementEvaluator.pm 7 Aug 2002 20:13:49 -0000 1.11
***************
*** 185,192 ****
# continue until all is resolved
while ( $toResolve =~ /^([^\.]+)\.?(.*)$/ ) {
my $memberName = $1;
$toResolve = $2;
!
# we got a MEMBER in $object, so we now extract its value
# which must be a CLASS
--- 185,193 ----
# continue until all is resolved
+ warn "toResolve: $toResolve";
while ( $toResolve =~ /^([^\.]+)\.?(.*)$/ ) {
my $memberName = $1;
$toResolve = $2;
! warn "splitted: member=$memberName, toResolve=$toResolve, index=$index";
# we got a MEMBER in $object, so we now extract its value
# which must be a CLASS
***************
*** 199,205 ****
$index = -1;
! if ( $memberName =~ /^([^:])+:([0-9]+)$/ ) {
$memberName = $1;
$index = $2;
}
--- 200,207 ----
$index = -1;
! if ( $memberName =~ /^([^:]+):([0-9]+)$/ ) {
$memberName = $1;
$index = $2;
+ warn "Is Array: Splitting: MemberName=$memberName, index=$index"
}
***************
*** 217,220 ****
--- 219,226 ----
return undef;
}
+ }
+
+ if ( $index != -1 ) {
+ $object = $object -> getValue() -> [ $index ]; # is an array
}
|
