#
#   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"
	}
    }
}

# Convert a Tcl list to a JSON formatted list (i.e. with some notion of type).
#
# If ignoreFmt is true, just caste everything as a string.
#
proc json::dict2json {dictVal {ignoreFmt 0}} {
    set FrmtdDict [list]
    dict for {key val} $dictVal {
        if {[expr {![catch {dict size $val}]}]} {
            lappend FrmtdDict "\"$key\":[dict2json $val $ignoreFmt]"
        } else {
            lappend FrmtdDict "\"$key\":[list2json $val $ignoreFmt]"
        }
    }
    return "\{[join $FrmtdDict ,]\}"
}

# Convert a Tcl list to a JSON formatted list (i.e. with some notion of type).
#
# If ignoreFmt is true, just caste everything as a string.
#
proc json::list2json {listVal {ignoreFmt 0}} {
    if {[llength $listVal] > 1} {
        set FrmtdList [list]
        foreach value $listVal {
            lappend FrmtdList [list2json $value $ignoreFmt]
        }
        return "\[[join $FrmtdList ,]\]"
    } else {
        return [string2json $listVal $ignoreFmt]
    }
}

proc json::string2json {str {ignoreFmt 0}} {
    if {$ignoreFmt} {
        return "\"$str\""
    }
    if {[string is double -strict $str]} {
        return $str
    }
    return "\"$str\""
}