1# This was imported into gdb from:
2# https://github.com/jorge-leon/ton
3
4# This software is copyrighted by Georg Lehner <jorge@at.anteris.net>.
5# The following terms apply to all files associated with the software
6# unless explicitly disclaimed in individual files.
7
8# The authors hereby grant permission to use, copy, modify, distribute,
9# and license this software and its documentation for any purpose,
10# provided that existing copyright notices are retained in all copies
11# and that this notice is included verbatim in any distributions. No
12# written agreement, license, or royalty fee is required for any of the
13# authorized uses.  Modifications to this software may be copyrighted by
14# their authors and need not follow the licensing terms described here,
15# provided that the new terms are clearly indicated on the first page of
16# each file where they apply.
17
18# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
19# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
20# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
21# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
22# POSSIBILITY OF SUCH DAMAGE.
23
24# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
25# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
26# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
27# NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND
28# THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
29# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
30
31# GOVERNMENT USE: If you are acquiring this software on behalf of the
32# U.S. government, the Government shall have only "Restricted Rights" in
33# the software and related documentation as defined in the Federal
34# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
35# are acquiring the software on behalf of the Department of Defense, the
36# software shall be classified as "Commercial Computer Software" and the
37# Government shall have only "Restricted Rights" as defined in Clause
38# 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
39# authors grant the U.S. Government and others acting in its behalf
40# permission to use and distribute the software in accordance with the
41# terms specified in this license.
42
43
44# leg20180331: ton / TON - Tcl Object Notation
45#
46# This package provides manipulation functionality for TON - a data
47# serialization format with a direct mapping to JSON.
48#
49# In its essence, a JSON parser is provided, which can convert a JSON
50# string into a Tcllib json style dictionary (dicts and arrays mixed),
51# into a jimhttp style dictionary (only dicts) or into a nested, typed
52# Tcl list.
53#
54# Finally, TON can be converted into (unformatted) JSON.
55
56namespace eval ton {
57    namespace export json2ton
58
59    variable version 0.4
60
61}
62proc ton::json2ton json {
63    # Parse JSON string json
64    #
65    # return: TON
66
67    set i [trr $json [string length $json]]
68    if {!$i} {return ""}
69    lassign [jscan $json $i] i ton
70    if {[set i [trr $json $i]]} {
71          error "json string invalid:[incr i -1]: left over characters."
72    }
73    return $ton
74}
75proc ton::trr {s i} {
76    # Trim righthand whitespace on the first i characters of s.
77    # return: number of remaining characters in s
78
79    while {[set j $i] &&
80             ([string is space [set c [string index $s [incr i -1]]]]
81              || $c eq "\n")} {}
82    return $j
83}
84proc ton::jscan {json i {d :}} {
85    # Scan JSON in first i characters of string json.
86    # d is the default delimiter list for the next token.
87    #
88    # return list of
89    # - remaining characters in json
90    # - TON
91    #
92    # The string must already be whitespace trimmed from the right.
93
94    incr i -1
95
96    if {[set c [string index $json $i]] eq "\""} {
97          str $json [incr i -1]
98    } elseif {$c eq "\}"} {
99          obj $json $i
100    } elseif {$c eq "\]"} {
101          arr $json $i
102    } elseif {$c in {e l}} {
103          lit $json $i
104    } elseif {[string match {[0-9.]} $c]} {
105          num $json $i $c $d
106    } else {
107          error "json string end invalid:$i: ..[string range $json $i-10 $i].."
108    }
109}
110proc ton::num {json i c d} {
111    # Parse number from position i in string json to the left.
112    # c .. character at position i
113    # d .. delimiter on which to stop
114    #
115    # return list:
116    # - remaining string length
117    # - TON of number
118
119    set float [expr {$c eq "."}]
120    for {set j $i} {$i} {incr i -1} {
121          if {[string match $d [set c [string index $json $i-1]]]} break
122          set float [expr {$float || [string match "\[eE.]" $c]}]
123    }
124    set num [string trimleft [string range $json $i $j]]
125    if {!$float && [string is entier $num]} {
126              list $i "i $num"
127    } elseif {$float && [string is double $num]} {
128          list $i "d $num"
129    } else {
130          error "number invalid:$i: $num."
131    }
132}
133proc ton::lit {json i} {
134    # Parse literal from position i in string json to the left
135    # return list:
136    # - remaining string length
137    # - TON of literal
138
139    if {[set c [string index $json $i-1]] eq "u"} {
140          list [incr i -3] "l true"
141    } elseif {$c eq "s"} {
142          list [incr i -4] "l false"
143    } elseif {$c eq "l"} {
144          list [incr i -3] "l null"
145    } else {
146          set e [string range $json $i-3 $i]
147          error "literal invalid:[incr i -1]: ..$e."
148    }
149}
150proc ton::str {json i} {
151    # Parse string from position i in string json to the left
152    # return list:
153    # - remaining string length
154    # - TON of string
155
156    for {set j $i} {$i} {incr i -1} {
157          set i [string last \" $json $i]
158          if {[string index $json $i-1] ne "\\"} break
159    }
160    if {$i==-1} {
161          error "json string start invalid:$i: exhausted while parsing string."
162    }
163    list $i "s [list [string range $json $i+1 $j]]"
164}
165proc ton::arr {json i} {
166    # Parse array from i characters in string json
167    # return list:
168    # - remaining string length
169    # - TON of array
170
171    set i [trr $json $i]
172    if {!$i} {
173          error "json string invalid:0: exhausted while parsing array."
174    }
175    if {[string index $json $i-1] eq "\["} {
176          return [list [incr i -1] a]
177    }
178    set r {}
179    while {$i} {
180          lassign [jscan $json $i "\[,\[]"] i v
181          lappend r \[$v\]
182          set i [trr $json $i]
183          incr i -1
184          if {[set c [string index $json $i]] eq ","} {
185              set i [trr $json $i]
186              continue
187          } elseif {$c eq "\["} break
188          error "json string invalid:$i: parsing array."
189    }
190    lappend r a
191    return [list $i [join [lreverse $r]]]
192}
193proc ton::obj {json i} {
194    # Parse array from i character in string json
195    # return list:
196    # - remaining string length
197    # - TON of object
198
199    set i [trr $json $i]
200    if {!$i} {
201          error "json string invalid:0: exhausted while parsing object."
202    }
203    if {[string index $json $i-1] eq "\{"} {
204          return [list [incr i -1] o]
205    }
206    set r {}
207    while {$i} {
208          lassign [jscan $json $i] i v
209          set i [trr $json $i]
210          incr i -1
211          if {[string index $json $i] ne ":"} {
212              error "json string invalid:$i: parsing key in object."
213          }
214          set i [trr $json $i]
215          lassign [jscan $json $i] i k
216          lassign $k type k
217          if {$type ne "s"} {
218              error "json string invalid:[incr i -1]: key not a string."
219          }
220          lappend r \[$v\] [list $k]
221          set i [trr $json $i]
222          incr i -1
223          if {[set c [string index $json $i]] eq ","} {
224              set i [trr $json $i]
225              continue
226          } elseif {$c eq "\{"} break
227          error "json string invalid:$i: parsing object."
228    }
229    lappend r o
230    return [list $i [join [lreverse $r]]]
231}
232# TON decoders
233namespace eval ton::2list {
234    proc atom {type v} {list $type $v}
235    foreach type {i d s l} {
236          interp alias {} $type {} [namespace current]::atom $type
237    }
238    proc a args {
239          set r a
240          foreach v $args {lappend r $v}
241          return $r
242    }
243    proc o args {
244          set r o
245          foreach {k v} $args {lappend r $k $v}
246          return $r
247    }
248    # There is plenty of room for validation in get
249    # array index bounds
250    # object key existence
251    proc get {l args} {
252          foreach k $args {
253              switch [lindex $l 0] {
254                    o {set l [dict get [lrange $l 1 end] $k]}
255                    a {set l [lindex $l [incr k]]}
256                    default {
257                        error "error: key $k to long, or wrong data: [lindex $l 0]"
258                    }
259              }
260          }
261          return $l
262    }
263}
264namespace eval ton::2dict {
265    proc atom v {return $v}
266    foreach type {i d l s} {
267          interp alias {} $type {} [namespace current]::atom
268    }
269    proc a args {return $args}
270    proc o args {return $args}
271}
272namespace eval ton::a2dict {
273    proc atom v {return $v}
274    foreach type {i d l s} {
275          interp alias {} $type {} [namespace current]::atom
276    }
277    proc a args {
278          set i -1
279          set r {}
280          foreach v $args {
281              lappend r [incr i] $v
282          }
283          return $r
284    }
285    proc o args {return $args}
286}
287namespace eval ton::2json {
288    proc atom v {return $v}
289    foreach type {i d l} {
290          interp alias {} $type {} [namespace current]::atom
291    }
292    proc a args {
293          return "\[[join $args {, }]]"
294    }
295    proc o args {
296          set r {}
297          foreach {k v} $args {lappend r "\"$k\": $v"}
298          return "{[join $r {, }]}"
299    }
300    proc s s {return "\"$s\""}
301}
302
303package provide ton $ton::version
304