Tcl Library Source Code

# -*- tcl -*-
# Tcl Benchmark File
#
# This file contains a number of benchmarks for the 'json' parser
# to allow developers to monitor package performance.
#
# (c) 2013 Andreas Kupries <[email protected]>

# We need at least version 8.4 for the package and thus the
# benchmarks.

if {![package vsatisfies [package present Tcl] 8.4]} {
    bench_puts "Need Tcl 8.4+, found Tcl [package present Tcl]"
    return
}

# ### ### ### ######### ######### ######### ###########################
## Setting up the environment ...

package require Tcl 8.4

package forget json

set self  [file join [pwd] [file dirname [info script]]]
set mod   [file dirname $self]
set index [file join [file dirname $self] tcllibc pkgIndex.tcl]

if 1 {
    if {[file exists $index]} {
	set ::dir [file dirname $index]
	uplevel #0 [list source $index]
	unset ::dir
	package require tcllibc
    }
}

source [file join $self json.tcl]

proc cat {f} {
    set c [open $f]
    set d [read $c]
    close $c
    return $d
}

# ### ### ### ######### ######### ######### ###########################
## Get all the possible implementations

json::SwitchTo {}
foreach e [json::KnownImplementations] {
    ::json::LoadAccelerator $e
}

# ### ### ### ######### ######### ######### ###########################
## Benchmarks.
## Just the parser, on the valid inputs for the testsuite.

foreach impl [json::Implementations] {
    json::SwitchTo $impl

    bench_puts {=== parse =========}

    foreach f [glob -nocomplain -directory $self/test-data *.json] {
	set in [cat $f]

	bench -desc "parse [file rootname [file tail $f]] ($impl)" -body {
	    json::json2dict $in
	}
    }

    foreach f [glob -nocomplain -directory $self/test-data *.bench] {
	set in [cat $f]

	bench -desc "parse [file rootname [file tail $f]] ($impl)" -body {
	    json::json2dict $in
	}
    }

    bench_puts {=== validate =========}

    foreach f [glob -nocomplain -directory $self/test-data *.json] {
	set in [cat $f]

	bench -desc "validate [file rootname [file tail $f]] ($impl)" -body {
	    json::validate $in
	}
    }

    foreach f [glob -nocomplain -directory $self/test-data *.bench] {
	set in [cat $f]

	bench -desc "validate [file rootname [file tail $f]] ($impl)" -body {
	    json::validate $in
	}
    }
}

# ### ### ### ######### ######### ######### ###########################
## Complete

return

# ### ### ### ######### ######### ######### ###########################
## Notes ...

namespace eval ::json {
    variable  selfdir [file dirname [info script]]
    variable  accel
    array set accel   {tcl 0 critcl 0}
    variable  loaded  {}

    variable apicmds {

	json2dict

	many-json2dict

	validate
    }
}

# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.

namespace eval ::json {
    variable e
    foreach e [KnownImplementations] {
	if {[LoadAccelerator $e]} {
	    SwitchTo $e
	    break
	}
    }
    unset e
}

# ### ### ### ######### ######### #########
## These three procedures shared between Tcl and Critcl implementations.
## See also package "json::write".

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

    foreach {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\""
}

# ### ### ### ######### ######### #########
## Ready

package provide json 1.2

# -*- tcl -*-
# -------------------------------------------------------------------------
# Tests
# -------------------------------------------------------------------------

set i 0
foreach name [array names JSON] {


    test json-${impl}-1.[incr i] "test JSON $name" -body {
        set res [json::json2dict $JSON($name)]
	set res [transform $res $name]
	set res
    } -cleanup {
	unset res
    } -result [resultfor $name]
}

set i 0
foreach name [array names JSON] {
    test json-${impl}-7.[incr i] "validate JSON $name" -body {
        json::validate $JSON($name)
    } -result 1
}

set i 0
foreach name [array names FAIL] {
    test json-${impl}-8.[incr i] "test FAIL $name" -body {
	json::json2dict $FAIL($name)
    } -returnCodes error -result $ERR(${name}-${impl})
}

set i 0
foreach name [array names FAIL] {
    test json-${impl}-9.[incr i] "validate FAIL $name" -body {
        json::validate $FAIL($name)
    } -result 0
}

# -------------------------------------------------------------------------
# More Tests - list2json, string2json
# TODO: dict2json
# -------------------------------------------------------------------------

test json-${impl}-2.0 {list2json} -body {

                } else {
                    unexpected $tokenCursor $token "VALUE"
                }
            }
        }
    }
}

# jsonc.tcl --
#
#       Implementation of a JSON parser in C, binding to the json-c library.
#       See c/README-tcllib for notes on origin.
#
# Copyright (c) 2013 - critcl wrapper - Andreas Kupries <[email protected]>
# Copyright (c) 2013 - C binding      - [email protected]

package require critcl
# @sak notprovided jsonc
package provide jsonc 1
package require Tcl 8.4




critcl::cheaders -Ic c/*.h
critcl::csources c/*.c

# # ## ### Import base declarations, forwards ### ## # #

critcl::ccode {
    #include <string.h>

	    return value2obj(I, jso);
	}	
    }

    static Tcl_Obj *
    value2obj(Tcl_Interp *I, struct json_object *jso)
    {
	struct array_list* ar;
	int                len;
	Tcl_Obj*           key;
	Tcl_Obj*           result;
	Tcl_Obj*           value;

	switch (json_object_get_type(jso)) {
	    case json_type_object: {
		/* Using List API here for compat with Tcl 8.4. */

		result = Tcl_NewListObj(0, NULL);



		json_object_object_foreach(jso, k, v) {
		    key   = Tcl_NewStringObj(k, -1);
		    value = lazy_value2obj(I, v);

		    Tcl_ListObjAppendElement(I, result, key);
		    Tcl_ListObjAppendElement(I, result, value);

	    }

	    case json_type_int: {
		return Tcl_NewLongObj(json_object_get_int64(jso));
	    }

	    case json_type_array: {

		ar     = json_object_get_array(jso);

		result = Tcl_NewListObj(0, NULL);

		for (len = 0; len < ar->length; len++) {
		    value = lazy_value2obj(I, ar->array[len]);
		    Tcl_ListObjAppendElement(I, result, value);
		}
		return result;
	    }

	    case json_type_string: {
		len = json_object_get_string_len(jso);
		return Tcl_NewStringObj(json_object_get_string(jso), len);
	    }
	}
	return NULL; /* unreachable */
    }
}

[
      {
         "precision": "zip",
         "Latitude":  37.7668,
         "Longitude": -122.3959,
         "Address":   "",
         "City":      "SAN FRANCISCO",
         "State":     "CA",
         "Zip":       "94107",
         "Country":   "US"
      },
      {
         "precision": "zip",
         "Latitude":  37.371991,
         "Longitude": -122.026020,
         "Address":   "",
         "City":      "SUNNYVALE",
         "State":     "CA",
         "Zip":       "94085",
         "Country":   "US"
      }
     ]

{precision zip Latitude 37.7668 Longitude -122.3959 Address {} City {SAN FRANCISCO} State CA Zip 94107 Country US} {precision zip Latitude 37.371991 Longitude -122.026020 Address {} City SUNNYVALE State CA Zip 94085 Country US}

list dict

{
    "glossary": {
        "title": "example glossary",
        "mixlist": ["a \"\" str", -0.09, null, "", {"member":true}],
        "GlossDiv": {
            "title": "S",
            "GlossList": [{
                "ID": "SGML",
                "GlossTerm": "Standard \\\" Language",
                "Acronym": "SGML\\",
                "Abbrev": "ISO 8879:1986",
                "GlossDef":
                "A meta-markup language, used ...",
                "GlossSeeAlso": ["GML", "XML", "markup"]}]}}
}

glossary {title {example glossary} mixlist {{a "" str} -0.09 null {} {member 1}} GlossDiv {title S GlossList {{ID SGML GlossTerm {Standard \" Language} Acronym SGML\\ Abbrev {ISO 8879:1986} GlossDef {A meta-markup language, used ...} GlossSeeAlso {GML XML markup}}}}}

dict * {dict GlossDiv {dict GlossList {list dict}}}

{"menu": {
    "id": "file",
    "value": "File:",
    "unival": "\u6021:",
    "popup": {
        "menuitem": [
                     {"value": "Open", "onclick": "OpenDoc()"},
                     {"value": "Close", "onclick": "CloseDoc()"}
                    ]
    }
}
}

menu {id file value File: unival @@@: popup {menuitem {{value Open onclick OpenDoc()} {value Close onclick CloseDoc()}}}}

dict * {dict popup {dict * {list dict}}}

{"menu": {
    "header": "Viewer",
    "items": [
              {"id": "Open"},
              {"id": "OpenNew", "label": "Open New"},
              null,
              {"id": "ZoomIn", "label": "Zoom In"},
              {"id": "ZoomOut", "label": "Zoom Out"},
              null,
              {"id": "Help"},
              {"id": "About", "label": "About Viewer..."}
             ]
}
}

menu {header Viewer items {{id Open} {id OpenNew label {Open New}} null {id ZoomIn label {Zoom In}} {id ZoomOut label {Zoom Out}} null {id Help} {id About label {About Viewer...}}}}

dict * {dict items {list 0 dict 1 dict 3 dict 4 dict 6 dict 7 dict}}

{"widget": {
    "debug": "on",
    "window": {
        "title":"Sample Widget",
        "name": "main_window",
        "width": 500,
        "height": 500},
    "text": {
        "data": "Click Here",
        "size": 36,
        "style": "bold",
        "name": null,
        "hOffset":250,
        "vOffset": 100,
        "alignment": "center",
        "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;"
    }
}
}

widget {debug on window {title {Sample Widget} name main_window width 500 height 500} text {data {Click Here} size 36 style bold name null hOffset 250 vOffset 100 alignment center onMouseUp {sun1.opacity = (sun1.opacity / 100) * 90;}}}

dict * {dict text dict window dict}

#use fileutil/fileutil.tcl fileutil

catch {unset JSON}
catch {unset TCL}
catch {unset DICTSORT}

proc dictsort3 {spec data} {
    while [llength $spec] {
        set type [lindex $spec 0]

                    incr idx
                }
                return $json
            }
            string {
                return $data
            }
            default {
		error "Invalid type"
	    }
        }
    }
}

foreach f [TestFilesGlob test-data/*.json] {
    set name [file rootname [file tail $f]]
    set JSON($name) [tcltest::viewFile $f]
}




foreach f [TestFilesGlob test-data/*.result] {

    set name [file rootname [file tail $f]]
    set TCL($name) [tcltest::viewFile $f]











}



foreach f [TestFilesGlob test-data/*.sort] {
    set name [file rootname [file tail $f]]
    set DICTSORT($name) [tcltest::viewFile $f]
}


# Postprocessing result of one test case, insert proper expected unicodepoint
set  TCL(menu) [string map [list @@@ \u6021]  $TCL(menu)]

set JSON(emptyList) {[]}
set  TCL(emptyList) {}











set JSON(emptyList2) {{"menu": []}}




set  TCL(emptyList2) {menu {}}



set JSON(emptyList3) {["menu", []]}
set  TCL(emptyList3) {menu {}}

set JSON(emptyList4) {[[]]}
set  TCL(emptyList4) {{}}




set JSON(escapes) {"\t\r\n\f\b\/\\\""}
set  TCL(escapes) "\t\r\n\f\b/\\\""






















foreach f [TestFilesGlob test-data/*.fail] {
    set name [file rootname [file tail $f]]
    set FAIL($name) [tcltest::viewFile $f]
}












foreach f [TestFilesGlob test-data/*.err] {
    set name [file rootname [file tail $f]]
    set ERR($name) [tcltest::viewFile $f]
}




set FAIL(escape1)        {"\%"}
set  ERR(escape1-tcl)    {unexpected token "END" at position 0; expecting VALUE}
set  ERR(escape1-critcl) {invalid string sequence}

set FAIL(escape2)        {"\."}
set  ERR(escape2-tcl)    {unexpected token "END" at position 0; expecting VALUE}
set  ERR(escape2-critcl) {invalid string sequence}







proc resultfor {name} {
    global TCL
    transform $TCL($name) $name
}

proc transform {res name} {