Zarutian's Thingy Package

# 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 [L1 ].

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.