====== # Code by Zarutian here is hereby free to everyone to use if they satisfy the following conditions: # 1. Dont blame me if this doesn't 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 [string map [list @name@ [list $name]] { namespace eval ::things::@name@ dispatch $args }] $name variable this $name $name variable creator thingy return $name } proc get varname { return [uplevel 1 [list set $varname]] } ====== [Zarutian] 2006-10-14 02:52 UTC: 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] 2006-10-14 03:17 UTC: Extend unknown. This is sloooowwww. ====== set temp { if {[uplevel 1 [list namespace current]] ne {::}} { 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 temp ====== [NEM]: 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 [http://www.tcl.tk/cgi-bin/tct/tip/181]. [Zarutian] 2006-10-14 03:18 UTC: Singleton for naming 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 1 [list set this]] error "$caller tried to invoke: $args on null" } ====== [Zarutian] 2006-10-14 03:20 UTC: 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 doesn't serialize children namespaces # I recommend that the memento pattern to be used instead of serializing in most cases variable this set result {} append result [$this serialize_variables] append result [$this serialize_proocedures] return $result } } ====== [Zarutian] 2006-10-14 03:23 UTC: 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 strategy 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 eq { }} { 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 } ====== ** Page Authors ** [pyk] 2024-03-22: Fixed spelling and modernized code. <> Package | Object Orientation