Attachment #150445 for bug #195863




 * Mikhail.
 */

%{
#include <tcl.h>
#include <errno.h>
#include <ctype.h>
#include <math.h>
#include <string.h>
#include <stdlib.h>
#include <assert.h>
#if TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 4
#define USE_DICT
#endif

#include <json_y.h>

#define TOKEN(tok)   TRACE (("TOKEN  %s\n", tok))
#define TOKEN1(tok)  TRACE (("TOKEN  %s (%s)\n", tok, Tcl_GetString(context->obj)))
#define REDUCE(rule) TRACE (("REDUCE %s\n", rule))

#define TRUE_O  staticobj(TRUEO)
#define FALSE_O staticobj(FALSEO)
#define NULL_O  staticobj(NULLO)

enum constants { FALSEO, TRUEO, NULLO, NUMCONSTANTS };
static Tcl_Obj * staticobj(enum constants);
static void jsonerror(struct context *, const char *);
static int  jsonlexp(struct context *context);

#define YYPARSE_PARAM_TYPE void *
#define YYPARSE_PARAM	   context

	}
	;

members	: member
	{
#ifdef USE_DICT
		$$ = Tcl_NewDictObj();
		Tcl_DictObjPut(NULL, $$, $1.key, $1.val);
#else
	        $$ = Tcl_NewListObj(0, NULL);
		Tcl_ListObjAppendElement(NULL, $$, $1.key);
		Tcl_ListObjAppendElement(NULL, $$, $1.val);
#endif
	}
	| members ',' member
	{
#ifdef USE_DICT
		Tcl_DictObjPut(NULL, $1, $3.key, $3.val);
#else
		Tcl_ListObjAppendElement(NULL, $1, $3.key);
		Tcl_ListObjAppendElement(NULL, $1, $3.val);
#endif
		$$ = $1;
	}
	;

member	: string ':' value

      continue;
    }
    break;
  }
}

/*
 * JSON has 3 string-literals: "null", "true", and "false". Instead of
 * creating a NEW Tcl-object EACH TIME such literal is encountered, we
 * return the reference to the first such object created (and bump its
 * reference-count to prevent memory errors).
 */
Tcl_Obj *
staticobj(enum constants constant)
{
    static Tcl_Obj   *objects[NUMCONSTANTS];
    Tcl_Obj         **p;

    assert(constant >= 0 && constant < NUMCONSTANTS);
    p = objects + constant;
    if (*p == NULL) {
	/*
	 * This is the first time we were asked for an object for
	 * this constant. Create it to the best of our ability.
	 *
	 * Using the trick below, rather than the usual
	 * Tcl_NewStringObj(), avoids creation of a COPY
	 * of the string "null". Such copying is a waste,
	 * if the object itself is never to be freed...
	 */
	*p = Tcl_NewObj();
	switch (constant) {
	case NULLO:
	    (*p)->bytes = (void *)"null";
	    (*p)->length = 4;
	    break;
	case TRUEO:
	    /*
	     * A boolean-object's default string representation is
	     * "0" or "1", but we'd like the fancier "false" and
	     * "true" for our objects to better match the
	     * expectations of JSON-users.
	     */
	    Tcl_SetBooleanObj(*p, 1);
	    (*p)->bytes = (void *)"true";
	    (*p)->length = 4;
	    break;
	case FALSEO:
	    Tcl_SetBooleanObj(*p, 0);
	    (*p)->bytes = (void *)"false";
	    (*p)->length = 5;
	    break;
	default:
	    Tcl_Panic("Internal error in %s:%d unknown constant %d",
		__FILE__, __LINE__, (int)constant);
	}
    }
    /*
     * Increase the ref-count so nothing ever attempts to free
     * neither the static object we are returning, nor its bytes.
     */
    Tcl_IncrRefCount(*p);
    return *p;
}

static int
jsonlexp(struct context *context)
{
  const char *bp = NULL;

  enum {
    PLAIN	= 0x0000ff00,
    INSTR	= 0x00ff0000
  } lstate;
  double 	 d;
  int		 i;
  long	 	 l;
  long long	 ll;
  Tcl_WideInt	 wi;
#ifdef USE_BIG_NUM
  mp_int	 mpi;
#endif
  char		*end;
  const char	*p;
  int		 initialized = 0;

  /*

      yyerror("Escape character outside of string");
      TOKEN ("escape error");
      return -1;
    }

    context->obj = NULL;
    /*
     * We already considered the null, true, and false
     * above, so it can only be a number now.
     *
     * NOTE: At this point we do not care about double
     * versus integer, nor about the possible integer
     * range. We generate a plain string Tcl_Obj and leave
     * it to the user of the generated structure to
     * convert to a number when actually needed. This
     * defered conversion also ensures that the Tcl and
     * platform we are building against does not matter
     * regarding integer range, only the abilities of the
     * Tcl at runtime.
     */
    errno = 0;
    d = strtod(context->text, &end);
    if (end == context->text || isnan(d) || isinf(d))
	goto bareword; /* Nothing parsed */
    if (context->text[0] == '0' && context->text[1] != '.') {
	yyerror("Leading zeros aren't allowed in JSON");
	TOKEN("Leading zero error");
	return -1;
    }
    if (errno == ERANGE) {
	/* Too large. Let TCL core deal with it */
	goto donewithnumber;
    }
    /* See, if there was anything other than digit there: */
    for (p = context->text; p != end; p++) {
	if ((*p >= '0' && *p <= '9') || *p == '+' || *p == '-')
	    continue;
	context->obj = Tcl_NewDoubleObj(d);
	goto donewithnumber;
    }
    /* Didn't find any non-digits, must be an integer: */
    errno = 0;
    ll = strtoll(context->text, &end, 10);
    if (errno == ERANGE) {
	/* Too large. Let TCL core deal with it */
	goto donewithnumber;
    }
    /* Find the right integer-type for this number */
    i = ll;	/* int ? */
    if (i == ll) {
	context->obj = Tcl_NewIntObj(i);
	goto donewithnumber;
    }
    l = ll;	/* long ? */
    if (l == ll) {
	context->obj = Tcl_NewLongObj(l);
	goto donewithnumber;
    }
    wi = ll;	/* Tcl_WideInt */
    if (wi == ll) {
	context->obj = Tcl_NewWideIntObj(wi);
	goto donewithnumber;
    }
  donewithnumber:
    if (context->obj == NULL) {
	context->obj = Tcl_NewStringObj(context->text,
					end - context->text);
    }
    context->remaining -= (end - context->text);
    context->text = end;
    TOKEN1 ("CONSTANT");
    return CONSTANT;
  }

Line 0 Link Here

(-)modules/json/tests/numbers.json (+6 lines)
	1	{"numbers": {
	2	"int" : 123,
	3	"long" : 1234567890123456789,
	4	"bigint": 12345678901234567890123456789012345678901234567890123456789
	5	}
	6	}

Line 0 Link Here

(-)modules/json/tests/numbers.result (+1 lines)
	1	numbers {int 123 long 1234567890123456789 bigint 12345678901234567890123456789012345678901234567890123456789}

Return to bug 195863

Lines 3-28 Link Here

(-)modules/json/c/json.y (-20 / +132 lines)
3	* Mikhail.	3	* Mikhail.
4	*/	4	*/
5		5
6	%{	6	%{
7	#include <tcl.h>	7	#include <tcl.h>
		8	#include <errno.h>
8	#include <ctype.h>	9	#include <ctype.h>
9	#include <math.h>	10	#include <math.h>
10	#include <string.h>	11	#include <string.h>
11	#include <stdlib.h>	12	#include <stdlib.h>
12	#include <assert.h>	13	#include <assert.h>
		14	#if TCL_MAJOR_VERSION > 8 \|\| TCL_MINOR_VERSION > 4
		15	#define USE_DICT
		16	#endif
13		17
14	#include <json_y.h>	18	#include <json_y.h>
15		19
16	#define TOKEN(tok) TRACE (("TOKEN %s\n", tok))	20	#define TOKEN(tok) TRACE (("TOKEN %s\n", tok))
17	#define TOKEN1(tok) TRACE (("TOKEN %s (%s)\n", tok, Tcl_GetString(context->obj)))	21	#define TOKEN1(tok) TRACE (("TOKEN %s (%s)\n", tok, Tcl_GetString(context->obj)))
18	#define REDUCE(rule) TRACE (("REDUCE %s\n", rule))	22	#define REDUCE(rule) TRACE (("REDUCE %s\n", rule))
19		23
20	#define TRUE_O (Tcl_NewStringObj("true", 4))	24	#define TRUE_O staticobj(TRUEO)
21	#define FALSE_O (Tcl_NewStringObj("false", 5))	25	#define FALSE_O staticobj(FALSEO)
22	#define NULL_O (Tcl_NewStringObj("null", 4))	26	#define NULL_O staticobj(NULLO)
23		27
		28	enum constants { FALSEO, TRUEO, NULLO, NUMCONSTANTS };
		29	static Tcl_Obj * staticobj(enum constants);
24	static void jsonerror(struct context , const char );	30	static void jsonerror(struct context , const char );
25	static int jsonlexp(struct context *context);	31	static int jsonlexp(struct context *context);
26		32
27	#define YYPARSE_PARAM_TYPE void *	33	#define YYPARSE_PARAM_TYPE void *
28	#define YYPARSE_PARAM context	34	#define YYPARSE_PARAM context
Lines 105-122 Link Here
105	}	111	}
106	;	112	;
107		113
108	members : member	114	members : member
109	{	115	{
		116	#ifdef USE_DICT
		117	$$ = Tcl_NewDictObj();
		118	Tcl_DictObjPut(NULL, $$, $1.key, $1.val);
		119	#else
110	$$ = Tcl_NewListObj(0, NULL);	120	$$ = Tcl_NewListObj(0, NULL);
111	Tcl_ListObjAppendElement(NULL, $$, $1.key);	121	Tcl_ListObjAppendElement(NULL, $$, $1.key);
112	Tcl_ListObjAppendElement(NULL, $$, $1.val);	122	Tcl_ListObjAppendElement(NULL, $$, $1.val);
		123	#endif
113	}	124	}
114	\| members ',' member	125	\| members ',' member
115	{	126	{
		127	#ifdef USE_DICT
		128	Tcl_DictObjPut(NULL, $1, $3.key, $3.val);
		129	#else
116	Tcl_ListObjAppendElement(NULL, $1, $3.key);	130	Tcl_ListObjAppendElement(NULL, $1, $3.key);
117	Tcl_ListObjAppendElement(NULL, $1, $3.val);	131	Tcl_ListObjAppendElement(NULL, $1, $3.val);
		132	#endif
118	$$ = $1;	133	$$ = $1;
119	}	134	}
120	;	135	;
121		136
122	member : string ':' value	137	member : string ':' value
Lines 177-186 Link Here
177	continue;	192	continue;
178	}	193	}
179	break;	194	break;
180	}	195	}
181	}	196	}
		197
		198	/*
		199	* JSON has 3 string-literals: "null", "true", and "false". Instead of
		200	* creating a NEW Tcl-object EACH TIME such literal is encountered, we
		201	* return the reference to the first such object created (and bump its
		202	* reference-count to prevent memory errors).
		203	*/
		204	Tcl_Obj *
		205	staticobj(enum constants constant)
		206	{
		207	static Tcl_Obj *objects[NUMCONSTANTS];
		208	Tcl_Obj **p;
		209
		210	assert(constant >= 0 && constant < NUMCONSTANTS);
		211	p = objects + constant;
		212	if (*p == NULL) {
		213	/*
		214	* This is the first time we were asked for an object for
		215	* this constant. Create it to the best of our ability.
		216	*
		217	* Using the trick below, rather than the usual
		218	* Tcl_NewStringObj(), avoids creation of a COPY
		219	* of the string "null". Such copying is a waste,
		220	* if the object itself is never to be freed...
		221	*/
		222	*p = Tcl_NewObj();
		223	switch (constant) {
		224	case NULLO:
		225	(p)->bytes = (void )"null";
		226	(*p)->length = 4;
		227	break;
		228	case TRUEO:
		229	/*
		230	* A boolean-object's default string representation is
		231	* "0" or "1", but we'd like the fancier "false" and
		232	* "true" for our objects to better match the
		233	* expectations of JSON-users.
		234	*/
		235	Tcl_SetBooleanObj(*p, 1);
		236	(p)->bytes = (void )"true";
		237	(*p)->length = 4;
		238	break;
		239	case FALSEO:
		240	Tcl_SetBooleanObj(*p, 0);
		241	(p)->bytes = (void )"false";
		242	(*p)->length = 5;
		243	break;
		244	default:
		245	Tcl_Panic("Internal error in %s:%d unknown constant %d",
		246	__FILE__, __LINE__, (int)constant);
		247	}
		248	}
		249	/*
		250	* Increase the ref-count so nothing ever attempts to free
		251	* neither the static object we are returning, nor its bytes.
		252	*/
		253	Tcl_IncrRefCount(*p);
		254	return *p;
		255	}
182		256
183	static int	257	static int
184	jsonlexp(struct context *context)	258	jsonlexp(struct context *context)
185	{	259	{
186	const char *bp = NULL;	260	const char *bp = NULL;
Lines 191-200 Link Here
191	enum {	265	enum {
192	PLAIN = 0x0000ff00,	266	PLAIN = 0x0000ff00,
193	INSTR = 0x00ff0000	267	INSTR = 0x00ff0000
194	} lstate;	268	} lstate;
195	double d;	269	double d;
		270	int i;
		271	long l;
		272	long long ll;
		273	Tcl_WideInt wi;
		274	#ifdef USE_BIG_NUM
		275	mp_int mpi;
		276	#endif
196	char *end;	277	char *end;
197	const char *p;	278	const char *p;
198	int initialized = 0;	279	int initialized = 0;
199		280
200	/*	281	/*
Lines 343-374 Link Here
343	yyerror("Escape character outside of string");	424	yyerror("Escape character outside of string");
344	TOKEN ("escape error");	425	TOKEN ("escape error");
345	return -1;	426	return -1;
346	}	427	}
347		428
		429	context->obj = NULL;
348	/*	430	/*
349	* We already considered the null, true, and false	431	* We already considered the null, true, and false
350	* above, so it can only be a number now.	432	* above, so it can only be a number now.
351	*
352	* NOTE: At this point we do not care about double
353	* versus integer, nor about the possible integer
354	* range. We generate a plain string Tcl_Obj and leave
355	* it to the user of the generated structure to
356	* convert to a number when actually needed. This
357	* defered conversion also ensures that the Tcl and
358	* platform we are building against does not matter
359	* regarding integer range, only the abilities of the
360	* Tcl at runtime.
361	*/	433	*/
362		434	errno = 0;
363	d = strtod(context->text, &end);	435	d = strtod(context->text, &end);
364	if (end == context->text)	436	if (end == context->text \|\| isnan(d) \|\| isinf(d))
365	goto bareword; /* Nothing parsed */	437	goto bareword; /* Nothing parsed */
366		438	if (context->text[0] == '0' && context->text[1] != '.') {
367	context->obj = Tcl_NewStringObj (context->text,	439	yyerror("Leading zeros aren't allowed in JSON");
368	end - context->text);	440	TOKEN("Leading zero error");
369		441	return -1;
		442	}
		443	if (errno == ERANGE) {
		444	/* Too large. Let TCL core deal with it */
		445	goto donewithnumber;
		446	}
		447	/* See, if there was anything other than digit there: */
		448	for (p = context->text; p != end; p++) {
		449	if ((p >= '0' && p <= '9') \|\| p == '+' \|\| p == '-')
		450	continue;
		451	context->obj = Tcl_NewDoubleObj(d);
		452	goto donewithnumber;
		453	}
		454	/* Didn't find any non-digits, must be an integer: */
		455	errno = 0;
		456	ll = strtoll(context->text, &end, 10);
		457	if (errno == ERANGE) {
		458	/* Too large. Let TCL core deal with it */
		459	goto donewithnumber;
		460	}
		461	/* Find the right integer-type for this number */
		462	i = ll; /* int ? */
		463	if (i == ll) {
		464	context->obj = Tcl_NewIntObj(i);
		465	goto donewithnumber;
		466	}
		467	l = ll; /* long ? */
		468	if (l == ll) {
		469	context->obj = Tcl_NewLongObj(l);
		470	goto donewithnumber;
		471	}
		472	wi = ll; /* Tcl_WideInt */
		473	if (wi == ll) {
		474	context->obj = Tcl_NewWideIntObj(wi);
		475	goto donewithnumber;
		476	}
		477	donewithnumber:
		478	if (context->obj == NULL) {
		479	context->obj = Tcl_NewStringObj(context->text,
		480	end - context->text);
		481	}
370	context->remaining -= (end - context->text);	482	context->remaining -= (end - context->text);
371	context->text = end;	483	context->text = end;
372	TOKEN1 ("CONSTANT");	484	TOKEN1 ("CONSTANT");
373	return CONSTANT;	485	return CONSTANT;
374	}	486	}