source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/json/json.tcl

#
#   JSON parser for Tcl.
#
#   See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
#
#   Copyright 2006 ActiveState Software Inc.
#
#   $Id: json.tcl,v 1.2 2006/08/25 23:19:53 hobbs Exp $
#

if {$::tcl_version < 8.5} {
    package require dict
}

package provide json 1.0

namespace eval json {}

proc json::getc {{txtvar txt}} {
    # pop single char off the front of the text
    upvar 1 $txtvar txt
    if {$txt eq ""} {
        return -code error "unexpected end of text"
    }

    set c [string index $txt 0]
    set txt [string range $txt 1 end]
    return $c
}

proc json::json2dict {txt} {
    return [_json2dict]
}

proc json::_json2dict {{txtvar txt}} {
    upvar 1 $txtvar txt

    set state TOP

    set txt [string trimleft $txt]
    while {$txt ne ""} {
        set c [string index $txt 0]

        # skip whitespace
        while {[string is space $c]} {
            getc
            set c [string index $txt 0]
        }

        if {$c eq "\{"} {
            # object
            switch -- $state {
                TOP {
                    # we are dealing with an Object
                    getc
                    set state OBJECT
                    set dictVal [dict create]
                }
                VALUE {
                    # this object element's value is an Object
                    dict set dictVal $name [_json2dict]
                    set state COMMA
                }
                LIST {
                    # next element of list is an Object
                    lappend listVal [_json2dict]
                    set state COMMA
                }
                default {
                    return -code error "unexpected open brace in $state mode"
                }
            }
        } elseif {$c eq "\}"} {
            getc
            if {$state ne "OBJECT" && $state ne "COMMA"} {
                return -code error "unexpected close brace in $state mode"
            }
            return $dictVal
        } elseif {$c eq ":"} {
            # name separator
            getc

            if {$state eq "COLON"} {
                set state VALUE
            } else {
                return -code error "unexpected colon in $state mode"
            }
        } elseif {$c eq ","} {
            # element separator
            if {$state eq "COMMA"} {
                getc
                if {[info exists listVal]} {
                    set state LIST
                } elseif {[info exists dictVal]} {
                    set state OBJECT
                }
            } else {
                return -code error "unexpected comma in $state mode"
            }
        } elseif {$c eq "\""} {
            # string
            # capture quoted string with backslash sequences
            set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
            set string ""
            if {![regexp $reStr $txt string]} {
                set txt [string replace $txt 32 end ...]
                return -code error "invalid formatted string in $txt"
            }
            set txt [string range $txt [string length $string] end]
            # chop off outer ""s and substitute backslashes
            # This does more than the RFC-specified backslash sequences,
            # but it does cover them all
            set string [subst -nocommand -novariable \
                            [string range $string 1 end-1]]

            switch -- $state {
                TOP {
                    return $string
                }
                OBJECT {
                    set name $string
                    set state COLON
                }
                LIST {
                    lappend listVal $string
                    set state COMMA
                }
                VALUE {
                    dict set dictVal $name $string
                    unset name
                    set state COMMA
                }
            }
        } elseif {$c eq "\["} {
            # JSON array == Tcl list
            switch -- $state {
                TOP {
                    getc
                    set state LIST
                }
                LIST {
                    lappend listVal [_json2dict]
                    set state COMMA
                }
                VALUE {
                    dict set dictVal $name [_json2dict]
                    set state COMMA
                }
                default {
                    return -code error "unexpected open bracket in $state mode"
                }
            }
        } elseif {$c eq "\]"} {
            # end of list
            getc
            if {![info exists listVal]} {
                #return -code error "unexpected close bracket in $state mode"
                # must be an empty list
                return ""
            }

            return $listVal
        } elseif {0 && $c eq "/"} {
            # comment
            # XXX: Not in RFC 4627
            getc
            set c [getc]
            switch -- $c {
                / {
                    # // comment form
                    set i [string first "\n" $txt]
                    if {$i == -1} {
                        set txt ""
                    } else {
                        set txt [string range $txt [incr i] end]
                    }
                }
                * {
                    # /* comment */ form
                    getc
                    set i [string first "*/" $txt]
                    if {$i == -1} {
                        return -code error "incomplete /* comment"
                    } else {
                        set txt [string range $txt [incr i] end]
                    }
                }
                default {
                    return -code error "unexpected slash in $state mode"
                }
            }
        } elseif {[string match {[-0-9]} $c]} {
            # one last check for a number, no leading zeros allowed,
            # but it may be 0.xxx
            string is double -failindex last $txt
            if {$last > 0} {
                set num [string range $txt 0 [expr {$last - 1}]]
                set txt [string range $txt $last end]

                switch -- $state {
                    TOP {
                        return $num
                    }
                    LIST {
                        lappend listVal $num
                        set state COMMA
                    }
                    VALUE {
                        dict set dictVal $name $num
                        set state COMMA
                    }
                    default {
                        getc
                        return -code error "unexpected number '$c' in $state mode"
                    }
                }
            } else {
                getc
                return -code error "unexpected '$c' in $state mode"
            }
        } elseif {[string match {[ftn]} $c]
                  && [regexp {^(true|false|null)} $txt val]} {
            # bare word value: true | false | null
            set txt [string range $txt [string length $val] end]

            switch -- $state {
                TOP {
                    return $val
                }
                LIST {
                    lappend listVal $val
                    set state COMMA
                }
                VALUE {
                    dict set dictVal $name $val
                    set state COMMA
                }
                default {
                    getc
                    return -code error "unexpected '$c' in $state mode"
                }
            }
        } else {
            # error, incorrect format or unexpected end of text
            return -code error "unexpected '$c' in $state mode"
        }
    }
}

proc json::dict2json {dictVal} {
    # XXX: Currently this API isn't symmetrical, as to create proper
    # XXX: JSON text requires type knowledge of the input data
    set json ""

    dict for {key val} $dictVal {
        # key must always be a string, val may be a number, string or
        # bare word (true|false|null)
        if {0 && ![string is double -strict $val]
            && ![regexp {^(?:true|false|null)$} $val]} {
            set val "\"$val\""
        }
        append json "\"$key\": $val," \n
    }

    return "\{${json}\}"
}

proc json::list2json {listVal} {
    return "\[$[join $listVal ,]\]"
}

proc json::string2json {str} {
    return "\"$str\""
}