xotcl 1.6.7-2 / usr / share / tcltk / xotcl1.6.7-patterns / observer.xotcl

# $Id: observer.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::observer 0.8
package require XOTcl

namespace eval ::xotcl::pattern::observer {
    namespace import ::xotcl::*

    Class Observer -superclass Class

    @ @File {
	description {
	    Simple observer pattern meta-class taken from the paper 
	    'Filters as a Language Support for Design Patterns in
	    Object-Oriented Scripting Languages'. 
	}
    }

    Class Observer::Subject -superclass Class

    Observer::Subject instproc notificationFilter {args} {
	set procName [self calledproc]
	my instvar \
	    preObservers  [list preObservers($procName)  preObs] \
	    postObservers [list postObservers($procName) postObs]

	if {[info exists preObs]} {
	    foreach obj $preObs { $obj update [self] $args }
	}
	set result [next]

	if {[info exists postObs]} {
	    foreach obj $postObs { $obj update [self] $args }
	}
	return $result
    }

    Class Observer::SubjectMgt
    Observer::SubjectMgt instproc attach {hook objs} {
	upvar [self callinglevel] $hook observers
	foreach obj $objs {
	    if {![info exists observers] || [lsearch $observers $obj] == -1} {
		lappend observers $obj
	    }
	}
    }
    Observer::SubjectMgt instproc detach {hook objs} {
	upvar [self callinglevel] $hook observers
	if {[info exists observers]} {
	    foreach obj $objs {
		set p [lsearch $observers $obj]
		set observers [lreplace $observers $p $p]
	    }
	}
    }

    Observer::SubjectMgt instproc attachPre {procName args} {
	my instvar preObservers 
	my attach  preObservers($procName) $args
    } 
    Observer::SubjectMgt instproc attachPost {procName args} {
	my instvar postObservers 
	my attach  postObservers($procName) $args
    } 
    Observer::SubjectMgt instproc detachPre {procName args} {
	my instvar preObservers
	my detach  preObservers($procName) $args
    }
    Observer::SubjectMgt instproc detachPost {procName args} {
	my instvar postObservers
	my detach  postObservers($procName) $args
    }

    Observer::Subject instproc init args {
	next
	my superclass [list Observer::SubjectMgt [my info superclass]]
	my instfilter notificationFilter
    }

    Observer instproc timeout t {
	my set timeout $t
    }

    Observer instproc update {subject args} {
	#addTimeOut [my set timeout] "my update $subject $args"
	#$subject getResponse
	# do something with the response
	puts [self]---update
    }

    namespace export Observer
    namespace eval Observer {
	namespace export Subject SubjectMgt
    }
}

namespace import ::xotcl::pattern::observer::*
namespace eval Observer {
    namespace import ::xotcl::pattern::observer::Observer::*
}