# Code by Zarutian here is hereby free to everyone to use if they satisfy the following conditions:
# 1. Dont blame me if this doesnt work for any purpose you intented.
# 2. Attribute your use of this code
# 3. Any and all modifications of this code must be shared under these conditions.
# 4. Any patent infrightment (anywhere and anywhen) is the sole responsibility of the patent holder.
# I am sorry if your patent was too obvious or too broad to be infrighted upon but it is no concern of mine.
package require Tcl 8.5
package provide thingy 1.2
proc thingy {name} {
if {[namespace exists ::things::[set name]]} {
namespace eval ::things::[set name] { destroy }
if {[namespace exists ::things::[set name]]} { error }
}
namespace eval ::things::[set name] {
proc dispatch args {
return [uplevel 1 $args]
}
proc destroy {} {
namespace delete [namespace current]
}
}
proc $name args "namespace eval ::things::[set name] dispatch \$args"
$name variable this $name
$name variable creator thingy
return $name
}
proc get {varname} {
return [uplevel 1 [list set $varname]]
}Zarutian 02:52 UTC 14. oktober 2006: A variant of Richard Suchenwich
[thingy
] one line object orientation system. Please do not change the above code block without conferring with me first. Comments are welcome below.
Zarutian 03:17 UTC 14. oktober 2006: Extend unknown. This is sloooowwww.
set temp {
if {[uplevel 1 [list namespace current]] != "::"} {
if {[lsearch -exact [uplevel 1 [list info procs]] "unknown"] != -1 } {
return [namespace eval [uplevel 1 [list namespace current]] "unknown $args"]
}
}
}
proc unknown args "[set temp]\n[info body unknown]"
unset tempNEM: As you already require Tcl 8.5, you can use
namespace unknown to add different unknown handlers to each namespace. You can even set up the global namespace handler to resolve relative to the current namespace:
namespace eval :: { namespace unknown unknown }(The default is "::unknown"). This will have the same effect as your above code. See TIP 181 for details [
1].
Zarutian 03:18 UTC 14. oktober 2006: Singleton for nameing new objects
thingy name
name set counter 0
name proc next {} {
variable counter
return "thing[incr counter]"
}Zarutian 03:19 UTC 14. oktober 2006: Null pointer catcher
thingy null
null proc dispatch args {
set caller [uplevel 4 [list set this]]
error "$caller tried to invoke: $args on null"
}Zarutian 03:20 UTC 14. oktober 2006: Serializer for objects. (The objects cannot hold references to unserializable objects yet. Have to implement pass-by-reference someday later)
proc makeSerializable {item} {
$item proc serialize_variables {} {
set this_ns [namespace current]
set vars [info vars [set this_ns]::*]
set result "# [llength $vars] variables\n"
foreach var $vars {
set varname [string range $var [string length [set this_ns]::] end]
if {[array exists $var]} {
append result "array put [list $varname] [list [array get $var]]"
append result \n
} else {
append result "set [list $varname] [list [set $var]]"
append result \n
}
}
return $result
}
$item proc serialize_procedures {} {
set this_ns [namespace current]
set procs [info procs [set this_ns]::*]
set result "# [llength $procs] procedures\n"
foreach proc $procs {
set procname [string range $proc [string length [set this_ns]::] end]
append result "proc [list $procname] [list [info args $proc]] [list [info body $proc]]\n"
}
return $result
}
$item proc serialize {} {
# NOTICE: this method/procedure doesnt serialize children namespaces
# I recommend that the memento pattern to be used instead of seralizeing in most cases
variable this
set result ""
append result [$this serialize_variables]
append result [$this serialize_proocedures]
return $result
}
}Zarutian 03:23 UTC 14. oktober 2006: Stuff to make deep copies of objects. Uses makeSerializable defined above.
proc makeCloneable {item} {
makeSerializable $item
$item proc spawnClone {name} {
variable this
thingy $name
$name eval [$this serialize]
$name variable this $name
$name variable creator [list $this spawnClone]
# is this, below, duck-typing?
if {[lsearch -exact [$name info proc] cloned] != -1} { $name cloned $this }
return $name
}
}Zarutian proc makeThingsRemotable {} {
# Pass-By-Copy
# Pass-By-Reference
# Pass-By-Replica
# A hard but possible stragety if the object system was initialized before and used.
# 1. store names of all object instanced into a list
# 2. iterate that list
# 2.1 for each item make a new name unique to host ("[hostname]_[set oldname]")
# 2.2 find and replace the old name for the new name everywhere
# an easier way would be just replace current instance bound to handle [name] with
# the one below before any objects are instanced
catch { name destroy }
thingy name
name variable counter 0
name variable unique "[clock seconds]-[hostname]"
name proc next {} {
variable counter
variable unique
return "[set unique]-[incr counter]"
}
set temp {
}
proc unknown args "[set temp]\n[info body unknown]"
unset temp
}
proc urlEncode {input} {
set result ""
foreach char [split $input ""] {
if {[regexp -- {[a-zA-Z0-9]} $char]} {
append result $char
} else {
if {$char == " "} {
append result "+"
} else {
scan $char "%c" value
if {$value < 256} {
append result [format "%%%02x" $value]
} else {
# var ekki einhverstaðar RFC sem skilgreindi Internationalized Resource Identifiers/Locators?
append result [urlEncode [format "\\u%04x" $value]]
}
}
}
}
return $result
}
proc makeLocalReplicaOfRemoteV1 {name uri} {
thingy $name
$name variable uri $uri
$name proc dispatch args {
variable uri
package require http 2.5.0
set token [http::geturl $uri -query "[urlEncode $args]"]
set data [http::data $token]
http::cleanup $token
if {[lindex $args 0] == "destroy"} { destroy }
}
return $name
}
