Tcl Library Source Code

Artifact [bd32690b2c]
Login

Artifact bd32690b2cc24a59aa3c40c098e9e18d8008ec14:

Attachment "json-2.y" to ticket [6efa4f571a] added by aku 2013-12-16 20:57:23.
/*
 *
 */

%{
#include <tcl.h>
#include <ctype.h>
#include <math.h>
#include <string.h>
#include <stdlib.h>
#include <assert.h>

#ifdef STANDALONE
#include <fcntl.h>
#include <sys/mman.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <err.h>
#include <unistd.h>
#endif

struct context {
	const char	*text;
	int		 remaining, lineno;
	Tcl_Interp	*I;
	int		 result;
	Tcl_Obj		*obj;
#ifdef STANDALONE
	const char	*fname;
#endif
};

#ifdef STANDALONE
static void yyerror(const char *s);
#else
static void tclyyerror(struct context *, const char *);
#define yyerror(msg)	tclyyerror(context, msg)
#endif

enum constants { FALSEO, TRUEO, NULLO, NUMCONSTANTS };
static Tcl_Obj * staticobj(enum constants);
static int jsonlex(struct context *context);

#define YYPARSE_PARAM_TYPE void *
#define YYPARSE_PARAM	context
#define YYPARSE_PARAM_DECL
#define yylex()	jsonlex(context)

#ifndef YYBISON
static int yyparse(YYPARSE_PARAM_TYPE YYPARSE_PARAM);
#endif

%}

%union {
	Tcl_Obj		*obj;
	struct {
		Tcl_Obj	*key;
		Tcl_Obj	*val;
	} keyval;
};

%token STRING CONSTANT

%type <obj>	tree
%type <obj>	json
%type <obj>	object
%type <obj>	list
%type <obj>	values
%type <obj>	members
%type <obj>	value
%type <obj>	string
%type <keyval>	member

%%

tree:	json
	{
		struct context *c = context;
		if (c->I)
			Tcl_SetObjResult(c->I, $1);
		c->result = TCL_OK;
	}
	;

json:
	object
	| list
	;

object	: '{' members '}'
	{
		$$ = $2;
	}
	| '{' '}'
	{
		$$ = Tcl_NewObj();
	}
	;

list	: '[' values ']'
	{
		$$ = $2;
	}
	| '[' ']'
	{
		$$ = Tcl_NewObj();
	}
	;

values	: value
	{	
		$$ = Tcl_NewListObj(1, &$1);
	}
	| values ',' value
	{
		Tcl_ListObjAppendElement(NULL, $1, $3);
		$$ = $1;
	}
	;

members	: member
	{
		$$ = Tcl_NewDictObj();
		Tcl_DictObjPut(NULL, $$, $1.key, $1.val);
	}
	| members ',' member
	{
		Tcl_DictObjPut(NULL, $1, $3.key, $3.val);
		$$ = $1;
	}
	;

member	: string ':' value
	{
		$$.key = $1;
		$$.val = $3;
	}
	;

string	: STRING
	{
		$$ = ((struct context *)context)->obj;
	}
	;

value	: CONSTANT
	{
		$$ = ((struct context *)context)->obj;
	}
	| string
	| object
	| list
	;

%%
#include <err.h>

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) {
		if (constant == NULLO)
			*p = Tcl_NewStringObj("null", 4);
		else {
			*p = Tcl_NewBooleanObj(constant);
			(*p)->bytes = constant ? (void *)"true" :
			    (void *)"false";
			(*p)->length = constant ? sizeof("true") :
			    sizeof("false") - 1;
		}
	}
	Tcl_IncrRefCount(*p);
	return *p;
}

int
jsonlex(struct context *context)
{
	const char	*bp = NULL;
#define DRAIN(n) context->text += n, context->remaining -= n
	enum {
		PLAIN	= 0x0000ff00,
		INSTR	= 0x00ff0000
	} lstate;
	double	 	 d;
	long long	 ll;
	char		*end;
	const char	*p;
	int		 initialized = 0;

#define	STORESTRINGSEGMENT()				\
	if (initialized) {				\
		if (context->text != bp) {		\
			Tcl_AppendToObj(context->obj,	\
			    bp, context->text - bp);	\
		}					\
	} else {					\
		context->obj = Tcl_NewStringObj(	\
		    bp, context->text - bp);		\
		initialized = 1;			\
	}

	while (context->remaining) {
		switch (*context->text) {
		case '\n':
			context->lineno++;
			/* FALLTHROUGH */
		case ' ':
		case '\t':
		case '\r':
			DRAIN(1);
			continue;
		}
		break;
	}

	for (lstate = PLAIN; context->remaining > 0; DRAIN(1)) {
		if (lstate == INSTR) {
			if (*context->text == '"') {
				/*
				 * End of quoted string
				 */
				STORESTRINGSEGMENT();
				DRAIN(1);
				return STRING;
			}

			if (*context->text == '\\') {
				/*
				 * Escaped sequence
				 */
				char	buf[TCL_UTF_MAX];
				int	len, consumed;

				STORESTRINGSEGMENT();
				/*
				 * XXX Tcl_UtfBackslash() may be more
				 * XXX permissive, than JSON standard.
				 * XXX But that may be a good thing:
				 * XXX "be generous in what you accept".
				 */
				len = Tcl_UtfBackslash(context->text,
				    &consumed, buf);
				DRAIN(consumed - 1);
				bp = context->text + 1;
				Tcl_AppendToObj(context->obj, buf, len);
			}
			continue;
		}

		switch (*context->text) {
		case ',':
		case '{':
		case ':':
		case '}':
		case '[':
		case ']':
			DRAIN(1);
			return context->text[-1];
		case 't':
			if ((context->remaining < 4) ||
			    strncmp("rue", context->text + 1, 3))
				goto bareword;
			DRAIN(4);
			context->obj = staticobj(TRUEO);
			return CONSTANT;
		case 'f':
			if ((context->remaining < 5) ||
			    strncmp("alse", context->text + 1, 4))
				goto bareword;
			DRAIN(5);
			context->obj = staticobj(FALSEO);
			return CONSTANT;
		case 'n':
			if ((context->remaining < 4) ||
			    strncmp("ull", context->text + 1, 3))
				goto bareword;
			DRAIN(4);
			context->obj = staticobj(NULLO);
			return CONSTANT;
		case '"':
			bp = context->text + 1;
			lstate = INSTR;
			continue;
		case '\\':
			yyerror("Escape character outside of string");
			return -1;
		}

		/*
		 * We already considered the null, true, and false
		 * above, so it can only be a number now. Let's see,
		 * whether it is a floating-point or an integer and
		 * finish...
		 */

		d = strtod(context->text, &end);
		if (end == context->text)
			goto bareword; /* Nothing parsed */
		/*
		 * See, if there was anything other than digit there:
		 */
		for (p = context->text; p != end; p++) {
			if (*p >= '0' && *p <= '9')
				continue;
			context->obj = Tcl_NewDoubleObj(d);
			goto donewithnumber;
		}

		/*
		 * Didn't find any non-digits, presume integer:
		 */
		ll = strtoll(context->text, &end, 10);
		if (context->text == end)
			goto bareword;
		context->obj = Tcl_NewWideIntObj(ll);

	donewithnumber:
		context->remaining -= (end - context->text);
		context->text = end;
		return CONSTANT;
	}
	return 0;
bareword:
	yyerror("Bare word encountered");
	return -1;
}

#ifdef STANDALONE
static struct context	 Context;
int
main(int argc, char **argv)
{
	int		 i, fd;
	char		*mapped;
	struct stat	 sb;

/*	yydebug = 1; */
	for (i = 1; i < argc; i++) {
		fd = open(argv[i], O_RDONLY);
		if (fd == -1) {
			warn("opening %s", argv[i]);
			continue;
		}
		if (fstat(fd, &sb) == -1) {
			warn("fstat-ing %d after opening %s", fd, argv[i]);
			goto next;
		}
		mapped = mmap(NULL, sb.st_size, PROT_READ|PROT_WRITE,
		    MAP_NOCORE|MAP_NOSYNC, fd, 0);
		if (mapped == MAP_FAILED) {
			warn("mmaping %lld bytes of %d after opening %s",
			    (long long)sb.st_size, fd, argv[i]);
			goto next;
		}
		memset(&Context, 0, sizeof(Context));
		Context.text = mapped;
		Context.lineno = 1;
		Context.fname = argv[i];
		Context.remaining = sb.st_size; /* The file better fit in size_t */
		mapped[Context.remaining] = '\0'; /* XXX may crash here */
		yyparse(&Context);
		if (munmap(mapped, sb.st_size) == -1)
			warn("munmap of %s", argv[i]);
		next:
		close(fd);
	}
}

static void
yyerror(const char *s)
{
	fprintf(stderr, "%s on %s:%d: %.107s\n", s, Context.fname,
	    Context.lineno, Context.text);
	exit(1);
}
#else

static void
tclyyerror(struct context *context, const char *message)
{
	char	*fullmessage, *yytext;
	int	 yyleng;

	yytext = Tcl_GetStringFromObj(context->obj, &yyleng);
	fullmessage = Tcl_Alloc(strlen(message) + 63 + yyleng);
	sprintf(fullmessage, "%s %d bytes before end, around ``%.*s''",
	    message, context->remaining, yyleng, yytext);

	Tcl_SetResult(context->I, fullmessage, TCL_DYNAMIC);
}

static int
json2dict(ClientData cd, Tcl_Interp *I, int objc, Tcl_Obj * const *objv)
{
	struct context	context = { NULL };
	if (objc != 2) {
		Tcl_WrongNumArgs(I, 1, objv, "JSON-text");
		return TCL_ERROR;
	}

	context.text = Tcl_GetStringFromObj(objv[1], &context.remaining);
	context.I = I;
	context.result = TCL_ERROR;
	yyparse(&context);
	return context.result;
}

Tcl_AppInitProc	Jsonmi_Init;

int
Jsonmi_Init(Tcl_Interp *I)
{
	Tcl_CreateObjCommand(I, "jsonmi::json2dict", json2dict, NULL, NULL);

	return Tcl_PkgProvide(I, "jsonmi", "1.1");
}
	
#endif