/usr/share/tcltk/xotcl1.6.8-patterns/observer.xotcl is in xotcl 1.6.8-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | package provide xotcl::pattern::observer 1.0
package require XOTcl 1
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::*
}
|