· 6 years ago · Aug 31, 2019, 11:58 PM
1#
2# JSON parser for Tcl.
3#
4# See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
5#
6# Copyright 2006 ActiveState Software Inc.
7#
8# $Id: json.tcl,v 1.2 2006/08/25 23:19:53 hobbs Exp $
9#
10
11if {$::tcl_version < 8.5} {
12 package require dict
13}
14
15package provide json 1.3.3
16
17namespace eval json {}
18
19proc json::getc {{txtvar txt}} {
20 # pop single char off the front of the text
21 upvar 1 $txtvar txt
22 if {$txt eq ""} {
23 return -code error "unexpected end of text"
24 }
25
26 set c [string index $txt 0]
27 set txt [string range $txt 1 end]
28 return $c
29}
30
31proc json::json2dict {txt} {
32 return [_json2dict]
33}
34
35proc json::_json2dict {{txtvar txt}} {
36 upvar 1 $txtvar txt
37
38 set state TOP
39
40 set txt [string trimleft $txt]
41 while {$txt ne ""} {
42 set c [string index $txt 0]
43
44 # skip whitespace
45 while {[string is space $c]} {
46 getc
47 set c [string index $txt 0]
48 }
49
50 if {$c eq "\{"} {
51 # object
52 switch -- $state {
53 TOP {
54 # we are dealing with an Object
55 getc
56 set state OBJECT
57 set dictVal [dict create]
58 }
59 VALUE {
60 # this object element's value is an Object
61 dict set dictVal $name [_json2dict]
62 set state COMMA
63 }
64 LIST {
65 # next element of list is an Object
66 lappend listVal [_json2dict]
67 set state COMMA
68 }
69 default {
70 return -code error "unexpected open brace in $state mode"
71 }
72 }
73 } elseif {$c eq "\}"} {
74 getc
75 if {$state ne "OBJECT" && $state ne "COMMA"} {
76 return -code error "unexpected close brace in $state mode"
77 }
78 return $dictVal
79 } elseif {$c eq ":"} {
80 # name separator
81 getc
82
83 if {$state eq "COLON"} {
84 set state VALUE
85 } else {
86 return -code error "unexpected colon in $state mode"
87 }
88 } elseif {$c eq ","} {
89 # element separator
90 if {$state eq "COMMA"} {
91 getc
92 if {[info exists listVal]} {
93 set state LIST
94 } elseif {[info exists dictVal]} {
95 set state OBJECT
96 }
97 } else {
98 return -code error "unexpected comma in $state mode"
99 }
100 } elseif {$c eq "\""} {
101 # string
102 # capture quoted string with backslash sequences
103 set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
104 set string ""
105 if {![regexp $reStr $txt string]} {
106 set txt [string replace $txt 32 end ...]
107 return -code error "invalid formatted string in $txt"
108 }
109 set txt [string range $txt [string length $string] end]
110 # chop off outer ""s and substitute backslashes
111 # This does more than the RFC-specified backslash sequences,
112 # but it does cover them all
113 set string [subst -nocommand -novariable \
114 [string range $string 1 end-1]]
115
116 switch -- $state {
117 TOP {
118 return $string
119 }
120 OBJECT {
121 set name $string
122 set state COLON
123 }
124 LIST {
125 lappend listVal $string
126 set state COMMA
127 }
128 VALUE {
129 dict set dictVal $name $string
130 unset name
131 set state COMMA
132 }
133 }
134 } elseif {$c eq "\["} {
135 # JSON array == Tcl list
136 switch -- $state {
137 TOP {
138 getc
139 set state LIST
140 }
141 LIST {
142 lappend listVal [_json2dict]
143 set state COMMA
144 }
145 VALUE {
146 dict set dictVal $name [_json2dict]
147 set state COMMA
148 }
149 default {
150 return -code error "unexpected open bracket in $state mode"
151 }
152 }
153 } elseif {$c eq "\]"} {
154 # end of list
155 getc
156 if {![info exists listVal]} {
157 #return -code error "unexpected close bracket in $state mode"
158 # must be an empty list
159 return ""
160 }
161
162 return $listVal
163 } elseif {0 && $c eq "/"} {
164 # comment
165 # XXX: Not in RFC 4627
166 getc
167 set c [getc]
168 switch -- $c {
169 / {
170 # // comment form
171 set i [string first "\n" $txt]
172 if {$i == -1} {
173 set txt ""
174 } else {
175 set txt [string range $txt [incr i] end]
176 }
177 }
178 * {
179 # /* comment */ form
180 getc
181 set i [string first "*/" $txt]
182 if {$i == -1} {
183 return -code error "incomplete /* comment"
184 } else {
185 set txt [string range $txt [incr i] end]
186 }
187 }
188 default {
189 return -code error "unexpected slash in $state mode"
190 }
191 }
192 } elseif {[string match {[-0-9]} $c]} {
193 # one last check for a number, no leading zeros allowed,
194 # but it may be 0.xxx
195 string is double -failindex last $txt
196 if {$last > 0} {
197 set num [string range $txt 0 [expr {$last - 1}]]
198 set txt [string range $txt $last end]
199
200 switch -- $state {
201 TOP {
202 return $num
203 }
204 LIST {
205 lappend listVal $num
206 set state COMMA
207 }
208 VALUE {
209 dict set dictVal $name $num
210 set state COMMA
211 }
212 default {
213 getc
214 return -code error "unexpected number '$c' in $state mode"
215 }
216 }
217 } else {
218 getc
219 return -code error "unexpected '$c' in $state mode"
220 }
221 } elseif {[string match {[ftn]} $c]
222 && [regexp {^(true|false|null)} $txt val]} {
223 # bare word value: true | false | null
224 set txt [string range $txt [string length $val] end]
225
226 switch -- $state {
227 TOP {
228 return $val
229 }
230 LIST {
231 lappend listVal $val
232 set state COMMA
233 }
234 VALUE {
235 dict set dictVal $name $val
236 set state COMMA
237 }
238 default {
239 getc
240 return -code error "unexpected '$c' in $state mode"
241 }
242 }
243 } else {
244 # error, incorrect format or unexpected end of text
245 return -code error "unexpected '$c' in $state mode"
246 }
247 }
248}
249
250proc json::dict2json {dictVal} {
251 # XXX: Currently this API isn't symmetrical, as to create proper
252 # XXX: JSON text requires type knowledge of the input data
253 set json ""
254
255 dict for {key val} $dictVal {
256 # key must always be a string, val may be a number, string or
257 # bare word (true|false|null)
258 if {0 && ![string is double -strict $val]
259 && ![regexp {^(?:true|false|null)$} $val]} {
260 set val "\"$val\""
261 }
262 append json "\"$key\": $val," \n
263 }
264
265 return "\{${json}\}"
266}
267
268proc json::list2json {listVal} {
269 return "\[$[join $listVal ,]\]"
270}
271
272proc json::string2json {str} {
273 return "\"$str\""
274}