This is a first implementation of the Google-protobuf protocol in Tcl. See http://code.google.com/intl/de/apis/protocolbuffers/docs/overview.html;


======
# ##############################################################################
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} {
}
# ##############################################################################
======


<<categories>>Enter Category Here