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.
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]
# ############################################################################### ##############################################################################
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} {
}
# ############################################################################### ##############################################################################
# ******************************************************************************
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]
}
# ******************************************************************************
# ##############################################################################This document, and the package it describes, might undoubtedly contain bugs and other problems. Please report such problems with title "protobuf" to
[string map {at @ x . ext .com} [append _ Florian x Murr "at" siemens ext]]Please also report any ideas for enhancements you may have for either package and/or documentation.
RLH What would one need to setup the environment to test this?
JMN see also https://grpc.io/