Menu
▾
▴
[NetScript CVS] CVS: netscript2/src/perl/NetScript/Engine EventListener.pm,NONE,1.1 BasicStatement.pm,1.2,1.3 DOMWalker.pm,1.1,1.2 Event.pm,1.3,1.4 EventRelay.pm,1.4,1.5
|
From: Jan T. <de...@us...> - 2002-05-09 19:11:10
|
Update of /cvsroot/net-script/netscript2/src/perl/NetScript/Engine
In directory usw-pr-cvs1:/tmp/cvs-serv25828
Modified Files:
BasicStatement.pm DOMWalker.pm Event.pm EventRelay.pm
Added Files:
EventListener.pm
Log Message:
* re-implemented DOMWalker
* re-implemented Event System
* added EventListener
--- NEW FILE: EventListener.pm ---
#--------------------------------------------------------
# $Id: EventListener.pm,v 1.1 2002/05/09 19:11:03 derkork Exp $
#
# Class EventListener
# 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;
#/**
# An EventListener listens to an event and calls a method of an
# object, when receiving the event. The event listener decides
# whether it consumes the event or releases it to be sent to
# other event listeners.
#*/
package NetScript::Engine::EventListener;
use vars qw($VERSION);
#--------------------------------------------------------
# Imports
#--------------------------------------------------------
use NetScript::Engine::Event;
#--------------------------------------------------------
# Globals
#--------------------------------------------------------
$VERSION = '1.0';
#/**
# Constant for "Listener should be informed first".
# @public
# @final
#*/
sub PRIORITY_FIRST { 1; }
#/**
# Constant for "Listener should be informed last".
# @public
# @final
#*/
sub PRIORITY_LAST { 2; }
#/**
# Ctor.
# @public
#*/
sub new {
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
# Create a Class using the Hash-As-An-Object-Idiom
my $this = {};
bless( $this, $class ); # create Object
$this -> { m_Object } = undef;
$this -> { m_Sub } = undef;
$this -> { m_EventType } = undef;
$this -> { m_Priority } = 0;
return $this; # return Object
}
#/**
# Initialises the event listener.
# @param a scalar holding the event type to which this listener
# should listen.
# @param the name of the callback method that should be called
# upon receipt of an event of the appropriate type. Callback
# methods have to return a boolean value specifying whether
# the event should be consumed or not.
# @param an object on which the callback method should be called
# @optional a scalar holding one of these:
# <ul><li><code>PRIORITY_FIRST</code> - specifies that the listener
# should be informed before all other listeners.</li>
# <li><code>PRIORITY_LAST</code> - specifies, that the listener
# should be informed after all other listeners.</li></ul>
# If this parameter is not specified the order is arbitrary. If
# more than one listener wants to be informed first or last on the
# same event, the order is also arbitrary. Use with caution.
# @public
#*/
sub init {
my ( $this, $eventType, $sub, $object, $priority ) = @_;
$this -> { m_Object } = $object;
$this -> { m_Sub } = $sub;
$this -> { m_EventType } = $eventType;
$this -> { m_Priority } = $priority;
}
#/**
# Returns the Event type to which this listener is listening.
# @public
#*/
sub eventType {
my ( $this ) = @_;
$this -> { m_EventType };
}
#/**
# Returns the priority of this listener.
# @public
#*/
sub priority {
my ($this) = @_;
$this -> { m_Priority };
}
#/**
# Fires the Event to the attached object.
# @param an instance of <code>NetScript::Engine::Event</code>
# @return a boolean value specifying if the event was consumed or not.
# @public
#*/
sub fireEvent {
my ( $this, $event ) = @_;
my $object = $this -> { m_Object };
my $sub = $this -> { m_Sub };
$object -> $sub( $event );
}
1; # make "require" happy
Index: BasicStatement.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/BasicStatement.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** BasicStatement.pm 26 Apr 2002 10:49:06 -0000 1.2
--- BasicStatement.pm 9 May 2002 19:11:03 -0000 1.3
***************
*** 35,39 ****
#*/
sub new {
! my ($proto, $argsRef) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
--- 35,39 ----
#*/
sub new {
! my ($proto) = @_;
my $proto = shift; # get Prototype
my $class = ref( $proto ) || $proto;# get the Classname
***************
*** 60,64 ****
#/**
# Returns a copy of the node. Additionally replaces
! # variables in text nodes,
# @todo Support for ProcessingInstruction
# @return the value of the statement (XML::DOM2::Node)
--- 60,65 ----
#/**
# Returns a copy of the node. Additionally replaces
! # variables in text nodes, ProcessingInstractions, Element
! # attributes and comments.
# @todo Support for ProcessingInstruction
# @return the value of the statement (XML::DOM2::Node)
Index: DOMWalker.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/DOMWalker.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** DOMWalker.pm 26 Apr 2002 10:49:06 -0000 1.1
--- DOMWalker.pm 9 May 2002 19:11:03 -0000 1.2
***************
*** 13,18 ****
#/**
# The DOMWalker is the main executing Instance of the Interpreter
! # It walks over the incoming DOM, evaluates the Nodes and creates
! # the Result-DOM, which is then written out.
# @final
#*/
--- 13,21 ----
#/**
# The DOMWalker is the main executing Instance of the Interpreter
! # It walks over the incoming DOM, and throws out events for each
! # Node. The event listeners can then process the events and insert
! # Nodes into the target document and/or modify the source node of
! # the source document. The events contain the Walker itself als
! # EventUnknown.
# @final
#*/
***************
*** 26,33 ****
#/**
# Ctor.
# @param an instance of NetScript::Interpreter.
# @public
- # @final
#*/
sub new {
--- 29,77 ----
#/**
+ # Event which is generated upon start of an element.
+ # @public
+ # @final
+ #*/
+ sub ELEMENT_START_EVENT { "DOMWALKER_ELEMENT_START_EVENT"; }
+
+ #/**
+ # Event which is generated upon end of an element.
+ # @public
+ # @final
+ #*/
+ sub ELEMENT_END_EVENT { "DOMWALKER_ELEMENT_END_EVENT"; }
+
+ #/**
+ # Event which is generated upon encounter of a processing instruction.
+ # @public
+ # @final
+ #*/
+ sub PI_EVENT { "DOMWALKER_PI_EVENT"; }
+
+ #/**
+ # Event which is generated upon encounter of any other node.
+ # @public
+ # @final
+ #*/
+ sub OTHER_NODE_EVENT { }
+
+ #/**
+ # Event which is generated upon encounter of a text node
+ # @public
+ # @final
+ #*/
+ sub TEXT_EVENT { "DOMWALKER_TEXT_EVENT"; }
+
+ #/**
+ # Event which is generated upon encounter of comment node.
+ # @public
+ # @final
+ #*/
+ sub COMMENT_EVENT { "DOMWALKER_COMMENT_EVENT"; }
+
+ #/**
# Ctor.
# @param an instance of NetScript::Interpreter.
# @public
#*/
sub new {
***************
*** 37,248 ****
my $this = {};
! $this -> { m_basicStatement } =
NetScript::Engine::BasicStatement -> new();
$this -> { m_interpreter } = $interpreter;
- bless( $this, $class ); # create Object
return $this; # return Object
}
#/**
! # This sub walks over the given DOM and returns a result
! # DOM.The given DOM remains unchanged
! # @param an instance of XML::DOM2::Document
! # @return an instance of XML::DOM2::Document
# @public
- # @final
#*/
! sub walkOver {
! my ( $this, $document ) = @_;
!
! # Save the document
! $this -> { m_document } = $document;
! my $di = XML::DOM2::DOMImplementation -> new();
!
! # Create a result document
! my $newDocument = $di -> createDocument( {
! namespaceURI => "dummy",
! qualifiedName => "dummy"
! });
! $this -> { m_resultDocument } = $newDocument;
!
! # save the reference node
! $this -> referenceNode( $newDocument );
! $newDocument -> removeChild( {
! oldChild => $newDocument -> documentElement()
! });
! # start processing from up till down, recursively
! $this -> startProcess( $document );
!
! $newDocument;
}
#/**
! # Processes an level within the tree.
! # @private
#*/
! sub startProcess {
my ( $this, $node ) = @_;
!
! #we got a node, process it, then process its children...
! if ( $node -> nodeType() == XML::DOM2::Node -> ELEMENT_NODE() ||
! $node -> nodeType() == XML::DOM2::Node -> DOCUMENT_NODE() ) {
!
! unless( $node -> nodeType == XML::DOM2::Node -> DOCUMENT_NODE() ) {
! $this -> processElement( $node );
! }
! # process the children
! my $children = $node -> childNodes();
! my $length = $children -> length();
!
! for ( 0..$length-1 ) {
! $this -> startProcess( $children -> item ( {
! index => $_
! } ) );
! }
!
! unless( $node -> nodeType == XML::DOM2::Node -> DOCUMENT_NODE() ) {
! $this -> elementFinished();
! }
! }
! elsif ( $node -> nodeType() == XML::DOM2::Node ->
! PROCESSING_INSTRUCTION_NODE() ) {
! $this -> processProcessingInstruction( $node );
! }
! else {
! $this -> processSimpleNode( $node );
! }
}
-
#/**
! # Processes a processing instruction. All processing instructions
! # which are related to netscript look this way:
! # <code><?netscript command [parameter [parameter] ...]?></code>
! # These PIs are executed but not copied to the destination tree.
! # Parameters are separated by spaces. Non-NetScript-related PIs are
! # just copied.
! # @private
! # @param an instance of XML::DOM2::ProcessingInstruction
#*/
! sub processProcessingInstruction {
! my ( $this, $pi ) = @_;
! my $target = $pi -> target();
!
! if ( $target eq "netscript" ) {
! my $data = $pi -> data();
!
! }
! else {
! # no netscript pi so just copy it.
! #import the node to the new document
! $this -> processSimpleNode( $pi );
! }
}
#/**
! # Processes a simple node. Simple nodes have no function.
! # They are just copied to the destination document and
! # variables within them are replaced.
! # @private
! # @param an instance of XML::DOM2::Node or its descendants
#*/
! sub processSimpleNode {
! my ( $this, $node ) = @_;
! $this -> basicStatement() -> init(
! $this -> interpreter(),
! $node,
! $this -> result() );
! $this -> referenceNode() -> appendChild( {
! newChild => $this -> basicStatement() -> evaluate()
! });
}
#/**
! # Processes an Element node.
! # @private
! # @param an instance of XML::DOM2::Element
#*/
! sub processElement {
! my ($this, $element) = @_;
!
! # copy node
! $this -> basicStatement() -> init(
! $this -> interpreter(),
! $element,
! $this -> result() );
! my $copy = $this -> basicStatement() -> evaluate();
- # append to reference node
- $this -> referenceNode() -> appendChild({
- newChild => $copy
- });
! #set as new reference node
! $this -> referenceNode( $copy ) ;
}
#/**
! # Finishes the current reference node.
! # @private
#*/
! sub elementFinished {
! my ($this) = @_;
! # set the parent of the current reference node as new reference node
! $this -> referenceNode( $this -> referenceNode() -> parentNode() );
}
#/**
! # Returns the source document.
# @public
- # @return an instance of XML::DOM2::Document
#*/
! sub document {
my ( $this ) = @_;
! $this -> { m_document };
}
#/**
! # Returns the result document.
# @public
- # @return an instance of XML::DOM2::Document
#*/
! sub result {
! my ( $this ) = @_;
! $this -> { m_resultDocument };
}
#/**
! # Returns or sets the current reference node in the result document.
# @private
- # @optional an instance of XML::DOM2::Node
- # @return an instance of XML::DOM2::Node
#*/
! sub referenceNode {
! my ( $this, $node ) = @_;
! if ( $node ) {
! $this -> { m_referenceNode } = $node;
}
! $this -> { m_referenceNode };
! }
#/**
! # Returns an instance of NetScript::Engine::BasicStatement
! # @return an instance of NetScript::Engine::BasicStatement
# @private
#*/
! sub basicStatement {
! my ( $this ) = @_;
! $this -> { m_basicStatement };
}
!
#/**
! # Returns the interpreter.
! # @return an instance of NetScript::Interpreter.
! # @private
#*/
! sub interpreter {
! my ( $this ) = @_;
! $this -> { m_interpreter };
}
--- 81,327 ----
my $this = {};
! bless( $this, $class ); # create Object
! $this -> { m_currentSourceNode } = undef;
! $this -> { m_currentTargetNode } = undef;
!
! $this -> { m_basicStatement } =
NetScript::Engine::BasicStatement -> new();
+ my %markedNodes = ();
+ $this -> { m_markedNodes } = \%markedNodes;
+
$this -> { m_interpreter } = $interpreter;
return $this; # return Object
}
+
#/**
! # Marks the current node in the source document.
! # Returns an ID which can be used to retrieve
! # the node.
! # @return a scalar holding an ID
# @public
#*/
! sub markCurrentSource {
! my ( $this ) = @_;
! $this -> markNode( $this -> currentSource() );
! }
! #/**
! # Marks the current node in the Target document.
! # Returns an ID which can be used to retrieve
! # the node.
! # @return a scalar holding an ID
! # @public
! #*/
! sub markCurrentTarget {
! my ( $this ) = @_;
! $this -> markNode( $this -> currentTarget() );
}
#/**
! # Marks the given node.
! # @param an instance of <code>XML::DOM2::Node</code>
! # @return an ID which can be used to retrieve the node.
! # @public
#*/
! sub markNode {
my ( $this, $node ) = @_;
! my $uid = $this -> interpreter() -> getUID();
! $this -> { m_markedNodes } -> { $uid } = $node;
! $uid;
}
#/**
! # Returns a marked node.
! # @param an ID for the previously marked node.
! # @return an instance of <code>XML::DOM2::Node</code>
! # @public
#*/
! sub markedNode {
! my ( $this, $uid ) = @_;
! $this -> { m_markedNodes } -> { $uid };
}
#/**
! # Removes a mark from a node.
! # @param an ID for the previously marked node.
! # @public
#*/
! sub clearMark {
! my ($this, $uid) = @_;
! delete ( $this -> { m_markedNodes } -> { $uid } );
}
#/**
! # Retrieves or sets the current node in the source document.
! # @optional an instance of <code>XML::DOM2::Node</code>
! # @return an instance of <code>XML::DOM2::Node</code>
! # @public
#*/
! sub currentSource {
! my ( $this, $newNode ) = @_;
! if ( defined( $newNode ) ) {
! $this -> { m_currentSourceNode } = $newNode;
! }
! $this -> { m_currentSourceNode };
! }
! #/**
! # Retrieves or sets the current node in the target document.
! # @optional an instance of <code>XML::DOM2::Node</code>
! # @return an instance of <code>XML::DOM2::Node</code>
! # @public
! #*/
! sub currentTarget {
! my ( $this, $newNode ) = @_;
! if ( defined( $newNode ) ) {
! $this -> { m_currentTargetNode } = $newNode;
! }
! $this -> { m_currentTargetNode };
}
+
#/**
! # Inserts a node into the target document. The given node will be cloned
! # and inserted into the target document. The function returns the
! # clone. Text nodes, Element attributes, Processing Instructions and
! # comments are searched for variables. These will be replaced with their
! # values.
! # @param <code>an instance of XML::DOM2::Node</code>
! # @optional a bool value; true - if the newly inserted node becomes
! # the reference target node; false -else (this flag is only valid if
! # the given node is an <code>XML::DOM2::Element</code>)
! # @public
#*/
! sub insertIntoTarget {
! my ( $this, $node, $isRefNode ) = @_;
! my $currentNode = $this -> currentTarget();
! my $document = $currentNode -> ownerDocument();
! $this -> basicStatement() -> init(
! $this -> interpreter(), $node, $document );
!
! my $clone = $this -> basicStatement() -> evaluate();
!
! # append clone to document
! $this -> currentTarget() -> appendChild( {
! newChild => $clone
! });
!
! # set current target node to new node
! if ( $clone -> nodeType() == XML::DOM2::Node -> ELEMENT_NODE() &&
! $isRefNode ) {
! $this -> currentTarget( $clone ) ;
! }
}
#/**
! # @return an instance of <code>NetScript::Interpreter</code>
# @public
#*/
! sub interpreter {
my ( $this ) = @_;
! $this -> { m_interpreter };
}
#/**
! # Walks over the given Document and returns a result document.
! # @param an instance of <code>XML::DOM2::Document</code>
! # @return an instance of <code>XML::DOM2::Document</code>
# @public
#*/
! sub walkOver {
! my ( $this, $source ) = @_;
! $this -> currentSource( $source );
! my $di = XML::DOM2::DOMImplementation -> new();
! # create target document
! my $document = $di -> createDocument( {
! namespaceURI => "dummy",
! qualifiedName => "dummy:dummy"
! } );
! # remove document element
! $document -> removeChild( {
! oldChild => $document -> documentElement()
! } );
!
! $this -> currentTarget( $document );
!
! $this -> goWalk();
! # Return result document
! $document;
}
#/**
! # Walks over the document. The walking is depth-first. The walker
! # will create an event for the current source node, then will iterate
! # over the children of the current source node in a depth-first manner.
# @private
#*/
! sub goWalk {
! my ( $this ) = @_;
! my $node = $this -> currentSource();
!
!
! # create start Event
! $this -> createEvent( $node );
! my $children = $node -> childNodes();
! my $count = $children -> length() - 1;
!
! # iterate over the children
! for ( 0..$count ) {
! $this -> currentSource( $children -> item ( {
! index => $_
! }));
! $this -> goWalk();
}
!
! # set old node as currentNode
! $this -> currentSource( $node );
!
! if ($node -> nodeType == XML::DOM2::Node -> ELEMENT_NODE() ) {
! # create end Event
! $this -> interpreter() -> getEventRelay() -> createAndRaiseEvent(
! $this -> ELEMENT_END_EVENT(), undef, $this );
! }
!
! }
!
#/**
! # Creates an even for the given node.
! # @param an instance of <code>XML::DOM2::Node</code>
# @private
#*/
! sub createEvent {
! my ( $this, $node ) = @_;
! my $nodeType = $node -> nodeType();
! my $eventType;
!
! if ( $nodeType == XML::DOM2::Node -> ELEMENT_NODE() ) {
! $eventType = $this -> ELEMENT_START_EVENT();
! }
! elsif ( $nodeType == XML::DOM2::Node -> TEXT_NODE() ) {
! $eventType = $this -> TEXT_EVENT();
! }
! elsif ( $nodeType == XML::DOM2::Node -> PROCESSING_INSTRUCTION_NODE() ) {
! $eventType = $this -> PI_EVENT();
! }
! elsif ( $nodeType == XML::DOM2::Node -> COMMENT_NODE() ) {
! $eventType = $this -> COMMENT_EVENT();
! }
! else {
! $eventType = $this -> OTHER_NODE_EVENT();
! }
! $this -> interpreter() -> getEventRelay() -> createAndRaiseEvent(
! $eventType, undef, $this );
}
!
#/**
! # Returns an instance of <code>NetScript::Engine::BasicStatement</code>
! # @public
#*/
! sub basicStatement {
! my ( $this ) = @_;
! $this -> { m_basicStatement };
}
Index: Event.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/Event.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Event.pm 1 Apr 2002 20:30:56 -0000 1.3
--- Event.pm 9 May 2002 19:11:03 -0000 1.4
***************
*** 24,32 ****
# The constructor. Constructs a new event.
# @param a hash reference containing the following key-value-pairs
! # EventType - a string defining the type of an event
! # EventMessage - a string holding a message
! # EventUnknown - a scalar/reference which can hold any information
! # that might be of use for the receivers of the event.
! # @return an instance of NetScript::Engine::Event
#*/
sub new {
--- 24,33 ----
# The constructor. Constructs a new event.
# @param a hash reference containing the following key-value-pairs
! # <ul>
! # <li>EventType - a string defining the type of an event</li>
! # <li>EventMessage - a string holding a message</li>
! # <li>EventUnknown - a scalar/reference which can hold any information
! # that might be of use for the receivers of the event.</li></ul>
! # @return an instance of <code>NetScript::Engine::Event</code>
#*/
sub new {
***************
*** 51,56 ****
# Returns the event type.
# @return a string holding the event Type.
#*/
! sub getEventType {
my ($this) = @_;
return $this -> { m_EventType };
--- 52,58 ----
# Returns the event type.
# @return a string holding the event Type.
+ # @public
#*/
! sub eventType {
my ($this) = @_;
return $this -> { m_EventType };
***************
*** 60,65 ****
# Returns the event Message
# @return a string holding the event Message
#*/
! sub getEventMessage {
my ($this) = @_;
return $this -> { m_EventMessage };
--- 62,68 ----
# Returns the event Message
# @return a string holding the event Message
+ # @public
#*/
! sub eventMessage {
my ($this) = @_;
return $this -> { m_EventMessage };
***************
*** 70,75 ****
# EventUnknown during Event construction.
# @return a scalar/reference holding the EventUnknown.
#*/
! sub getEventUnknown {
my ($this) = @_;
return $this -> { m_EventUnknown };
--- 73,79 ----
# EventUnknown during Event construction.
# @return a scalar/reference holding the EventUnknown.
+ # @public
#*/
! sub eventUnknown {
my ($this) = @_;
return $this -> { m_EventUnknown };
Index: EventRelay.pm
===================================================================
RCS file: /cvsroot/net-script/netscript2/src/perl/NetScript/Engine/EventRelay.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** EventRelay.pm 1 Apr 2002 20:30:56 -0000 1.4
--- EventRelay.pm 9 May 2002 19:11:03 -0000 1.5
***************
*** 1,12 ****
#--------------------------------------------------------
- # This class represents an event relay. It is used to
- # relay events within the Interpreter to their receivers.
- # does hold variable settings and arrays. Events are
- # sent using a FIFO principle. This means that events which
- # are raised first, will be sent first. An event which is
- # raised by a client upon reception of another event, will be fired
- # after the current event has been delivered to all clients.
- # So this implementation guarantees that all events will be
- # delivered in the same temporal order as they have been raised.
# $Id$
#
--- 1,3 ----
***************
*** 18,21 ****
--- 9,24 ----
#--------------------------------------------------------
use strict;
+
+ #/**
+ # This class represents an event relay. It is used to
+ # relay events within the Interpreter to their receivers.
+ # does hold variable settings and arrays. Events are
+ # sent using a FIFO principle. This means that events which
+ # are raised first, will be sent first. An event which is
+ # raised by a client upon reception of another event, will be fired
+ # after the current event has been delivered to all clients.
+ # So this implementation guarantees that all events will be
+ # delivered in the same temporal order as they have been raised.
+ #*/
package NetScript::Engine::EventRelay;
use vars qw($VERSION);
***************
*** 25,28 ****
--- 28,32 ----
#--------------------------------------------------------
use NetScript::Engine::Event;
+ use NetScript::Engine::EventListener;
#--------------------------------------------------------
***************
*** 56,70 ****
# Adds an event-listener to the internal list of
# listeners.
! # @param an object reference to the listener.
! # @param a hash reference containing event-sub pairs.
! # The keys are strings, describing the events which is listened to,
! # the values are strings which describe the functions to be called
! # if an event of this type is raised.
#*/
sub addEventListener {
! my ($this, $object, $functionsRef) = @_;
! my %functions = %{$functionsRef};
! $functions{ "NetScript::Engine::EventRelay::Listener" } = $object;
! $this -> { m_EventListeners } -> { $object } = \%functions;
}
--- 60,94 ----
# Adds an event-listener to the internal list of
# listeners.
! # @param an instance of <code>NetScript::Engine::EventListener</code>
#*/
sub addEventListener {
! my ($this, $listener ) = @_;
! my $arrayRef = $this -> { m_EventListeners } ->
! { $listener -> eventType() };
!
! # create array if doesn't exist
! unless ( defined( $arrayRef ) ) {
! my @attachedListeners = ();
! $this -> { m_EventListeners } ->
! { $listener -> eventType() } = \@attachedListeners;
! $arrayRef = \@attachedListeners;
! }
!
! my $priority = $listener -> priority();
! if ( $priority == $listener -> PRIORITY_FIRST() ) {
! unshift( @{ $arrayRef }, $listener );
! }
! elsif ( $priority == $listener -> PRIORITY_LAST() ) {
! push( @{ $arrayRef }, $listener );
! }
! else {
! # insert after the last listener with PRIORITY_FIRST
! my $index = 0;
! for ( @{ $arrayRef } ) {
! splice( @{ $arrayRef }, $index, 0, $listener ), last if
! $_ -> priority() != $listener -> PRIORITY_FIRST();
! $index++;
! }
! }
}
***************
*** 72,80 ****
# Removes a previously added event-listener from the list
# of listeners.
! # @param an object reference to the attached listener.
#*/
sub removeEventListener {
! my ($this, $object ) = @_;
! delete( $this -> { m_EventListeners } -> { $object } );
}
--- 96,113 ----
# Removes a previously added event-listener from the list
# of listeners.
! # @param the <code>NetScript::Engine::EventListener</code>-object
! # to remove
! # @note this operation can be expensive
#*/
sub removeEventListener {
! my ($this, $listener ) = @_;
! my @attachedListeners = $this -> { m_EventListeners } ->
! { $listener -> eventType() };
! my $index = 0;
! for ( @attachedListeners ) {
! delete $attachedListeners[$index], last if
! $_ == $listener;
! $index++;
! }
}
***************
*** 115,136 ****
# now we deliver events
$this -> { m_deliveringEvents } = 1;
!
! # get event type
! my $eventType = $event -> getEventType();
!
! # now relay the event
! my @listeners = keys( %{$this -> { m_EventListeners }} );
!
! for (@listeners) { # iterate over all attached listeners.
! # get object.
! my $object = $this -> { m_EventListeners } -> { $_ } -> { "NetScript::Engine::EventRelay::Listener" };
!
! # get sub to call.
! my $sub = $this -> { m_EventListeners } -> { $_ } -> { $eventType };
! if (defined( $sub )) {
! $object -> $sub( $event );
}
}
# we have delivered the current event.
$this -> { m_deliveringEvents } = 0;
--- 148,164 ----
# now we deliver events
$this -> { m_deliveringEvents } = 1;
!
! my $arrayRef = $this -> { m_EventListeners } ->
! { $event -> eventType() };
! if ( defined( $arrayRef ) ) {
! # iterate over all listeners for this event
! my @attachedListeners = @{ $arrayRef };
! for ( @attachedListeners ) {
! # send and if consumed stop processing
! $_ -> fireEvent( $event ) || last;
}
}
+
# we have delivered the current event.
$this -> { m_deliveringEvents } = 0;
|
