Taylor Venable avatar Taylor Venable committed b735e05

Move a bunch of stuff around

Comments (0)

Files changed (34)

src/erlang/distrib.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+
+namespace eval ::tcerl::distrib {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    variable SUPPORTED_CONTROL_MESSAGES {link send exit unlink node_link reg_send group_leader exit2}
+    variable USE_DIST_HEADER true
+
+    proc header {} {
+        return [binary format {ccc} 131 68 0]
+    }
+
+    proc link {from to} {
+        set code [term::new int 1]
+        set from [term::new pid {*}$from]
+        set to [term::new pid {*}$to]
+
+        set tuple [term::new tuple [list $code $from $to]]
+        set control [term::encode $tuple]
+
+        return [send_ctrlmsg $control]
+    }
+
+    proc send {cookie to msg} {
+        set code [term::new int 2]
+        set cookie [term::new atom $cookie]
+        set to [term::new pid {*}$to]
+
+        set tuple [term::new tuple $code $cookie $to]
+        set control [term::encode $tuple]
+        set msg [term::encode $msg]
+
+        return [send_ctrlmsg $control $msg]
+    }
+
+    proc exit {from to reason} {
+        set code [term::new int 3]
+        set from [term::new pid {*}$from]
+        set to [term::new pid {*}$to]
+
+        set tuple [term::new tuple $code $from $to $reason]
+        set control [term::encode $tuple]
+
+        return [send_ctrlmsg $control]
+    }
+
+    proc unlink {from to} {
+        set code [term::new int 4]
+        set from [term::new pid {*}$from]
+        set to [term::new pid {*}$to]
+
+        set tuple [term::new tuple $code $from $to]
+        set control [term::encode $tuple]
+
+        return [send_ctrlmsg $control]
+    }
+
+    proc node_link {} {
+        error unimplemented
+    }
+
+    proc reg_send {from cookie to msg} {
+        set code [term::new int 6]
+        set from [term::new pid {*}$from]
+        set cookie [term::new atom $cookie]
+        set to [term::new atom $to]
+
+        set tuple [term::new tuple $code $from $cookie $to]
+        set control [term::encode $tuple]
+        set msg [term::encode $msg]
+
+        return [send_ctrlmsg $control $msg]
+    }
+
+    proc group_leader {} {
+        error unimplemented
+    }
+
+    proc exit2 {} {
+        error unimplemented
+    }
+
+    # FIXME don't hardcode hostname
+    procra connect -nullary {reset} -required {name node in_cookie out_cookie} {
+        if {$reset} {
+            catch {disconnect $name $node}
+        }
+        set port [epmd::get_port $name $node]
+        return [node::connect $name@zareason $node@zareason localhost $port $in_cookie $out_cookie]
+    }
+
+    procra disconnect -required {name node} {
+        return [node::disconnect $name@zareason $node@zareason]
+    }
+
+    procra transmit -required {name node op} -rest rest {
+        variable SUPPORTED_CONTROL_MESSAGES
+        set port [epmd::get_port $name $node]
+        if {$op ni $SUPPORTED_CONTROL_MESSAGES} {
+            error unsupported
+        }
+        set msg [$op {*}$rest]
+        misc::puts_binary $msg
+
+        set sock [node::get_socket $name@zareason $node@zareason]
+        puts -nonewline $sock $msg
+        flush $sock
+    }
+
+    proc send_ctrlmsg {args} {
+        if {"DIST_HDR_ATOM_CACHE" in $::tcerl::node::MY_CAPS} {
+            return [send_ctrlmsg_dh {*}$args]
+        } else {
+            return [send_ctrlmsg_nodh {*}$args]
+        }
+    }
+
+    procra send_ctrlmsg_dh -required {control} -optional {msg} {
+        set control_length [string length $control]
+        set header_length [string length [header]]
+
+        if {[info exists msg]} {
+            set msg_length [string length $msg]
+            set length [expr {$header_length + $control_length + $msg_length}]
+            set result [binary format {I} $length]
+            append result [header]
+            append result $control
+            append result $msg
+        } else {
+            set length [expr {$header_length + $control_length}]
+            set result [binary format {I} $length]
+            append result [header]
+            append result $control
+        }
+
+        return $result
+    }
+
+    procra send_ctrlmsg_nodh -required {control} -optional {msg} {
+        set control [binary format {ca*} 131 $control]
+        set control_length [string length $control]
+
+        if {[info exists msg]} {
+            set msg [binary format {ca*} 131 $msg]
+            set msg_length [string length $msg]
+            set length [expr {1 + $control_length + $msg_length}]
+            set result [binary format {Ic} $length 112]
+            append result $control
+            append result $msg
+        } else {
+            set length [expr {1 + $control_length}]
+            set result [binary format {Ic} $length 112]
+            append result $control
+        }
+
+        return $result
+    }
+}

src/erlang/epmd.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+
+namespace eval ::tcerl::epmd {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    variable current_port 9000
+    variable epmd_sock
+    variable port
+    variable epmd_host_array
+    variable epmd_port_array
+
+    procra prepend_length -required {msg} {
+        set length [expr {[string length $msg]}]
+        return [binary format {Sa*} $length $msg]
+    }
+
+    procra register -nullary {hidden} -required {name} -optional {epmd_host epmd_port} {
+        variable current_port
+        variable epmd_sock
+        variable port
+        variable epmd_host_array
+        variable epmd_port_array
+
+        if {![info exists epmd_host]} {
+            set epmd_host "localhost"
+        }
+        if {![info exists epmd_port]} {
+            set epmd_port 4369
+        }
+
+        set port($name) $current_port
+        incr current_port
+
+        set epmd_sock($name) [socket $epmd_host $epmd_port]
+        fconfigure $epmd_sock($name) -translation binary
+
+        set epmd_host_array($name) $epmd_host
+        set epmd_port_array($name) $epmd_port
+
+        set msg {}
+        set node_type [expr {$hidden ? 72 : 77}]
+        append msg [binary format {cSccSSS} 120 $port($name) $node_type 0 5 5 [string bytelength $name]]
+        append msg $name
+        append msg [binary format {S} 0]
+        set msg [prepend_length $msg]
+        misc::puts_binary $msg
+
+        puts -nonewline $epmd_sock($name) $msg
+        flush $epmd_sock($name)
+
+        set response [read $epmd_sock($name) 4]
+        misc::puts_binary $response
+        binary scan $response {cucuSu} ident status creation
+        if {$ident != 121} {
+            error "invalid response from EPMD"
+        }
+        if {$status != 0} {
+            error "EPMD indicated error"
+        }
+    }
+
+    procra unregister -required {name} {
+        variable epmd_sock
+
+        close $epmd_sock($name)
+    }
+
+    procra get_port -required {name target} {
+        variable epmd_host_array
+        variable epmd_port_array
+
+        set sock [socket $epmd_host_array($name) $epmd_port_array($name)]
+        fconfigure $sock -translation binary
+
+        set msg [binary format {c} 122]
+        append msg $target
+        set msg [prepend_length $msg 0]
+        misc::puts_binary $msg
+
+        puts -nonewline $sock $msg
+        flush $sock
+
+        binary scan [read $sock 2] {cucu} code status
+        if {$code != 119} {
+            error "invalid response from EPMD"
+        }
+        if {$status != 0} {
+            error "EPMD indicated error"
+        }
+        binary scan [read $sock 10] {SucucuSuSuSu} port node_type proto highvsn lowvsn name_length
+        set target2 [read $sock $name_length]
+        if {$target ne $target2} {
+            error "nodes have different names: $target =/= $target2"
+        }
+        binary scan [read $sock 2] {Su} elen
+        if {$elen > 0} {
+            set extra [read $sock $elen]
+            misc::puts_binary $extra
+        }
+
+        puts "Peer node information:"
+        puts "  Name    = $target2"
+        puts "  Type    = [expr {$node_type == 72 ? "hidden" : "normal"}]"
+        puts "  Port    = $port"
+        puts "  Proto   = [expr {$proto == 0 ? "IPv4" : "unknown"}]"
+        puts "  LowVsn  = $lowvsn"
+        puts "  HighVsn = $highvsn"
+
+        close $sock
+        return $port
+    }
+}

src/erlang/misc.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+
+namespace eval ::tcerl::misc {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    proc puts_binary {x} {
+        binary scan $x {cu*} output
+        puts "<<[join $output ","]>>"
+    }
+}

src/erlang/node.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+package require md5
+
+namespace eval ::tcerl::node {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    variable conn
+    variable sock
+
+    variable CAP_INFO {
+        {PUBLISHED              0x1}
+        {ATOM_CACHE             0x2}
+        {EXTENDED_REFERENCES    0x4}
+        {DIST_MONITOR           0x8}
+        {FUN_TAGS               0x10}
+        {DIST_MONITOR_NAME      0x20}
+        {HIDDEN_ATOM_CACHE      0x40}
+        {NEW_FUN_TAGS           0x80}
+        {EXTENDED_PIDS_PORTS    0x100}
+        {EXPORT_PTR_TAG         0x200}
+        {BIT_BINARIES           0x400}
+        {NEW_FLOATS             0x800}
+        {UNICODE_IO             0x1000}
+        {DIST_HDR_ATOM_CACHE    0x2000}
+        {SMALL_ATOM_TAGS        0x4000}
+    }
+
+    # variable MY_CAPS {PUBLISHED EXTENDED_REFERENCES DIST_MONITOR FUN_TAGS DIST_MONITOR_NAME HIDDEN_ATOM_CACHE NEW_FUN_TAGS EXTENDED_PIDS_PORTS EXPORT_PTR_TAG BIT_BINARIES NEW_FLOATS UNICODE_IO DIST_HDR_ATOM_CACHE SMALL_ATOM_TAGS}
+    variable MY_CAPS {PUBLISHED EXTENDED_REFERENCES EXTENDED_PIDS_PORTS BIT_BINARIES UNICODE_IO SMALL_ATOM_TAGS}
+
+    procra prepend_length -required {msg} {
+        set length [expr {[string length $msg]}]
+        return [binary format {Sa*} $length $msg]
+    }
+
+    proc encode_caps {caps} {
+        variable CAP_INFO
+        set cap_int 0
+        foreach cap $caps {
+            set x [lsearch -index 0 -all -inline $CAP_INFO $cap]
+            if {[llength $x] == 0} {
+                error "no such capability: $cap"
+            } elseif {[llength $x] > 1} {
+                error "too many capability matches: $cap -> $x"
+            }
+            puts "+$cap"
+            set cap_int [expr {$cap_int | [lindex [lindex $x 0] 1]}]
+        }
+
+        return $cap_int
+    }
+
+    proc decode_caps {cap_int} {
+        variable CAP_INFO
+        set caps {}
+        for {set i 1; set j 0} {$j < 32} {set i [expr {$i * 2}]; incr j} {
+            set masked [expr {$cap_int & $i}]
+            if {$masked != 0} {
+                set hex [format {0x%X} $masked]
+                set x [lsearch -index 1 -all -inline $CAP_INFO $hex]
+                if {[llength $x] == 0} {
+                    error "no such capability: $hex"
+                } elseif {[llength $x] > 1} {
+                    error "too many capability matches: $hex -> $x"
+                }
+                lappend caps [lindex [lindex $x 0] 0]
+            }
+        }
+
+        return $caps
+    }
+
+    procra connect -required {name node host port in_cookie out_cookie} {
+        variable conn
+        variable sock
+        if {[info exists conn($name/$node)]} {
+            return alive
+        }
+        set conn($name/$node) true
+        set sock($name/$node) [socket $host $port]
+        fconfigure $sock($name/$node) -translation binary
+        if {[catch {set result [send_name $sock($name/$node) $name $node]} errmsg]} {
+            close $sock($name/$node)
+            unset sock($name/$node)
+            unset conn($name/$node)
+            error $errmsg
+        }
+        if {!$result} { return alive }
+        if {[catch {challenge_response $sock($name/$node) $name $node $in_cookie $out_cookie} errmsg]} {
+            close $sock($name/$node)
+            unset sock($name/$node)
+            unset conn($name/$node)
+            error $errmsg
+        }
+    }
+
+    procra disconnect -required {name node} {
+        variable conn
+        variable sock
+
+        if {![info exists sock($name/$node)]} {
+            error "not connected: $name <-/-> $node"
+        }
+        close $sock($name/$node)
+        unset sock($name/$node)
+        unset conn($name/$node)
+
+        puts "Disconnected: $name <-/-> $node"
+        return ok
+    }
+
+
+    # tag = 110:8
+    # version = 5:16
+    # caps = _:32
+    # name = _:*
+    proc send_name {sock name node} {
+        variable MY_CAPS
+        set msg [binary format {cSI} 110 5 [encode_caps $MY_CAPS]]
+        append msg $name
+        set msg [prepend_length $msg]
+
+        puts -nonewline $sock $msg
+        flush $sock
+
+        # recv_name
+
+        set response [read $sock 2]
+        binary scan $response {Su} length
+        set response [read $sock $length]
+        binary scan $response {cua*} tag status
+        if {$tag != 115} {
+            error "recv_name: invalid response from $node: wrong tag (got $tag, expecting 115)"
+        }
+        switch -- $status {
+            {ok} {
+                return true
+            }
+            {ok_simultaneous} {
+                error unimplemented
+            }
+            {nok} {
+                error "connection to $node already in progress"
+            }
+            {not_allowed} {
+                error "connection to $node refused"
+            }
+            {alive} {
+                return false
+            }
+            {default} {
+                error "invalid status from $node: $status"
+            }
+        }
+    }
+
+    proc challenge_response {sock name node in_cookie out_cookie} {
+        variable CAP_INFO
+
+        # recv_challenge
+
+        set response [read $sock 2]
+        binary scan $response {Su} length
+        set response [read $sock $length]
+        binary scan $response {cuSuIuIua*} tag version caps challenge node2
+
+        if {$tag != 110} {
+            error "recv_challenge: invalid response from $node: wrong tag (got $tag, expecting 110)"
+        }
+        if {$node ne $node2} {
+            error "recv_challenge: node name doesn't match expected: $node / $node2"
+        }
+
+        puts "Node information:"
+        puts "  Name = $node2"
+        puts "  Version = $version"
+        puts "  Caps ="
+        set caps [decode_caps $caps]
+        foreach cap $CAP_INFO {
+            if {[lindex $cap 0] in $caps} {
+                puts "    +[lindex $cap 0]"
+            } else {
+                puts "    -[lindex $cap 0]"
+            }
+        }
+        puts "  Challenge = $challenge"
+
+        # send_challenge_reply
+
+        set concatenated "$out_cookie$challenge"
+        set response [::md5::md5 $concatenated]
+        puts "  Response = [::md5::md5 -hex $concatenated]"
+        # FIXME don't hardcode challenge
+        set my_challenge 42
+        set msg [binary format {cIa*} 114 $my_challenge $response]
+        set msg [prepend_length $msg]
+        puts -nonewline $sock $msg
+        flush $sock
+
+        # recv_challenge_ack
+
+        set response [read $sock 2]
+        binary scan $response {Su} length
+        set response [read $sock $length]
+        binary scan $response {cua*} tag digest
+        if {$tag != 97} {
+            error "recv_challenge_ack: invalid response from $node: wrong tag (got $tag, expecting 97)"
+        }
+        if {$digest ne [::md5::md5 "$in_cookie$my_challenge"]} {
+            error "recv_challenge_ack: digest mismatch from $node"
+        }
+
+        fileevent $sock readable [list ::tcerl::node::keepalive $name $node]
+        puts "Successfully connected to $node!"
+    }
+
+    proc keepalive {name node} {
+        variable sock
+
+        if {[eof $sock($name/$node)]} {
+            disconnect $name $node
+        } else {
+            set data [read $sock($name/$node) 4]
+            set x [binary scan $data {I} length]
+            if {$x == 0} {
+                disconnect $name $node
+            } elseif {$length == 0} {
+                set response [binary format {cccc} 0 0 0 0]
+                puts -nonewline $sock($name/$node) $response
+                flush $sock($name/$node)
+            } else {
+                set data [read $sock($name/$node) $length]
+                puts "Got some kind of data:"
+                misc::puts_binary $data
+                binary scan $data {ca*} id data
+                if {$id == 112} {
+                    # No distribution header.
+                    puts "Here's the term:"
+                    lassign [term::decode $data] term data
+                    term::write $term
+                    if {[term::type $term] ne "TUPLE"} {
+                        error "message is not a tuple: [term::tostring $term]"
+                    }
+                    set code [term::element $term 1]
+                    if {[term::type $code] ne "INTEGER"} {
+                        error "message code is not an integer: [term::tostring $code]"
+                    }
+                    if {[lindex $code 1] in {2 6 12 16}} {
+                        puts "Here's the message:"
+                        lassign [term::decode $data] msg data
+                        set ::MAILBOX $msg
+                        term::write $msg
+                    }
+                } elseif {$id == 131} {
+                    # Just read the atom cache?
+                    # Or make [term::decode] do the whole thing?
+                } else {
+                    error "invalid id: $id"
+                }
+            }
+        }
+    }
+
+    proc get_socket {name node} {
+        variable sock
+
+        if {![info exists sock($name/$node)]} {
+            error "not connected: $name <-/-> $node"
+        }
+
+        return $sock($name/$node)
+    }
+}

src/erlang/src/distrib.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::distrib {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    variable SUPPORTED_CONTROL_MESSAGES {link send exit unlink node_link reg_send group_leader exit2}
-    variable USE_DIST_HEADER true
-
-    proc header {} {
-        return [binary format {ccc} 131 68 0]
-    }
-
-    proc link {from to} {
-        set code [term::new int 1]
-        set from [term::new pid {*}$from]
-        set to [term::new pid {*}$to]
-
-        set tuple [term::new tuple [list $code $from $to]]
-        set control [term::encode $tuple]
-
-        return [send_ctrlmsg $control]
-    }
-
-    proc send {cookie to msg} {
-        set code [term::new int 2]
-        set cookie [term::new atom $cookie]
-        set to [term::new pid {*}$to]
-
-        set tuple [term::new tuple $code $cookie $to]
-        set control [term::encode $tuple]
-        set msg [term::encode $msg]
-
-        return [send_ctrlmsg $control $msg]
-    }
-
-    proc exit {from to reason} {
-        set code [term::new int 3]
-        set from [term::new pid {*}$from]
-        set to [term::new pid {*}$to]
-
-        set tuple [term::new tuple $code $from $to $reason]
-        set control [term::encode $tuple]
-
-        return [send_ctrlmsg $control]
-    }
-
-    proc unlink {from to} {
-        set code [term::new int 4]
-        set from [term::new pid {*}$from]
-        set to [term::new pid {*}$to]
-
-        set tuple [term::new tuple $code $from $to]
-        set control [term::encode $tuple]
-
-        return [send_ctrlmsg $control]
-    }
-
-    proc node_link {} {
-        error unimplemented
-    }
-
-    proc reg_send {from cookie to msg} {
-        set code [term::new int 6]
-        set from [term::new pid {*}$from]
-        set cookie [term::new atom $cookie]
-        set to [term::new atom $to]
-
-        set tuple [term::new tuple $code $from $cookie $to]
-        set control [term::encode $tuple]
-        set msg [term::encode $msg]
-
-        return [send_ctrlmsg $control $msg]
-    }
-
-    proc group_leader {} {
-        error unimplemented
-    }
-
-    proc exit2 {} {
-        error unimplemented
-    }
-
-    # FIXME don't hardcode hostname
-    procra connect -nullary {reset} -required {name node in_cookie out_cookie} {
-        if {$reset} {
-            catch {disconnect $name $node}
-        }
-        set port [epmd::get_port $name $node]
-        return [node::connect $name@zareason $node@zareason localhost $port $in_cookie $out_cookie]
-    }
-
-    procra disconnect -required {name node} {
-        return [node::disconnect $name@zareason $node@zareason]
-    }
-
-    procra transmit -required {name node op} -rest rest {
-        variable SUPPORTED_CONTROL_MESSAGES
-        set port [epmd::get_port $name $node]
-        if {$op ni $SUPPORTED_CONTROL_MESSAGES} {
-            error unsupported
-        }
-        set msg [$op {*}$rest]
-        misc::puts_binary $msg
-
-        set sock [node::get_socket $name@zareason $node@zareason]
-        puts -nonewline $sock $msg
-        flush $sock
-    }
-
-    proc send_ctrlmsg {args} {
-        if {"DIST_HDR_ATOM_CACHE" in $::tcerl::node::MY_CAPS} {
-            return [send_ctrlmsg_dh {*}$args]
-        } else {
-            return [send_ctrlmsg_nodh {*}$args]
-        }
-    }
-
-    procra send_ctrlmsg_dh -required {control} -optional {msg} {
-        set control_length [string length $control]
-        set header_length [string length [header]]
-
-        if {[info exists msg]} {
-            set msg_length [string length $msg]
-            set length [expr {$header_length + $control_length + $msg_length}]
-            set result [binary format {I} $length]
-            append result [header]
-            append result $control
-            append result $msg
-        } else {
-            set length [expr {$header_length + $control_length}]
-            set result [binary format {I} $length]
-            append result [header]
-            append result $control
-        }
-
-        return $result
-    }
-
-    procra send_ctrlmsg_nodh -required {control} -optional {msg} {
-        set control [binary format {ca*} 131 $control]
-        set control_length [string length $control]
-
-        if {[info exists msg]} {
-            set msg [binary format {ca*} 131 $msg]
-            set msg_length [string length $msg]
-            set length [expr {1 + $control_length + $msg_length}]
-            set result [binary format {Ic} $length 112]
-            append result $control
-            append result $msg
-        } else {
-            set length [expr {1 + $control_length}]
-            set result [binary format {Ic} $length 112]
-            append result $control
-        }
-
-        return $result
-    }
-}

src/erlang/src/epmd.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::epmd {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    variable current_port 9000
-    variable epmd_sock
-    variable port
-    variable epmd_host_array
-    variable epmd_port_array
-
-    procra prepend_length -required {msg} {
-        set length [expr {[string length $msg]}]
-        return [binary format {Sa*} $length $msg]
-    }
-
-    procra register -nullary {hidden} -required {name} -optional {epmd_host epmd_port} {
-        variable current_port
-        variable epmd_sock
-        variable port
-        variable epmd_host_array
-        variable epmd_port_array
-
-        if {![info exists epmd_host]} {
-            set epmd_host "localhost"
-        }
-        if {![info exists epmd_port]} {
-            set epmd_port 4369
-        }
-
-        set port($name) $current_port
-        incr current_port
-
-        set epmd_sock($name) [socket $epmd_host $epmd_port]
-        fconfigure $epmd_sock($name) -translation binary
-
-        set epmd_host_array($name) $epmd_host
-        set epmd_port_array($name) $epmd_port
-
-        set msg {}
-        set node_type [expr {$hidden ? 72 : 77}]
-        append msg [binary format {cSccSSS} 120 $port($name) $node_type 0 5 5 [string bytelength $name]]
-        append msg $name
-        append msg [binary format {S} 0]
-        set msg [prepend_length $msg]
-        misc::puts_binary $msg
-
-        puts -nonewline $epmd_sock($name) $msg
-        flush $epmd_sock($name)
-
-        set response [read $epmd_sock($name) 4]
-        misc::puts_binary $response
-        binary scan $response {cucuSu} ident status creation
-        if {$ident != 121} {
-            error "invalid response from EPMD"
-        }
-        if {$status != 0} {
-            error "EPMD indicated error"
-        }
-    }
-
-    procra unregister -required {name} {
-        variable epmd_sock
-
-        close $epmd_sock($name)
-    }
-
-    procra get_port -required {name target} {
-        variable epmd_host_array
-        variable epmd_port_array
-
-        set sock [socket $epmd_host_array($name) $epmd_port_array($name)]
-        fconfigure $sock -translation binary
-
-        set msg [binary format {c} 122]
-        append msg $target
-        set msg [prepend_length $msg 0]
-        misc::puts_binary $msg
-
-        puts -nonewline $sock $msg
-        flush $sock
-
-        binary scan [read $sock 2] {cucu} code status
-        if {$code != 119} {
-            error "invalid response from EPMD"
-        }
-        if {$status != 0} {
-            error "EPMD indicated error"
-        }
-        binary scan [read $sock 10] {SucucuSuSuSu} port node_type proto highvsn lowvsn name_length
-        set target2 [read $sock $name_length]
-        if {$target ne $target2} {
-            error "nodes have different names: $target =/= $target2"
-        }
-        binary scan [read $sock 2] {Su} elen
-        if {$elen > 0} {
-            set extra [read $sock $elen]
-            misc::puts_binary $extra
-        }
-
-        puts "Peer node information:"
-        puts "  Name    = $target2"
-        puts "  Type    = [expr {$node_type == 72 ? "hidden" : "normal"}]"
-        puts "  Port    = $port"
-        puts "  Proto   = [expr {$proto == 0 ? "IPv4" : "unknown"}]"
-        puts "  LowVsn  = $lowvsn"
-        puts "  HighVsn = $highvsn"
-
-        close $sock
-        return $port
-    }
-}

src/erlang/src/misc.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::misc {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    proc puts_binary {x} {
-        binary scan $x {cu*} output
-        puts "<<[join $output ","]>>"
-    }
-}

src/erlang/src/node.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-package require md5
-
-namespace eval ::tcerl::node {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    variable conn
-    variable sock
-
-    variable CAP_INFO {
-        {PUBLISHED              0x1}
-        {ATOM_CACHE             0x2}
-        {EXTENDED_REFERENCES    0x4}
-        {DIST_MONITOR           0x8}
-        {FUN_TAGS               0x10}
-        {DIST_MONITOR_NAME      0x20}
-        {HIDDEN_ATOM_CACHE      0x40}
-        {NEW_FUN_TAGS           0x80}
-        {EXTENDED_PIDS_PORTS    0x100}
-        {EXPORT_PTR_TAG         0x200}
-        {BIT_BINARIES           0x400}
-        {NEW_FLOATS             0x800}
-        {UNICODE_IO             0x1000}
-        {DIST_HDR_ATOM_CACHE    0x2000}
-        {SMALL_ATOM_TAGS        0x4000}
-    }
-
-    # variable MY_CAPS {PUBLISHED EXTENDED_REFERENCES DIST_MONITOR FUN_TAGS DIST_MONITOR_NAME HIDDEN_ATOM_CACHE NEW_FUN_TAGS EXTENDED_PIDS_PORTS EXPORT_PTR_TAG BIT_BINARIES NEW_FLOATS UNICODE_IO DIST_HDR_ATOM_CACHE SMALL_ATOM_TAGS}
-    variable MY_CAPS {PUBLISHED EXTENDED_REFERENCES EXTENDED_PIDS_PORTS BIT_BINARIES UNICODE_IO SMALL_ATOM_TAGS}
-
-    procra prepend_length -required {msg} {
-        set length [expr {[string length $msg]}]
-        return [binary format {Sa*} $length $msg]
-    }
-
-    proc encode_caps {caps} {
-        variable CAP_INFO
-        set cap_int 0
-        foreach cap $caps {
-            set x [lsearch -index 0 -all -inline $CAP_INFO $cap]
-            if {[llength $x] == 0} {
-                error "no such capability: $cap"
-            } elseif {[llength $x] > 1} {
-                error "too many capability matches: $cap -> $x"
-            }
-            puts "+$cap"
-            set cap_int [expr {$cap_int | [lindex [lindex $x 0] 1]}]
-        }
-
-        return $cap_int
-    }
-
-    proc decode_caps {cap_int} {
-        variable CAP_INFO
-        set caps {}
-        for {set i 1; set j 0} {$j < 32} {set i [expr {$i * 2}]; incr j} {
-            set masked [expr {$cap_int & $i}]
-            if {$masked != 0} {
-                set hex [format {0x%X} $masked]
-                set x [lsearch -index 1 -all -inline $CAP_INFO $hex]
-                if {[llength $x] == 0} {
-                    error "no such capability: $hex"
-                } elseif {[llength $x] > 1} {
-                    error "too many capability matches: $hex -> $x"
-                }
-                lappend caps [lindex [lindex $x 0] 0]
-            }
-        }
-
-        return $caps
-    }
-
-    procra connect -required {name node host port in_cookie out_cookie} {
-        variable conn
-        variable sock
-        if {[info exists conn($name/$node)]} {
-            return alive
-        }
-        set conn($name/$node) true
-        set sock($name/$node) [socket $host $port]
-        fconfigure $sock($name/$node) -translation binary
-        if {[catch {set result [send_name $sock($name/$node) $name $node]} errmsg]} {
-            close $sock($name/$node)
-            unset sock($name/$node)
-            unset conn($name/$node)
-            error $errmsg
-        }
-        if {!$result} { return alive }
-        if {[catch {challenge_response $sock($name/$node) $name $node $in_cookie $out_cookie} errmsg]} {
-            close $sock($name/$node)
-            unset sock($name/$node)
-            unset conn($name/$node)
-            error $errmsg
-        }
-    }
-
-    procra disconnect -required {name node} {
-        variable conn
-        variable sock
-
-        if {![info exists sock($name/$node)]} {
-            error "not connected: $name <-/-> $node"
-        }
-        close $sock($name/$node)
-        unset sock($name/$node)
-        unset conn($name/$node)
-
-        puts "Disconnected: $name <-/-> $node"
-        return ok
-    }
-
-
-    # tag = 110:8
-    # version = 5:16
-    # caps = _:32
-    # name = _:*
-    proc send_name {sock name node} {
-        variable MY_CAPS
-        set msg [binary format {cSI} 110 5 [encode_caps $MY_CAPS]]
-        append msg $name
-        set msg [prepend_length $msg]
-
-        puts -nonewline $sock $msg
-        flush $sock
-
-        # recv_name
-
-        set response [read $sock 2]
-        binary scan $response {Su} length
-        set response [read $sock $length]
-        binary scan $response {cua*} tag status
-        if {$tag != 115} {
-            error "recv_name: invalid response from $node: wrong tag (got $tag, expecting 115)"
-        }
-        switch -- $status {
-            {ok} {
-                return true
-            }
-            {ok_simultaneous} {
-                error unimplemented
-            }
-            {nok} {
-                error "connection to $node already in progress"
-            }
-            {not_allowed} {
-                error "connection to $node refused"
-            }
-            {alive} {
-                return false
-            }
-            {default} {
-                error "invalid status from $node: $status"
-            }
-        }
-    }
-
-    proc challenge_response {sock name node in_cookie out_cookie} {
-        variable CAP_INFO
-
-        # recv_challenge
-
-        set response [read $sock 2]
-        binary scan $response {Su} length
-        set response [read $sock $length]
-        binary scan $response {cuSuIuIua*} tag version caps challenge node2
-
-        if {$tag != 110} {
-            error "recv_challenge: invalid response from $node: wrong tag (got $tag, expecting 110)"
-        }
-        if {$node ne $node2} {
-            error "recv_challenge: node name doesn't match expected: $node / $node2"
-        }
-
-        puts "Node information:"
-        puts "  Name = $node2"
-        puts "  Version = $version"
-        puts "  Caps ="
-        set caps [decode_caps $caps]
-        foreach cap $CAP_INFO {
-            if {[lindex $cap 0] in $caps} {
-                puts "    +[lindex $cap 0]"
-            } else {
-                puts "    -[lindex $cap 0]"
-            }
-        }
-        puts "  Challenge = $challenge"
-
-        # send_challenge_reply
-
-        set concatenated "$out_cookie$challenge"
-        set response [::md5::md5 $concatenated]
-        puts "  Response = [::md5::md5 -hex $concatenated]"
-        # FIXME don't hardcode challenge
-        set my_challenge 42
-        set msg [binary format {cIa*} 114 $my_challenge $response]
-        set msg [prepend_length $msg]
-        puts -nonewline $sock $msg
-        flush $sock
-
-        # recv_challenge_ack
-
-        set response [read $sock 2]
-        binary scan $response {Su} length
-        set response [read $sock $length]
-        binary scan $response {cua*} tag digest
-        if {$tag != 97} {
-            error "recv_challenge_ack: invalid response from $node: wrong tag (got $tag, expecting 97)"
-        }
-        if {$digest ne [::md5::md5 "$in_cookie$my_challenge"]} {
-            error "recv_challenge_ack: digest mismatch from $node"
-        }
-
-        fileevent $sock readable [list ::tcerl::node::keepalive $name $node]
-        puts "Successfully connected to $node!"
-    }
-
-    proc keepalive {name node} {
-        variable sock
-
-        if {[eof $sock($name/$node)]} {
-            disconnect $name $node
-        } else {
-            set data [read $sock($name/$node) 4]
-            set x [binary scan $data {I} length]
-            if {$x == 0} {
-                disconnect $name $node
-            } elseif {$length == 0} {
-                set response [binary format {cccc} 0 0 0 0]
-                puts -nonewline $sock($name/$node) $response
-                flush $sock($name/$node)
-            } else {
-                set data [read $sock($name/$node) $length]
-                puts "Got some kind of data:"
-                misc::puts_binary $data
-                binary scan $data {ca*} id data
-                if {$id == 112} {
-                    # No distribution header.
-                    puts "Here's the term:"
-                    lassign [term::decode $data] term data
-                    term::write $term
-                    if {[term::type $term] ne "TUPLE"} {
-                        error "message is not a tuple: [term::tostring $term]"
-                    }
-                    set code [term::element $term 1]
-                    if {[term::type $code] ne "INTEGER"} {
-                        error "message code is not an integer: [term::tostring $code]"
-                    }
-                    if {[lindex $code 1] in {2 6 12 16}} {
-                        puts "Here's the message:"
-                        lassign [term::decode $data] msg data
-                        set ::MAILBOX $msg
-                        term::write $msg
-                    }
-                } elseif {$id == 131} {
-                    # Just read the atom cache?
-                    # Or make [term::decode] do the whole thing?
-                } else {
-                    error "invalid id: $id"
-                }
-            }
-        }
-    }
-
-    proc get_socket {name node} {
-        variable sock
-
-        if {![info exists sock($name/$node)]} {
-            error "not connected: $name <-/-> $node"
-        }
-
-        return $sock($name/$node)
-    }
-}

src/erlang/src/term.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::term {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    proc encode {args} {
-        return [term_encode::encode {*}$args]
-    }
-
-    proc decode {args} {
-        return [term_decode::decode {*}$args]
-    }
-
-    procra write -required {term} {
-        puts [tostring $term]
-    }
-
-    procra tostring -required {term} {
-        set result ""
-        set type [lindex $term 0]
-        switch -- $type {
-            {INTEGER} {
-                # 97, 98
-                append result [lindex $term 1]
-            }
-            {ATOM} {
-                # 100, 115
-                append result "'[lindex $term 1]'"
-            }
-            {BINARY} {
-                # 77 (?), 109
-                append result "<<...>>"
-            }
-            {REFERENCE} {
-                # 101
-                append result "#Reference<...>"
-            }
-            {PORT} {
-                # 102
-                append result "#Port<...>"
-            }
-            {PID} {
-                # 103
-                append result "<X.Y.Z>"
-            }
-            {TUPLE} {
-                # 104, 105
-                append result "{"
-                set sub_results {}
-                foreach elem [lrange $term 1 end] {
-                    lappend sub_results [tostring $elem]
-                }
-                append result [join $sub_results ", "]
-                append result "}"
-            }
-            {NIL} {
-                # 106
-                append result "\[\]"
-            }
-            {STRING} {
-                # 107
-                append result "\"[lindex $term 1]\""
-            }
-            {LIST} {
-                # 108
-                append result "\["
-                set sub_results {}
-                foreach elem [lrange $term 1 end-1] {
-                    lappend sub_results [tostring $elem]
-                }
-                append result [join $sub_results ", "]
-                if {[lindex [lindex $term end] 0] ne "NIL"} {
-                    append result " | [tostring [lindex $term end]]"
-                }
-                append result "\]"
-            }
-            {BIGNUM} {
-                # 110, 111
-                append result [lindex $term 1]
-            }
-            {default} {
-                error "unsupported: $type"
-            }
-        }
-    }
-
-    procra new -required {type} -rest {value} {
-        switch -- $type {
-            {int} -
-            {integer} {
-                if {[llength $value] != 1 || ![string is integer [lindex $value 0]]} {
-                    error "Malformed integer, should be: \[tcerl::term::new int A\]"
-                }
-
-                return [list INTEGER {*}$value]
-            }
-            {float} {
-                if {[llength $value] != 1 || ![string is double [lindex $value 0]]} {
-                    error "Malformed float, should be: \[tcerl::term::new float A\]"
-                }
-
-                return [list FLOAT {*}$value]
-            }
-            {string} {
-                if {[llength $value] != 1} {
-                    error "Malformed string, should be: \[tcerl::term::new string A\]"
-                }
-
-                return [list STRING {*}$value]
-            }
-            {atom} {
-                if {[llength $value] != 1} {
-                    error "Malformed atom, should be: \[tcerl::term::new atom A\]"
-                }
-
-                return [list ATOM {*}$value]
-            }
-            {list} {
-                return [list LIST {*}$value]
-            }
-            {pid} {
-                if {[llength $value] != 3 && [llength $value] != 4} {
-                    error "Malformed PID (wrong # of args), should be: \[tcerl::term::new pid ?Host? A B C\]"
-                }
-
-                foreach component [lrange $value end-2 end] {
-                    if {![string is integer $component]} {
-                        error "Malformed PID (bad component \"$component\"), should be: \[tcerl::term::new pid ?Host? A B C\]"
-                    }
-                }
-
-                if {[llength $value] == 3} {
-                    return [list PID "nonode@nohost" {*}$value]
-                } else {
-                    return [list PID {*}$value]
-                }
-            }
-            {tuple} {
-                return [list TUPLE {*}$value]
-            }
-            {nil} {
-                return [list NIL]
-            }
-            {binary} {
-                return [list BINARY $value]
-            }
-            {default} {
-                error "Unknown Erlang term type: $type"
-            }
-        }
-
-        error IMPOSSIBLE
-    }
-
-    procra element -required {term index} {
-        set type [lindex $term 0]
-        if {$type ne "TUPLE"} {
-            error "not a tuple: [tostring $term]"
-        }
-        if {$index > [llength $term]} {
-            error "out of range: $index on [tostring $term]"
-        }
-        return [lindex $term $index]
-    }
-
-    procra type -required {term} {
-        return [lindex $term 0]
-    }
-}

src/erlang/src/term_decode.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::term_decode {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    variable small_atoms false
-
-    proc advance {var bytes} {
-        upvar $var data
-        binary scan $data "cu${bytes}a*" _ data
-    }
-
-    procra decode -nullary {nomagic} -unary {indent node} -required {data} {
-        if {![info exists indent]} {
-            return [decode -indent 0 {*}${args/original}]
-        }
-
-        if {!$nomagic} {
-            binary scan $data {cua*} magic data
-            if {$magic != 131} {
-                error "invalid magic: $magic"
-            }
-        }
-
-        binary scan $data {cua*} tag data
-        puts "[string repeat " " $indent] * Decoding Tag = $tag"
-        switch -- $tag {
-            {86} {
-                # Atom Cache
-                atom_cache::handle $data
-            }
-            {70} {
-                # New Float
-            }
-            {77} {
-                # Bit Binary
-            }
-            {82} {
-                # Atom Cache Reference
-                if {![info exists node]} {
-                    error "node name required to handle atom cache reference"
-                }
-
-                binary scan $data {cua*} index data
-                return [list [atom_cache::ref $node $index] $data]
-            }
-            {97} {
-                # Small Integer
-                binary scan $data {cua*} number data
-                return [list [term::new integer $number] $data]
-            }
-            {98} {
-                # Large Integer
-                binary scan $data {Iua*} number data
-                return [list [term::new integer $number] $data]
-            }
-            {99} {
-                # Old Float
-            }
-            {100} {
-                # Atom
-                binary scan $data {Sua*} length data
-                binary scan $data "a${length}a*" atom data
-                # FIXME make sure this is latin-1
-                return [list [term::new atom [encoding convertfrom iso8859-1 $atom]] $data]
-            }
-            {101} {
-                # Reference
-                set node [decode -nomagic -indent [expr {$indent + 2}] $data]
-                advance data [string length $node]
-                binary scan $data {Iucua*} id creation data
-                return [list [term::new reference $node $id $creation] $data]
-            }
-            {102} {
-                # Port
-                lassign [decode -nomagic -indent [expr {$indent + 2}] $data] node data
-                binary scan $data {Iucua*} id creation data
-                return [list [term::new port $node $id $creation] $data]
-            }
-            {103} {
-                # Pid
-                lassign [decode -nomagic -indent [expr {$indent + 2}] $data] node data
-                binary scan $data {IuIucua*} id serial creation data
-                return [list [term::new pid $node $id $serial $creation] $data]
-            }
-            {104} {
-                # Small Tuple
-                binary scan $data {cua*} arity data
-                set elems {}
-                for {set i 0} {$i < $arity} {incr i} {
-                    lassign [decode -nomagic -indent [expr {$indent + 2}] $data] elem data
-                    lappend elems $elem
-                }
-                return [list [term::new tuple {*}$elems] $data]
-            }
-            {105} {
-                # Large Tuple
-                binary scan $data {Iua*} arity data
-                set elems {}
-                for {set i 0} {$i < $arity} {incr i} {
-                    lassign [decode -nomagic -indent [expr {$indent + 2}] $data] elem data
-                    lappend elems $elem
-                }
-                return [list [term::new tuple {*}$elems] $data]
-            }
-            {106} {
-                # Nil
-                return [list [term::new nil] $data]
-            }
-            {107} {
-                # String
-                binary scan $data {Sua*} length data
-                binary scan $data "a${length}a*" str data
-                return [list [term::new string [encoding convertfrom iso8859-1 $str]] $data]
-            }
-            {108} {
-                # List
-                binary scan $data {Iua*} arity data
-                set elems {}
-                for {set i 0} {$i < $arity} {incr i} {
-                    lassign [decode -nomagic -indent [expr {$indent + 2}] $data] elem data
-                    lappend elems $elem
-                }
-                lassign [decode -nomagic -indent [expr {$indent + 2}] $data] tail data
-                return [list [term::new list {*}$elems $tail] $data]
-            }
-            {109} {
-                # Binary
-                binary scan $data {Iua*} length data
-                binary scan $data "cu${length}a*" bin data
-                return [list [term::new binary $bin] $data]
-            }
-            {110} {
-                # Small Bignum
-            }
-            {111} {
-                # Large Bignum
-            }
-            {112} {
-                # New Fun
-            }
-            {113} {
-                # Export
-            }
-            {114} {
-                # New Reference
-            }
-            {115} {
-                # Small Atom
-                binary scan $data {cua*} length data
-                binary scan $data "a${length}a*" atom data
-                return [list [term::new atom [encoding convertfrom iso8859-1 $atom]] $data]
-            }
-            {117} {
-                # Old Fun
-            }
-        }
-    }
-}

src/erlang/src/term_encode.tcl

-### Copyright (c) 2011, Taylor Venable
-### All rights reserved.
-###
-### Redistribution and use in source and binary forms, with or without
-### modification, are permitted provided that the following conditions are met:
-###
-###     * Redistributions of source code must retain the above copyright
-###       notice, this list of conditions and the following disclaimer.
-###
-###     * Redistributions in binary form must reproduce the above copyright
-###       notice, this list of conditions and the following disclaimer in the
-###       documentation and/or other materials provided with the distribution.
-###
-### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-### POSSIBILITY OF SUCH DAMAGE.
-
-package provide tcerl 1.0
-
-package require procra 1.0
-
-namespace eval ::tcerl::term_encode {
-    namespace import ::procra::procra
-    namespace path ::tcerl
-
-    variable small_atoms false
-
-    procra raw_encode -required {type} -optional {value} {
-        switch -- $type {
-            {SMALL_INTEGER_EXT} {
-                # integer (8-bit)
-                return [binary format {cc} 97 $value]
-            }
-            {INTEGER_EXT} {
-                # integer (32-bit)
-                return [binary format {ci} 98 $value]
-            }
-            {FLOAT_EXT} {
-                # old float representation
-                error unsupported
-            }
-            {ATOM_EXT} {
-                # atom
-                # TODO Convert $value to latin-1.
-                return [binary format {cSa*} 100 [string bytelength $value] $value]
-            }
-            {REFERENCE_EXT} {
-                error unsupported
-            }
-            {PORT_EXT} {
-                error unsupported
-            }
-            {PID_EXT} {
-                set result [binary format {c} 103]
-                append result [raw_encode ATOM_EXT [lindex $value 0]]
-                append result [binary format {I} [lindex $value 2]]
-                # FIXME don't hardcode creation number
-                append result [binary format {Ic} 0 0]
-                return $result
-            }
-            {SMALL_TUPLE_EXT} {
-                # tuple with length < 256
-                set result [binary format {cc} 104 [llength $value]]
-                foreach elt $value {
-                    append result [raw_encode {*}$elt]
-                }
-                return $result
-            }
-            {LARGE_TUPLE_EXT} {
-                error unsupported
-            }
-            {NIL_EXT} {
-                # empty list
-                return [binary format {c} 106]
-            }
-            {STRING_EXT} {
-                # string with length < 65536
-                return [binary format {cSa*} 107 [string bytelength $value] $value]
-            }
-            {LIST_EXT} {
-                # any list
-                # Using tcerl, these are always proper.
-                # NOTE The "final tail" should NOT appear in the "elements" field.
-                #      The "final tail" should NOT be counted in the length.
-                set result [binary format {cI} 108 [llength $value]]
-                foreach elt $value {
-                    append result [raw_encode {*}$elt]
-                }
-                append result [raw_encode NIL_EXT]
-                return $result
-            }
-            {BINARY_EXT} {
-                error unsupported
-            }
-            {SMALL_BIG_EXT} {
-                error unsupported
-            }
-            {LARGE_BIG_EXT} {
-                error unsupported
-            }
-            {NEW_REFERENCE_EXT} {
-                error unsupported
-            }
-            {SMALL_ATOM_EXT} {
-                # atom with length < 256
-                return [binary format {cca*} 115 [string bytelength $value] $value]
-            }
-            {FUN_EXT} {
-                error unsupported
-                # function reference
-                lassign $value pid module index uniq free_vars
-                set result [binary format {cI} 117 [llength free_vars]]
-                append result [raw_encode {*}$pid]
-                append result [raw_encode {*}$module]
-                append result [raw_encode {*}$index]
-                append result [raw_encode {*}$uniq]
-                append result [raw_encode {*}$free_vars]
-            }
-            {NEW_FUN_EXT} {
-                error unsupported
-            }
-            {EXPORT_EXT} {
-                error unsupported
-            }
-            {BIT_BINARY_EXT} {
-                error unsupported
-            }
-            {NEW_FLOAT_EXT} {
-                error unsupported
-            }
-            {default} {
-                error "encoder: bad internal term type $type"
-            }
-        }
-    }
-
-    proc factor_encoding {datum} {
-        variable small_atoms
-
-        set type [lindex $datum 0]
-        switch -- $type {
-            {INTEGER} {
-                lassign $datum _ value
-                if {$value > -127 && $value < 128} {
-                    return [list SMALL_INTEGER_EXT $value]
-                } else {
-                    return [list INTEGER_EXT $value]
-                }
-            }
-            {FLOAT} {
-                lassign $datum _ value
-            }
-            {LIST} {
-                set elements [lrange $datum 1 end]
-                set rest {}
-                foreach elt $elements {
-                    lappend rest [factor_encoding $elt]
-                }
-                return [list LIST_EXT $rest]
-            }
-            {STRING} {
-                set value [lindex $datum 1]
-                if {[string bytelength $value] > 65535} {
-                    error unimplemented
-                } else {
-                    return [list STRING_EXT $value]
-                }
-            }
-            {PID} {
-                return [list PID_EXT [lrange $datum 1 end]]
-            }
-            {TUPLE} {
-                set elements [lrange $datum 1 end]
-                set rest {}
-                foreach elt $elements {
-                    lappend rest [factor_encoding $elt]
-                }
-                if {[llength $elements] > 255} {
-                    return [list LARGE_TUPLE_EXT $rest]
-                } else {
-                    return [list SMALL_TUPLE_EXT $rest]
-                }
-            }
-            {ATOM} {
-                set value [lindex $datum 1]
-                if {[string bytelength $value] < 256 && $small_atoms} {
-                    return [list SMALL_ATOM_EXT $value]
-                } else {
-                    return [list ATOM_EXT $value]
-                }
-            }
-            {NIL} {
-                return [list NIL_EXT]
-            }
-            {default} {
-                error "encoder: invalid term: ($type) [lrange $datum 1 end]"
-            }
-        }
-    }
-
-    proc encode {datum} {
-        raw_encode {*}[factor_encoding $datum]
-    }
-}

src/erlang/term.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+
+namespace eval ::tcerl::term {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    proc encode {args} {
+        return [term_encode::encode {*}$args]
+    }
+
+    proc decode {args} {
+        return [term_decode::decode {*}$args]
+    }
+
+    procra write -required {term} {
+        puts [tostring $term]
+    }
+
+    procra tostring -required {term} {
+        set result ""
+        set type [lindex $term 0]
+        switch -- $type {
+            {INTEGER} {
+                # 97, 98
+                append result [lindex $term 1]
+            }
+            {ATOM} {
+                # 100, 115
+                append result "'[lindex $term 1]'"
+            }
+            {BINARY} {
+                # 77 (?), 109
+                append result "<<...>>"
+            }
+            {REFERENCE} {
+                # 101
+                append result "#Reference<...>"
+            }
+            {PORT} {
+                # 102
+                append result "#Port<...>"
+            }
+            {PID} {
+                # 103
+                append result "<X.Y.Z>"
+            }
+            {TUPLE} {
+                # 104, 105
+                append result "{"
+                set sub_results {}
+                foreach elem [lrange $term 1 end] {
+                    lappend sub_results [tostring $elem]
+                }
+                append result [join $sub_results ", "]
+                append result "}"
+            }
+            {NIL} {
+                # 106
+                append result "\[\]"
+            }
+            {STRING} {
+                # 107
+                append result "\"[lindex $term 1]\""
+            }
+            {LIST} {
+                # 108
+                append result "\["
+                set sub_results {}
+                foreach elem [lrange $term 1 end-1] {
+                    lappend sub_results [tostring $elem]
+                }
+                append result [join $sub_results ", "]
+                if {[lindex [lindex $term end] 0] ne "NIL"} {
+                    append result " | [tostring [lindex $term end]]"
+                }
+                append result "\]"
+            }
+            {BIGNUM} {
+                # 110, 111
+                append result [lindex $term 1]
+            }
+            {default} {
+                error "unsupported: $type"
+            }
+        }
+    }
+
+    procra new -required {type} -rest {value} {
+        switch -- $type {
+            {int} -
+            {integer} {
+                if {[llength $value] != 1 || ![string is integer [lindex $value 0]]} {
+                    error "Malformed integer, should be: \[tcerl::term::new int A\]"
+                }
+
+                return [list INTEGER {*}$value]
+            }
+            {float} {
+                if {[llength $value] != 1 || ![string is double [lindex $value 0]]} {
+                    error "Malformed float, should be: \[tcerl::term::new float A\]"
+                }
+
+                return [list FLOAT {*}$value]
+            }
+            {string} {
+                if {[llength $value] != 1} {
+                    error "Malformed string, should be: \[tcerl::term::new string A\]"
+                }
+
+                return [list STRING {*}$value]
+            }
+            {atom} {
+                if {[llength $value] != 1} {
+                    error "Malformed atom, should be: \[tcerl::term::new atom A\]"
+                }
+
+                return [list ATOM {*}$value]
+            }
+            {list} {
+                return [list LIST {*}$value]
+            }
+            {pid} {
+                if {[llength $value] != 3 && [llength $value] != 4} {
+                    error "Malformed PID (wrong # of args), should be: \[tcerl::term::new pid ?Host? A B C\]"
+                }
+
+                foreach component [lrange $value end-2 end] {
+                    if {![string is integer $component]} {
+                        error "Malformed PID (bad component \"$component\"), should be: \[tcerl::term::new pid ?Host? A B C\]"
+                    }
+                }
+
+                if {[llength $value] == 3} {
+                    return [list PID "nonode@nohost" {*}$value]
+                } else {
+                    return [list PID {*}$value]
+                }
+            }
+            {tuple} {
+                return [list TUPLE {*}$value]
+            }
+            {nil} {
+                return [list NIL]
+            }
+            {binary} {
+                return [list BINARY $value]
+            }
+            {default} {
+                error "Unknown Erlang term type: $type"
+            }
+        }
+
+        error IMPOSSIBLE
+    }
+
+    procra element -required {term index} {
+        set type [lindex $term 0]
+        if {$type ne "TUPLE"} {
+            error "not a tuple: [tostring $term]"
+        }
+        if {$index > [llength $term]} {
+            error "out of range: $index on [tostring $term]"
+        }
+        return [lindex $term $index]
+    }
+
+    procra type -required {term} {
+        return [lindex $term 0]
+    }
+}

src/erlang/term_decode.tcl

+### Copyright (c) 2011, Taylor Venable
+### All rights reserved.
+###
+### Redistribution and use in source and binary forms, with or without
+### modification, are permitted provided that the following conditions are met:
+###
+###     * Redistributions of source code must retain the above copyright
+###       notice, this list of conditions and the following disclaimer.
+###
+###     * Redistributions in binary form must reproduce the above copyright
+###       notice, this list of conditions and the following disclaimer in the
+###       documentation and/or other materials provided with the distribution.
+###
+### THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+### AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+### ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+### INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+### CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+### ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+### POSSIBILITY OF SUCH DAMAGE.
+
+package provide tcerl 1.0
+
+package require procra 1.0
+
+namespace eval ::tcerl::term_decode {
+    namespace import ::procra::procra
+    namespace path ::tcerl
+
+    variable small_atoms false
+
+    proc advance {var bytes} {
+        upvar $var data
+        binary scan $data "cu${bytes}a*" _ data
+    }
+
+    procra decode -nullary {nomagic} -unary {indent node} -required {data} {
+        if {![info exists indent]} {
+            return [decode -indent 0 {*}${args/original}]
+        }
+
+        if {!$nomagic} {
+            binary scan $data {cua*} magic data
+            if {$magic != 131} {
+                error "invalid magic: $magic"
+            }
+        }
+
+        binary scan $data {cua*} tag data
+        puts "[string repeat " " $indent] * Decoding Tag = $tag"
+        switch -- $tag {
+            {86} {
+                # Atom Cache
+                atom_cache::handle $data
+            }
+            {70} {
+                # New Float
+            }
+            {77} {
+                # Bit Binary
+            }
+            {82} {
+                # Atom Cache Reference
+                if {![info exists node]} {
+                    error "node name required to handle atom cache reference"