This is an implementation of the Google-protobuf protocol in pure Tcl. See http://code.google.com/intl/de/apis/protocolbuffers/docs/overview.html;
At the moment the code is distributed to 3 Files: pkgIndex.tcl, parse.tcl and wire.tcl.
As you can see it is still at alpha-status, but I am still working at it and hope to improve it with your help.

First "pkgIndex.tcl":
======
if {![package vsatisfies [package provide Tcl] 8.5-]} { return }
# Tcl8.5 needed for 'dict' and 'expr' overflow behaviour.
if {$::tcl_platform(wordSize) < 4} {
    # *** protobuf not-yet for (tcl_platform(wordSize) != 4)
    return
}
# ******************************************************************************
proc ::pkgLoadProtobuf {dir} {
    #package require fm::debug
    #if {![package vsatisfies [package provide Tcl] 8.5-]} { package require dict 8.5.3 }
    source -encoding utf-8 [file join $dir parse.tcl]
    #source -encoding utf-8 [file join $dir util.tcl]
    source -encoding utf-8 [file join $dir wire.tcl]
    #source -encoding utf-8 [file join $dir tests.tcl]

    set v 0.a1
    namespace eval pb "variable pkg_version $v"
    package provide fm::protobuf $v  ;# last modified 2010-01-28,Do

    rename ::pkgLoadProtobuf {}
}
# ##############################################################################
package ifneeded fm::protobuf 0.a1 [list ::pkgLoadProtobuf $dir]
# ##############################################################################
======

Here is "parse.tcl":
======
# ##############################################################################
namespace eval pb {
    namespace export Init ParseProtofile ResolveNames SaveStubs
    namespace export read_* write_*
    variable import_path {}
    variable protoDict {}
    variable itp {}
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    variable all_messages {}
    variable curr {}
    variable curr_message {}
    variable curr_enum {}
    variable curr_enum_val -1
    variable namesToResolve {}
    variable inflate 0
    variable testing 1
    variable readChanCmd [list ::read]
    variable readChanCmd [list ::pd::_readAndCheck]
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    ;# --- type==>wire_type
    variable predefinedTypes
    array set predefinedTypes {
        0 0 1 1 2 2 3 3 4 4 5 5 
        bool 0
        int32 0 sint32 0 uint32 0
        int64 0 sint64 0 uint64 0
        double 1 fixed64 1 sfixed64 1
        bytes 2 string 2
        sfixed32 5 fixed32 5 float 5
    }
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    # "Language Guide": ...The complete list of available options is defined
    #     in  google/protobuf/descriptor.proto...

    #variable FieldOptions {ctype packed deprecated}
    #variable Options {default}
    # {java_package java_outer_classname optimize_for}
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    namespace eval itp {}
    namespace eval enum_itp {}
    namespace eval msg_itp {}
    namespace eval msg {}  ;# for 'message'
    namespace eval tmp {}  ;# for internal 'inflate' variables etc.
    # == == == == == == == == == == == == == == == == == == == == == == == == =
}
# ******************************************************************************
#tputs "fm::startup=$fm::startup"
# ******************************************************************************
proc pb::now {} {
    set s [clock seconds]
    set w [lindex {Sun Mon Tue Wen Thu Fri Sat} [clock format $s -format %w]]
    clock format $s -format "%Y-%m-%d,%H:%M,$w"
}
# ##############################################################################
proc pb::Init {} {
    variable itp ::pb::itpF1
    variable msg_itp ::pb::itpM1
    variable enum_itp ::pb::itpE1
    namespace eval ::pb::msg {}
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    interp create -safe $itp ;# --- fillCmdInterp
    # xxx 'service': see "Language Guide#Defining Services"
    # xxx (descriptor.proto): service, options,
    foreach i {// enum extend import message option package} {
        interp alias $itp $i {} ::pb::itp::$i
    }
    interp alias $itp unknown      {} ::pb::itp::_unknown
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    interp create -safe $msg_itp
    # xxx (descriptor.proto): ExtensionRange, MessageOptions,
    foreach i {// enum extend extensions message} {
        interp alias $msg_itp $i {} ::pb::msg_itp::$i
    }
    foreach i {optional repeated required} {
        interp alias $msg_itp $i {} ::pb::msg_itp::_kind $i
    }
    interp alias $msg_itp pbOptionList {} ::pb::msg_itp::pbOptionList
    interp alias $msg_itp unknown {} ::pb::msg_itp::_unknown
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    interp create -safe $enum_itp
    interp alias $enum_itp unknown {} ::pb::enum_itp::_unknown
    # == == == == == == == == == == == == == == == == == == == == == == == == =
}
# ******************************************************************************
proc pb::ParseProtofile {aProtoFile args} {
    foreach {opt val} $args {
        switch -- $opt {
            -import_path { variable import_path $opt }
        }
    }
    set pdct [_ParseProtofile $aProtoFile]
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    variable namesToResolve
    if {[llength $namesToResolve]} { ResolveNames }
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    foreach ns [dict keys [dict get $pdct message]] {
        if {$ns eq "::pb::msg"} continue
        set ${ns}::msg0 [create_msg0 $ns]
    }
}
# ******************************************************************************
    # xxx ein 'dict' returnieren, das die toplevel-Objekte beschreibt.
proc pb::_ParseProtofile {aProtoFile} {
    variable protoDict
    set protoDict0 $protoDict
    set protoDict [dict create]
    dict set protoDict message ::pb::msg {}
    ::pb::curr_message set ::pb::msg
    variable itp 
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    #interp invokehidden $itp source $aProtoFile
    set fid [open $aProtoFile r]
    fconfigure $fid -encoding utf-8
    set x [read $fid]
    close $fid
    set x [RemoveC++Comments $x]
    # -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
    # Here the syntax will be made as Tcl-compatible as possible.
    # 
    # We have to cope with syntax like the following:
    # 
    #     optional string field1 = 1 [ctype=CORD,
    #                                 (field_opt1)=8765432109];
    #     optional string field2 = 2[default="hello",(field_opt2)=8765432109];
    # 
    # Note: the square-brackets cross multiple lines without backslashes!
    # -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
    # --- protect '=', ',', etc. inside of strings
    # xxx Das reicht wenn z.B. mehr als '$' im String steht! => while-Schleife!
    regsub -all -line -- {(\".*?)=(.*?\")} $x {\1__pb_eq__\2} x
    regsub -all -line -- {(\".*?),(.*?\")} $x {\1__pb_comma__\2} x
    regsub -all -line -- {(\".*?)\[(.*?\")} $x {\1__pb_brac0__\2} x
    regsub -all -line -- {(\".*?)\](.*?\")} $x {\1__pb_brac1__\2} x
    regsub -all -line -- {(\".*?)\$(.*?\")} $x {\1__pb_dollar__\2} x

    # --- add syntactic spaces and remove protection
    set x [string map [list \
        = " = " \
        , " , " \
        \{ " \{" \
        \} "\} " \
        \[ " \[pbOptionList \{" \
        \] "\}\] " \
        __pb_eq__ = \
        __pb_comma__ , \
        __pb_brac0__ "\\\[" \
        __pb_brac1__ "\\\]" \
        __pb_dollar__ "\\\$" \
        ] $x]
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    #tputs "[string repeat * 77]\n$x\n[string repeat * 77]"
    $itp eval $x
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    #prALL
    set protoDict1 $protoDict
    set protoDict [dict merge $protoDict0 $protoDict1]
    set protoDict1
}
# ******************************************************************************
proc pb::ResolveNames {} {
    variable namesToResolve
    foreach {m nm val} $namesToResolve {
        upvar #0 ${m}::fields fields
        set type [dict get $fields v2d $val type]
        switch [resolveNm $m $type path nm1] {
            isEnum {
                #! isEnum m type nm val path
                dict set fields v2d $val wt 0
                dict set fields v2d $val type [list Enum $path $nm1]
                # Das Ersetzen der Default-Werte sollte ich gar nicht machen!
                #     if {[dict exists $fields v2d $val default]} {
                #         set key [dict get $fields v2d $val default]
                #         set x [dict get [set $path] $nm1 k2v $key] ;#! key ==> x
                #         dict set fields v2d $val default $x
                #     }
            }
            isMsg {
                #! isMsg m type nm val path
                dict set fields v2d $val wt 2
                dict set fields v2d $val type [list Msg $path]
            }
            isUnknown {
                dict set fields v2d $val wt 2
                ;#! xxx isUnknown m type nm val
            }
        }
    }
    set namesToResolve {}
}
# ******************************************************************************
proc pb::create_msg0 {ns} {
    upvar #0 ${ns}::fields fields
    set x [dict create]
    #! ns fields
    dict for {key val} [dict get $fields k2v] {
        switch [dict get $fields v2d $val kind] {
            optional {
                if {[dict exists $fields v2d $val default]} {
                    dict set x $key [dict get $fields v2d $val default]
                }
            }
            repeated {
            }
            required {
            }
        }
    }
    set x
}
# ******************************************************************************
proc pb::SaveStubs {protoDict aStubsFile {pkg {}}} { ;#! aStubsFile
    set fid [open $aStubsFile w]
    if {$pkg eq {}} {
        # xxx pkg aus dem protoDict lesen!
        set pkg " [file rootname [file tail $aStubsFile]] 0.1"
    }
    variable pkg_version
    puts $fid "package provide $pkg"
    puts $fid "# [string repeat # 77]"
    puts $fid "# Generated by 'package protobuf $pkg_version;# SaveStubs' ([now])"
    puts $fid "# [string repeat # 77]"
    puts $fid "package require fm::protobuf"
    #fconfigure $fid -encoding utf-8
    tputs "  # keys [dict keys [dict get $protoDict message]]"
    foreach {nm} [lsort -dictionary [dict keys [dict get $protoDict message]]] {
        puts $fid "namespace eval $nm \{"
        #puts $fid "    # [info vars ${nm}::*]"
        #puts $fid "    # [info commands ${nm}::*]"
        foreach vnm [lsort -dictionary [info vars ${nm}::*]] {
            upvar $vnm var
            if {![info exists var]} continue
            set tail [namespace tail $vnm]
            if {$tail eq "enums" && ![llength $var]} continue
            if {$tail ni {enums fields extensions}} continue
            puts $fid "    set $tail [list $var]"
        }
        if {$nm eq "::pb::msg"} {
            puts $fid "\}" ;# (namespace)
            continue
        }
        puts $fid "    set msg0 [list [create_msg0 $nm]]"
        puts $fid "\}" ;# (namespace)
    }
    close $fid
}
# ******************************************************************************
proc pb::prALL {} {
    variable all_messages
    tputs "# [string repeat * 77]"
    tputs "messages:"
    foreach i [lsort -dictionary $all_messages] {
        tputs "    ${i}::enums = {[set ${i}::enums]}"
        tputs "    ${i}::fields = {[set ${i}::fields]}"
    }
}
# ******************************************************************************
    ;# See 'Language Guide#Packages and Name Resolution':
    ;#     Type name resolution in the protocol buffer language works like C++:
    ;#     first the innermost scope is searched, then the nextinnermost,
    ;#     and so on, with each package considered to be "inner" to its parent
    ;#     package.
    ;#     A leading '.', for example '.foo.bar.Baz', means to start from the
    ;#     outermost scope instead. [fm: Example(1)]
    ;#     The protocol buffer compiler resolves all type names by parsing the
    ;#     imported .proto files. The code generator for each language knows how
    ;#     to refer to each type in that language, even if it has different
    ;#     scoping rules.
    ;# 
    ;# Example(2):
    ;#     message m1 { enum e1 { a=0; b=1; } }
    ;#     message m2 {
    ;#         optional m1.e1 f2=b; [default = a];
    ;#     }
    ;#     => aNS="m2"  aNm="m1.e1"
    ;# 
proc pb::resolveNm {aNS aNm aPath aNm1} {
    upvar 1 $aPath p  $aNm1 nm1
    set nm [split $aNm .]
    set nm0 [lrange $nm 0 end-1]
    set nm1 [lindex $nm end]

    # --- absolute-qualified name
    if {[string index $aNm 0] eq "."} {
        set msg [join [concat ::pb::msg $nm] ::]
        if {[namespace exists $msg]} { set p $msg;  return isMsg }

        set d [join [concat ::pb::msg $nm0 enums] ::]
        if {[dictAndValExist $d $nm1]} { set p $d;  return isEnum }
        return 0
    }

    # --- relative-qualified name
    set ns [string map {:: { }} $aNS]
    for {set i [llength $ns]} {$i >= 2} {incr i -1} {
        set nsi [lrange $ns 0 $i-1]
        set msg ::[join [concat $nsi $nm] ::]
        #! i nsi aNm msg [namespace exists $msg]
        if {[namespace exists $msg]} { set p $msg;  return isMsg }

        set d ::[join [concat $nsi $nm0 enums] ::]
        #! i nsi aNm d nm1
        if {[dictAndValExist $d $nm1]} { set p $d;  return isEnum }
    }
    return isUnknown
}
# ******************************************************************************
proc pb::dictAndValExist {d args} {
    if {![info exists $d]} { return 0 }
    dict exists [set $d] {*}$args
}
# ******************************************************************************
proc pb::RemoveC++Comments {a} {
    ;# --- protect '//' inside of strings
    regsub -all -line -- {(\".*?)//(.*?\")} $a {\1__pb_slashslash__\2} a

    regsub -all -line -- {^\s*//.*$} $a "\n" a
    regsub -all -line -- {;\s*//.*$} $a ";\n" a
    regsub -all -line -- {\{\s*//[^\}]*$} $a "\{\n" a

    # --- remove empty lines.
    regsub -all -- {\n\s*\n} $a "\n" a

    string map [list __pb_slashslash__ //] $a
}
# ******************************************************************************
proc pb::assert {a} {
    set x [uplevel 1 [list expr $a]]
    if {!$x} { return -code error "*** assertion ($a) failed" }
}
# ******************************************************************************
proc pb::unexpected {a} { return -code error "*** unexpected: $a" }
# ******************************************************************************
proc pb::curr_message {sub {a {}}} {
    variable curr_message
    switch $sub {
        create {
            variable protoDict
            dict set protoDict message $a {}
            set curr_message $a
            # --- every message into a separate namespace.
            namespace eval $curr_message {
                set enums [dict create]
                set fields [dict create v2d {} k2v {}]
            }
            variable all_messages
            lappend all_messages $curr_message
        }
        get    { return $curr_message }
        set    { set curr_message $a }
    }
    set curr_message
}
# ******************************************************************************
# ##############################################################################
# Interpreter inside of 'enum'.
# ******************************************************************************
proc pb::enum_itp::// {args} { }
# ******************************************************************************
    ;# Example(3):  enum E { a; b; c = 7; d=8; e=9; }
    ;#     _unknown a
    ;#     _unknown b
    ;#     _unknown c = 7
    ;#     _unknown d=8
    ;#     _unknown e=9
    ;# 
    ;# I do not allow options inside enums!  TODO: Does the spec?
    ;# 
proc pb::enum_itp::_unknown {key args} {
    # --- fill enum-dict!
    set m [::pb::curr_message get]
    upvar #0 ${m}::enums enums  ::pb::curr_enum curr_enum
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    upvar #0 ${m}::enumLastVal($curr_enum) lastVal

    if {![info exists lastVal]} { set lastVal -1 }
    if {[llength $args]} {
        ::pb::assert {[lindex $args 0] eq "="}
        set val [lindex $args 1]
    } else {
        set val [incr lastVal]
    }
    set lastVal $val
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    if {[dict exists $enums $curr_enum k2v $key]} {
        error "*** error: multiple used key in enum $curr_enum"
    }
    if {[dict exists $enums $curr_enum v2k $val]} {
        error "*** error: multiple used value in enum $curr_enum"
    }
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    dict set enums $curr_enum k2v $key $val
    dict set enums $curr_enum v2k $val $key
}
# ##############################################################################
# Interpreter innerhalb von 'message'.
# ******************************************************************************
proc pb::msg_itp::// {args} { }
# ******************************************************************************
proc pb::msg_itp::enum {nm body} {
    set m [::pb::curr_message get]
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    dict set ${m}::enums $nm k2v {}
    dict set ${m}::enums $nm v2k {}
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    set ::pb::curr_enum $nm
    set ::pb::curr_enum_val -1
    $::pb::enum_itp eval $body
}
# ******************************************************************************
    ;# 'Nested extension'
    ;# ------------------
    ;# Example(ext11):
    ;#     message Baz {
    ;#         extend Foo {
    ;#             optional int32 bar = 126;
    ;#         }
    ;#         ...
    ;#     }
    ;# 
    ;# The C++ code to access this extension is:
    ;#    Foo foo;   foo.SetExtension(Baz::bar, 15);
    ;# 
    ;# Example(ext12):
    ;#     message Baz {
    ;#         extend Foo {
    ;#             optional Baz bar = 127;
    ;#         }
    ;#         ...
    ;#     }
    ;#     
    ;# "Language Guide#Nested Extensions":
    ;#     ...All it means is that the symbol 'bar' is declared inside the scope
    ;#     of Baz; it's simply a static member...
    ;# 
    ;# =========================================================================
    ;# fm, TODO: What's the point of 'nested extensions'?
    ;#     They seem to complicate things for no reason/benefit at all!?
    ;# 
proc pb::msg_itp::extend {nm body} {
    set m [::pb::curr_message get]
    xxx!
}
# ******************************************************************************
    ;# 'Language Guide':
    ;#     ...Extensions let you declare that a range of field numbers in a
    ;#     message are available for third-party extensions...
    ;# 
    ;#     ...max is 2**29-1, or 536,870,911...
    ;#     Avoid field numbers 19000 though 19999... You can define an
    ;#     extension range that includes this range, but the protocol compiler
    ;#     will not allow you to define actual extensions with these numbers.
    ;# 
proc pb::msg_itp::extensions {von {to {}} {bis {}}} {
    set m [::pb::curr_message get]
    if {$bis eq {}} { set bis $von } elseif {$bis eq "max"} { set bis 536870911 }
    set ${m}::extensions [list $von $bis]
}
# ******************************************************************************
    ;# Jede Message in einen extra Namespace!
    ;# 
proc pb::msg_itp::message {name body} { ;#! name
    set m [::pb::curr_message get]
    ::pb::curr_message create ${m}::$name

    $::pb::msg_itp eval $body

    ::pb::curr_message set $m
}
# ******************************************************************************
    ;# kind in {optional repeated required}
    ;# 'opts'  := result of 'pbOptionList'
    ;# 
    ;# "Groups" are NOT SUPPORTED! ('Language-Guide: groups are deprecated')
    ;#     Example(5,not-supported):   'repeated group Result = 1 { ... }'
    ;# 
proc pb::msg_itp::_kind {kind type nm eq val {opts {}}} {
    set m [::pb::curr_message get]
    upvar #0 ${m}::fields fields
    if {[dict exists $fields v2d $val]} {
        error "*** ${m} multiple used field_num: $val"
    }
    upvar #0 ::pb::predefinedTypes predefinedTypes
    if {[info exists predefinedTypes($type)]} {
        dict set fields v2d $val wt $predefinedTypes($type)  ;# wire_type
    } else {
        dict set fields v2d $val wt {}
        # Support type-syntax 'Parent.Type'.
        # Allow forward-declarations!  => Do the name-resolution later.
        upvar #0 ::pb::namesToResolve namesToResolve
        lappend namesToResolve $m $nm $val
    }
    # --- 'v2d' := value2data;  'k2v' := key2value;
    dict set fields v2d $val type $type
    dict set fields v2d $val kind $kind
    dict set fields v2d $val name $nm
    dict set fields k2v $nm $val
    switch -- $kind {
        optional {
            if {[dict exists $opts default]} {
                set default [dict get $opts default]
                switch -- $type {
                    bool { set default [string is true $default] }
                }
                dict set fields v2d $val default $default
            }
        }
        repeated {
            # Only repeated fields of primitive numeric types (types which use
            # the varint, 32-bit, or 64-bit wire types) can be declared "packed".
            if {[dict exists $opts packed] && [string is true [dict get $opts packed]]} {
                dict set fields v2d $val kind packed
            }
        }
        required {
        }
    }
}
# ******************************************************************************
proc pb::msg_itp::_ignored {args} { }
# ******************************************************************************
    ;# Some options:  ctype, default, deprecated, packed
    ;# xxx "custom options":  (field_opt1) etc.
    ;# 
proc pb::msg_itp::pbOptionList {a} {
    set x [dict create]
    set s expectOpt
    foreach i $a {
        switch -- $i {
            ,  {
                switch $s {
                    expectEq  { set s expectOpt ;# xxx
                    }
                    expectOpt { }
                    expectVal { set val $i;  set s expectOpt }
                }
            }
            =  {
                switch $s {
                    expectEq  { set s expectVal }
                    expectOpt { error "*** syntax error: [info level 0]" }
                    expectVal { set val $i;  set s expectOpt }
                }
            }
            default {
                switch $s {
                    expectOpt { set opt $i;  set s expectEq }
                    expectVal {
                        set val $i
                    }
                }
            }
        }
        if {[info exists opt] && [info exists val]} {
            dict set x $opt $val
            # xxx
            # xxx ($option ne "default")
            # xxx  set ::pb::msg_default [list $key $val]
            unset -nocomplain opt val
        }
    }
    set x
}
# ******************************************************************************
proc pb::msg_itp::_unknown {args} {
}
# ##############################################################################
proc pb::itp::// {args} { }
# ******************************************************************************
proc pb::itp::enum {nm body} {
    pb::msg_itp::enum $nm $body
}
# ******************************************************************************
    ;# see "Language Guide#Extensions"
    ;# 
    ;# Example(ext1):
    ;#    extend google.protobuf.FileOptions {..}
    ;# 
    ;# Example(ext2):
    ;#    extend Foo { optional int32 bar = 126; }
    ;# 
    ;# ...However, the way you access extension fields in your application
    ;# code is slightly different to accessing regular fields...
    ;# ...in C++:    Foo foo;   foo.SetExtension(bar, 15);
    ;#
    ;# fm: not in this Tcl-implementation! I see no reason to
    ;#     treat extension-fields any different from regular fields.
    ;# 
proc pb::itp::extend {nm body} {
    xxx!
}
# ******************************************************************************
proc pb::itp::import {a} {
    upvar #0 ::pb::import_path import_path
    foreach i $import_path {
        set f [file join $i $a]
        if {[file exists $f]} {
            set pdct [::pb::_ParseProtofile $f]
            break
        }
    }
}
# ******************************************************************************
proc pb::itp::message {name body} { ;#! name
    ::pb::curr_message create ::pb::msg::$name
    $::pb::msg_itp eval $body
    ::pb::curr_message set ::pb::msg
}
# ******************************************************************************
    ;# --- for the time being options are ignored.
    ;#     
    ;# Example(opt1):
    ;#     option (google.protobuf.csharp_file_options).namespace = "Google.ProtocolBuffers.Examples.AddressBook"; 
    ;#     option (google.protobuf.csharp_file_options).umbrella_classname = "AddressBookProtos"; 
    ;#      
    ;#     option optimize_for = SPEED;
    ;# 
    ;# See:  https://code.google.com/p/protobuf-csharp-port/wiki/DescriptorOptions
    ;# 
proc pb::itp::option {args} { }
# ******************************************************************************
proc pb::itp::package {pkgName} {
    # xxx 'package': see "Language Guide#Packages"
    xxx! now wrap all messages into namespace ::pb::pkg::$pkgName
}
# ******************************************************************************
proc pb::itp::_ignored {args} { }
# ******************************************************************************
proc pb::itp::_unknown {args} {
}
# ##############################################################################
======


Now "wire.tcl":

======
# ##############################################################################
# ******************************************************************************
proc pb::enc_uint64 {e a} {
    upvar 1 $e x
    ;#assert {$a >= 0}
    ;# --- split $a into 7-bit chunks.
    if {$a < 128} {  ;# 2**7
        append x [binary format c $a]
        return 1
    } elseif {$a < 16384} {  ;# 2**14
        append x [binary format c [expr {($a & 127) | 128}]]
        append x [binary format c [expr {$a >> 7}]]
        return 2
    } elseif {$a < 2097152} {  ;# 2**21
        append x [binary format c [expr {($a & 127) | 128}]]
        append x [binary format c [expr {(($a >> 7) & 127) | 128}]]
        append x [binary format c [expr {$a >> 14}]]
        return 3
    }
    set n 0
    set sh 0
    while 1 {
        set b [expr {($a >> $sh) & 127}]
        incr sh 7
        incr n
        if {$a >> $sh} {
            append x [binary format c [expr {$b | 128}]]
        } else {
            append x [binary format c $b]
            return $n
        }
    }
}
# ******************************************************************************
proc pb::enc_int64 {e a} {
    upvar 1 $e x
    if {$a >= 0} {
        ;# --- split $a into 7-bit chunks.
        if {$a < 128} {  ;# 2**7
            append x [binary format c $a]
            return 1
        } elseif {$a < 16384} {  ;# 2**14
            append x [binary format c [expr {($a & 127) | 128}]]
            append x [binary format c [expr {$a >> 7}]]
            return 2
        } elseif {$a < 2097152} {  ;# 2**21
            append x [binary format c [expr {($a & 127) | 128}]]
            append x [binary format c [expr {(($a >> 7) & 127) | 128}]]
            append x [binary format c [expr {$a >> 14}]]
            return 3
        }
    } else {
        # --- treat negative numbers as big unsigneds.
        binary scan [binary format w $a] wu a
    }
    set n 0
    set sh 0
    while 1 {
        set b [expr {($a >> $sh) & 127}]
        incr sh 7
        incr n
        if {$a >> $sh} {
            append x [binary format c [expr {$b | 128}]]
        } else {
            append x [binary format c $b]
            return $n
        }
    }
}
# ******************************************************************************
proc pb::enc_sint64 {e a} {
    upvar 1 $e x
    if {$a >= 0} {
        return [enc_uint64 x [expr {$a << 1}]]
    } else {
        return [enc_uint64 x [expr {((-$a) << 1) - 1}]]
    }
}
# ******************************************************************************
proc pb::enc_bool {e a} {
    upvar 1 $e x
    if {$a} { append x [binary format c 1] } else { append x [binary format c 0] }
    return 1
}
# ******************************************************************************
    ;# TODO: How do I ensure that this writes 64 bit on every machine?
    ;# 
proc pb::enc_double {e a} { upvar 1 $e x;
    assert {[string length [binary format q $a]] == 8}
    append x [binary format q $a];
    return 8
}
# ******************************************************************************
    ;# TODO: How do I ensure that this writes 32 bit on every machine?
    ;# 
proc pb::enc_float {e a} { upvar 1 $e x;
    assert {[string length [binary format r $a]] == 4}
    append x [binary format r $a];
    return 4
}
# ******************************************************************************
proc pb::enc_fieldnum_wiretype {e field_num wire_type} {
    upvar 1 $e x
    switch $wire_type {
        3 - 4 { error "*** not implemented: (wire_type==$wire_type)" }
    }
    enc_uint64 x [expr {($field_num << 3) | $wire_type}]
}
# ******************************************************************************
proc pb::enc_string {e a} {
    upvar 1 $e x
    set a [encoding convertto utf-8 $a]
    set len [string length $a]
    set n [enc_uint64 x $len]
    append x [binary format a* $a]
    incr n $len
}
# ******************************************************************************
proc pb::enc_bytes {e a} {
    upvar 1 $e x
    set len [string length $a]
    set n [enc_uint64 x $len]
    append x [binary format a* $a]
    incr n $len
}
# ******************************************************************************
proc pb::enc_fixed64 {e a} { upvar 1 $e x;  append x $a;  incr n 8 }
# ******************************************************************************
proc pb::enc_fixed32 {e a} { upvar 1 $e x;  append x $a;  incr n 4 }
# ******************************************************************************
interp alias {} ::pb::enc_int32 {} ::pb::enc_int64
# ******************************************************************************
interp alias {} ::pb::enc_uint32 {} ::pb::enc_uint64
# ******************************************************************************
interp alias {} ::pb::enc_enum {} ::pb::enc_int64
# ******************************************************************************
interp alias {} ::pb::enc_sint32 {} ::pb::enc_sint64
# ******************************************************************************
interp alias {} ::pb::enc_sfixed64 {} ::pb::enc_fixed64
# ******************************************************************************
interp alias {} ::pb::enc_sfixed32 {} ::pb::enc_fixed32
# ******************************************************************************
    ;# cf. '_enc {*}$type' in 'enc_message'.
    ;# 
proc pb::enc_Enum {aEnums nm1 e val} {
    upvar #0 $aEnums enums
    upvar 1 $e x
    enc_uint64 x [dict get $enums $nm1 k2v $val]
}
# ******************************************************************************
    ;# 'embedded-message'
    ;# cf. '_enc {*}$type' in 'enc_message'.
    ;# 
proc pb::enc_Msg {ns e val} {
    upvar 1 $e x
    set n [enc_message code $ns $val]
    incr n [enc_uint64 x $n]
    append x $code
    set n
}
# ******************************************************************************
proc pb::_enc {a args} { uplevel 1 enc_$a $args }
# ******************************************************************************
proc pb::enc_message {e ns dct} {
    upvar 1 $e x
    upvar #0 ${ns}::fields fields
    set n 0
    set li {}
    dict for {fld val} $dct {
        if {![dict exists $fields k2v $fld]} {
            ! _unknown_field
            if {[string match _unknown_field* $fld]} {
                xxx support "unknown fields"
            }
            continue
        }
        set code {}
        set fnum [dict get $fields k2v $fld]
        set type [dict get $fields v2d $fnum type]
        set wt   [dict get $fields v2d $fnum wt]
        set kind [dict get $fields v2d $fnum kind]
        #! kind type wt fnum fld val
        switch $kind {
            required -
            optional {
                incr n [enc_fieldnum_wiretype code $fnum $wt]
                incr n [_enc {*}$type code $val]
            }
            repeated {
                set c1 {}
                set n1 [enc_fieldnum_wiretype c1 $fnum $wt]
                foreach v1 $val {
                    incr n $n1;  append code $c1
                    incr n [_enc {*}$type code $v1]
                }
            }
            packed {
                incr n [enc_fieldnum_wiretype code $fnum 2]
                set c1 {}
                set n1 0
                foreach v1 $val {
                    incr n1 [_enc {*}$type c1 $v1]
                }
                incr n [enc_uint64 code $n1]
                incr n $n1
                append code $c1
            }
            default { error "*** internal error:  unknown kind=[list $kind]" }
        }
        lappend li [list $fnum $code]
    }

    # --- sort by field-number
    foreach i [lsort -integer -index 0 $li] {
        if 0 { set fnum [lindex $i 0]; set bits [bits [lindex $i 1]]; ! fnum bits }
        append x [lindex $i 1]
    }
    set n
}
# ******************************************************************************
proc pb::enc_message_delimited {e ns dct} {
    upvar 1 $e x
    set n [enc_message code $ns $dct] ;#! n
    incr n [enc_uint64 x $n]
    append x $code
    set n
}
# ##############################################################################
proc pb::_dec {a args} { uplevel 1 dec_$a $args }
# ******************************************************************************
proc pb::_rd {numVar rd nb} {
    upvar #0 $numVar num
    if {$num < $nb} {
        return -code error "*** trying to read too many bytes!"
    }
    set num [expr {$num-$nb}]
    {*}$rd $nb
}
# ******************************************************************************
proc pb::wrap_rd {aRd nb} {
    upvar 1 $aRd rd
    variable inflate
    set var ::pb::tmp::rd[incr inflate]
    set $var $nb
    set rd [list ::pb::_rd $var $rd]
    #!! rd nb
    set var
}
# ##############################################################################
proc pb::write_message_delimited {fid ns dct} {
    chan configure $fid  -translation binary  -encoding binary
    set code {}
    set n [enc_message_delimited code $ns $dct]
    puts -nonewline $fid $code
    set n
}
# ##############################################################################
proc pb::read_message {fid ns dct} {
    upvar 1 $dct x
    set blocking [chan configure $fid -blocking]
    chan configure $fid  -translation binary  -encoding binary  -blocking 1
    set rd [list ::read $fid]
    set var [wrap_rd rd [expr {1<<63}]]
    set n [dec_message $var $rd $ns x]
    chan configure $fid -blocking $blocking
    set n
}
# ******************************************************************************
proc pb::read_message_delimited {fid ns dct} {
    upvar 1 $dct x
    set blocking [chan configure $fid -blocking]
    chan configure $fid  -translation binary  -encoding binary  -blocking 1
    set rd [list ::read $fid]
    #set rd [list ::pb::readAndPrnt $fid]
    set n [dec_uint64 {} $rd len]
    # --- 'len' read, now decode message (must have $len bytes)
    set var [wrap_rd rd $len]
    incr n [dec_message $var $rd $ns x]
    unset $var
    chan configure $fid -blocking $blocking
    set n
}
# ##############################################################################
    ;# Memo:
    ;#  1. A protocol buffer message is a series of key-value pairs.
    ;#  2. Each key is a varint with the value ((field_number << 3) | wire_type).
    ;#     In other words, the last three bits of the number store the wire type.
    ;# 
proc pb::dec_message {aVar rd ns dct} {
    upvar #0 $aVar var
    upvar 1 $dct x
    upvar #0 ${ns}::fields fields
    upvar #0 ${ns}::msg0 msg0
    set x $msg0
    set n 0
    while {$var} {
        #! var rd
        incr n [dec_fieldnum_wiretype $aVar $rd fld wt]
        #! fld wt

        if {[dict exists $fields v2d $fld]} {
            set type [dict get $fields v2d $fld type]
            set name [dict get $fields v2d $fld name]
            #! type name
            switch [set kind [dict get $fields v2d $fld kind]] {
                packed {
                    assert {$wt == 2}
                    incr n [dec_uint64 {} $rd n1]
                    set rd1 $rd
                    upvar #0 [set aVar1 [wrap_rd rd1 $n1]] var1
                    set val {}
                    while {$var1} {
                        incr n [_dec {*}$type $aVar1 $rd1 val1]
                        lappend val $val1
                    }
                }
                default { incr n [_dec {*}$type $aVar $rd val] }
            }
            #! val
            dict set x $name $val
        } else { ;#! --- unknown field  => skip!
            switch $wt {
                0 { ;# 'varint': int32, int64, uint32, uint64, sint32, sint64, bool, enum
                    set val [dec_varint $aVar $rd]
                    #set val [dec_int32 $aVar $rd x];  ! val
                    #set val [dec_sint32 $aVar $rd x];  ! val
                }
                1 { ;# '64-bit': fixed64, sfixed64, double
                    xxx ukn wt=$wt
                }
                2 { ;# 'length-delimited': string, bytes, embedded message, packed repeated field
                    xxx ukn wt=$wt
                }
                3 { ;# 'Start_group': (deprecated)
                    error "*** not implemented: (wire_type==3)"
                }
                4 { ;# 'End_group': (deprecated)
                    error "*** not implemented: (wire_type==4)"
                }
                5 { ;# '32-bit': fixed32, sfixed32, float
                    xxx ukn wt=$wt
                }
            }
            # xxx es können mehrere sein => durchnummerieren!
            # xxx den Typ ebenfalls mitgerücksichtigen!
            dict set x _unknown_field $val
        }
    }
    set n
}
# ******************************************************************************
proc pb::dec_message_delimited {aVar rd ns dct} {
    upvar 1 $dct x
    set n [dec_uint64 $aVar $rd nb]
    set _ [dec_message $aVar $rd $ns x]
    incr n $nb
}
# ******************************************************************************
    ;# 'b' := a binary byte;
    ;# 'i' := a signed(!) integer;
    ;# 'x' := field_num = uint;
    ;# ... 'The smallest field_number is 1, and the largest is 2**29-1, or 536,870,911' ...
    ;# Returns number of bytes read.
    ;# 
proc pb::dec_fieldnum_wiretype {aVar rd aFieldnum aWiretype} {
    upvar 1 $aFieldnum x  $aWiretype wire_type

    binary scan [{*}$rd 1] c i;    set x [expr {($i & 120) >> 3}]
    set wire_type [expr {$i & 7}]
    if {!($i & 128)} { return 1 }
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    # 'int32':  shift = 4 11 18; # avoid negativ numbers i.e. bit 32.
    binary scan [{*}$rd 1] c i;    set x [expr {((127 & $i) << 4) | $x}]
    if {!($i & 128)} { return 2 }

    binary scan [{*}$rd 1] c i;    set x [expr {((127 & $i) << 11) | $x}]
    if {!($i & 128)} { return 3 }

    binary scan [{*}$rd 1] c i;    set x [expr {((127 & $i) << 18) | $x}]
    if {!($i & 128)} { return 4 }
    # == == == == == == == == == == == == == == == == == == == == == == == == =
    binary scan [{*}$rd 1] c i
    if {!($i & 128)} {  ;# (192==128+64):  bits 8, 7 are not set. (positiv int32)
        set x [expr {((127 & $i) << 25) | $x}]
        return 5
    }
    error "*** Spec says we never should reach here!"
}
# ******************************************************************************
    ;# Returns number of bytes read.
    ;# 'int32';  shift = 0 7 14 21 (28)
    ;# Enrolling the loop is a first attempt to optimize for speed.
    ;# (It is an optimization method that is better suited for C).
    ;# 
    ;# "Encoding.pdf":
    ;#     "...If you use int32 or int64 as the type for a negative number,
    ;#     the resulting varint is always ten bytes long..."
    ;# 
proc pb::dec_int64 {aVar rd a} {
    upvar 1 $a x
    binary scan [{*}$rd 1] c i0
    if {!($i0 & 128)} {set x $i0;  return 1 }

    # >>> generated code:  g1 0 10
    binary scan [{*}$rd 1] c i1
    if {!($i1 & 128)} {set x [expr {(127 & $i0) | ($i1 << 7)}];  return 2}
    binary scan [{*}$rd 1] c i2
    if {!($i2 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ($i2 << 14)}];  return 3}
    binary scan [{*}$rd 1] c i3
    if {!($i3 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ($i3 << 21)}];  return 4}
    binary scan [{*}$rd 1] c i4
    if {!($i4 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ($i4 << 28)}];  return 5}
    binary scan [{*}$rd 1] c i5
    if {!($i5 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ($i5 << 35)}];  return 6}
    binary scan [{*}$rd 1] c i6
    if {!($i6 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ((127 & $i5) << 35) | ($i6 << 42)}];  return 7}
    binary scan [{*}$rd 1] c i7
    if {!($i7 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ((127 & $i5) << 35) | ((127 & $i6) << 42) | ($i7 << 49)}];  return 8}
    binary scan [{*}$rd 1] c i8
    if {!($i8 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ((127 & $i5) << 35) | ((127 & $i6) << 42) | ((127 & $i7) << 49) | ($i8 << 56)}];  return 9}
    binary scan [{*}$rd 1] c i9
    # <<< generated code

    # --- Negative numbers.
    if {$i9 != 1} { error "*** number does not fit into 64 bit!" }
    set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ((127 & $i5) << 35) | ((127 & $i6) << 42) | ((127 & $i7) << 49)}];
    # --- Now all 56 bits fit and only the sign-byte (8 bit) is missing.
    set h [expr {128 | (127 & $i8)}]
    binary scan [binary format wXc $x $h] w x
    return 10
}
# ******************************************************************************
interp alias {} ::pb::dec_int32 {} ::pb::dec_int64
# ******************************************************************************
interp alias {} ::pb::dec_bool {} ::pb::dec_int64
# ******************************************************************************
    ;# 'ZigZag encoding' ("Encoding.pdf"):
    ;#     -1 is encoded as 1, 1 is encoded as 2, -2 is encoded as 3, and so on.
    ;#     each value n is encoded using:  (n << 1) ^ (n >> 63);
    ;#     Note that the second shift [the (n >> 63) part] is an arithmetic shift.
    ;#     So, in other words, the result of the shift is either a number that is
    ;#     all zero bits (if n is positive) or all one bits (if n is negative).
    ;# 
proc pb::dec_sint64 {aVar rd a} {
    upvar 1 $a x
    set n [dec_int64 $aVar $rd x]
    if {$x & 1} {  ;# encoded(negative-number)
        set x [expr {-(($x + 1) >> 1)}]
    } else {       ;# encoded(positive-number)
        set x [expr {$x >> 1}]
    }
    set n
}
# ******************************************************************************
interp alias {} ::pb::dec_sint32 {} ::pb::dec_sint64
# ******************************************************************************
    ;# Read 'uint32', 'uint64'; # Tcl could do even more.
    ;# 
proc pb::dec_uint64 {aVar rd a} {
    upvar 1 $a x
    binary scan [{*}$rd 1] c i0
    if {!($i0 & 128)} {set x $i0;  return 1 }

    # >>> generated code:  g1 0 10
    binary scan [{*}$rd 1] c i1
    if {!($i1 & 128)} {set x [expr {(127 & $i0) | ($i1 << 7)}];  return 2}
    binary scan [{*}$rd 1] c i2
    if {!($i2 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ($i2 << 14)}];  return 3}
    binary scan [{*}$rd 1] c i3
    if {!($i3 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ($i3 << 21)}];  return 4}
    binary scan [{*}$rd 1] c i4
    if {!($i4 & 128)} {set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ($i4 << 28)}];  return 5}
    # <<< generated code

    binary scan [{*}$rd 1] c i
    set x [expr {(127 & $i0) | ((127 & $i1) << 7) | ((127 & $i2) << 14) | ((127 & $i3) << 21) | ((127 & $i4) << 28) | ((127 & $i) << 35)}]
    if {!($i & 128)} {return 6}

    set shift 35
    set n 6
    while {$i & 128} {
        binary scan [read $fid 1] c i
        incr n
        set x [expr {((127 & $i) << [incr shift 7]) | $x}]
    }
    set n
}
# ******************************************************************************
interp alias {} ::pb::dec_uint32 {} ::pb::dec_uint64
# ******************************************************************************
    ;# I don't know what that 'fixed'-thing should be; so I treat it as bytes.
    ;# TODO: 'fixed64', 'fixed32', 'sfixed64', 'sfixed32' as datatypes??
    ;# 
proc pb::dec_fixed32 {aVar rd a} { upvar 1 $a x;  set x [{*}$rd 4];  return 4 }
# ******************************************************************************
proc pb::dec_fixed64 {aVar rd a} { upvar 1 $a x;  set x [{*}$rd 8];  return 8 }
# ******************************************************************************
interp alias {} ::pb::dec_sfixed64 {} ::pb::dec_fixed64
# ******************************************************************************
interp alias {} ::pb::dec_sfixed32 {} ::pb::dec_fixed32
# ******************************************************************************
proc pb::dec_float {aVar rd a} { upvar 1 $a x;  binary scan [{*}$rd 4] r x;  return 4 }
# ******************************************************************************
proc pb::dec_double {aVar rd a} { upvar 1 $a x;  binary scan [{*}$rd 8] q x;  return 8 }
# ******************************************************************************
    ;# 
    ;# 
proc pb::dec_string {aVar rd a} {
    upvar 1 $a x
    set n [dec_uint64 $aVar $rd len]
    incr n $len ;#! len
    set _ [binary scan [{*}$rd $len] a$len y]
    set x [encoding convertfrom utf-8 $y]
    set n
}
# ******************************************************************************
    ;# Read 'int32', 'int64', 'int28';
    ;# 
    ;# 
    ;# --- binary scan [set b0 [read $fid 1]] c i0;  testeBits b0
    ;# 
proc pb::dec_varint {aVar rd a} {
    upvar 1 $a x
    set shift -7
    set n 0
    set x 0
    set i 128
    while {$i & 128} {
        incr n
        binary scan [{*}$rd 1] c i
        set x [expr {((127 & $i) << [incr shift 7]) | $x}]
    }
    set n
}
# ******************************************************************************
proc pb::dec_Enum {aEnums nm1 aVar rd a} {
    upvar 1 $a x
    set n [dec_uint64 $aVar $rd val] ;#! val
    upvar #0 $aEnums enums
    set x [dict get $enums $nm1 v2k $val]
    set n
}
# ******************************************************************************
proc pb::dec_Msg {ns aVar rd a} {
    upvar 1 $a x
    set n [dec_message_delimited $aVar $rd $ns x]
}
# ******************************************************************************
# ##############################################################################
======


<<categories>>Enter Category Here