json-encode.c -- small C-module to get native json escape in Tcl

json-encode.c

/*
 * json-encode.c --
 * 
 * Small module to get native json escape in tcl.
 *
 * Compile:
 *   mingw: gcc -O2 -DUSE_TCL_STUBS=1 -I$tcl/win  -I$tcl/generic json-encode.c -shared -o json.dll libtclstub87.a
 *   *nix:  gcc -O2 -DUSE_TCL_STUBS=1 -I$tcl/unix -I$tcl/generic json-encode.c -shared -o json.so  libtclstub87.a
 * 
 * Usage:
 *   $ tclsh87
 *   % load json
 *   % json-encode "string to encode"
 */
 
#include "tcl.h"
#include "stdlib.h"
 
/* tcl-generator for _TJson_TokTab *
 
set m [list "\"" "\\\"" \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t \
            \x00 \\u0000 \x01 \\u0001 \x02 \\u0002 \x03 \\u0003 \
            \x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007 \
            \x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010 \
            \x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014 \
            \x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018 \
            \x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c \
            \x1d \\u001d \x1e \\u001e \x1f \\u001f \x7f \\u007f \
            \x80 \\u0080 \x81 \\u0081 \x82 \\u0082 \x83 \\u0083 \
            \x84 \\u0084 \x85 \\u0085 \x86 \\u0086 \x87 \\u0087 \
            \x88 \\u0088 \x89 \\u0089 \x8a \\u008a \x8b \\u008b \
            \x8c \\u008c \x8d \\u008d \x8e \\u008e \x8f \\u008f \
            \x90 \\u0090 \x91 \\u0091 \x92 \\u0092 \x93 \\u0093 \
            \x94 \\u0094 \x95 \\u0095 \x96 \\u0096 \x97 \\u0097 \
            \x98 \\u0098 \x99 \\u0099 \x9a \\u009a \x9b \\u009b \
            \x9c \\u009c \x9d \\u009d \x9e \\u009e \x9f \\u009f ]
for {set c 0} {$c <= 127} {} {
  time {
    set ch [format %c $c]
    if {[set cm [string map $m $ch]] ne $ch} {
      if {[string range $cm 0 1] ne "\\u"} {
        set cm [string range $cm 1 end]
        if {$cm eq "\\"} {
          append cm "\\"
        }
        set cm " '$cm' /\* ESC '$cm' *\/,"
      } else {
        set cm " 1 /\* SPEC '$cm' *\/,"
      }
    } else {
      set cm " 0 /\* NOTOK '[url_encode -extended $ch]' *\/,"
    }
    puts -nonewline $cm
    incr c
  } 8
  puts ""
}
 
*/
 
const char _TJson_TokTab[] = {
 1 /* SPEC '\u0000' */, 1 /* SPEC '\u0001' */, 1 /* SPEC '\u0002' */, 1 /* SPEC '\u0003' */, 1 /* SPEC '\u0004' */, 1 /* SPEC '\u0005' */, 1 /* SPEC '\u0006' */, 1 /* SPEC '\u0007' */,
 'b' /* ESC 'b' */, 't' /* ESC 't' */, 'n' /* ESC 'n' */, 1 /* SPEC '\u000b' */, 'f' /* ESC 'f' */, 'r' /* ESC 'r' */, 1 /* SPEC '\u000e' */, 1 /* SPEC '\u000f' */,
 1 /* SPEC '\u0010' */, 1 /* SPEC '\u0011' */, 1 /* SPEC '\u0012' */, 1 /* SPEC '\u0013' */, 1 /* SPEC '\u0014' */, 1 /* SPEC '\u0015' */, 1 /* SPEC '\u0016' */, 1 /* SPEC '\u0017' */,
 1 /* SPEC '\u0018' */, 1 /* SPEC '\u0019' */, 1 /* SPEC '\u001a' */, 1 /* SPEC '\u001b' */, 1 /* SPEC '\u001c' */, 1 /* SPEC '\u001d' */, 1 /* SPEC '\u001e' */, 1 /* SPEC '\u001f' */,
 0 /* NOTOK '%20' */, 0 /* NOTOK '%21' */, '"' /* ESC '"' */, 0 /* NOTOK '%23' */, 0 /* NOTOK '%24' */, 0 /* NOTOK '%25' */, 0 /* NOTOK '%26' */, 0 /* NOTOK '%27' */,
 0 /* NOTOK '%28' */, 0 /* NOTOK '%29' */, 0 /* NOTOK '%2a' */, 0 /* NOTOK '%2b' */, 0 /* NOTOK '%2c' */, 0 /* NOTOK '-' */, 0 /* NOTOK '.' */, 0 /* NOTOK '%2f' */,
 0 /* NOTOK '0' */, 0 /* NOTOK '1' */, 0 /* NOTOK '2' */, 0 /* NOTOK '3' */, 0 /* NOTOK '4' */, 0 /* NOTOK '5' */, 0 /* NOTOK '6' */, 0 /* NOTOK '7' */,
 0 /* NOTOK '8' */, 0 /* NOTOK '9' */, 0 /* NOTOK '%3a' */, 0 /* NOTOK '%3b' */, 0 /* NOTOK '%3c' */, 0 /* NOTOK '%3d' */, 0 /* NOTOK '%3e' */, 0 /* NOTOK '%3f' */,
 0 /* NOTOK '@' */, 0 /* NOTOK 'A' */, 0 /* NOTOK 'B' */, 0 /* NOTOK 'C' */, 0 /* NOTOK 'D' */, 0 /* NOTOK 'E' */, 0 /* NOTOK 'F' */, 0 /* NOTOK 'G' */,
 0 /* NOTOK 'H' */, 0 /* NOTOK 'I' */, 0 /* NOTOK 'J' */, 0 /* NOTOK 'K' */, 0 /* NOTOK 'L' */, 0 /* NOTOK 'M' */, 0 /* NOTOK 'N' */, 0 /* NOTOK 'O' */,
 0 /* NOTOK 'P' */, 0 /* NOTOK 'Q' */, 0 /* NOTOK 'R' */, 0 /* NOTOK 'S' */, 0 /* NOTOK 'T' */, 0 /* NOTOK 'U' */, 0 /* NOTOK 'V' */, 0 /* NOTOK 'W' */,
 0 /* NOTOK 'X' */, 0 /* NOTOK 'Y' */, 0 /* NOTOK 'Z' */, 0 /* NOTOK '%5b' */, '\\' /* ESC '\\' */, 0 /* NOTOK '%5d' */, 0 /* NOTOK '%5e' */, 0 /* NOTOK '_' */,
 0 /* NOTOK '%60' */, 0 /* NOTOK 'a' */, 0 /* NOTOK 'b' */, 0 /* NOTOK 'c' */, 0 /* NOTOK 'd' */, 0 /* NOTOK 'e' */, 0 /* NOTOK 'f' */, 0 /* NOTOK 'g' */,
 0 /* NOTOK 'h' */, 0 /* NOTOK 'i' */, 0 /* NOTOK 'j' */, 0 /* NOTOK 'k' */, 0 /* NOTOK 'l' */, 0 /* NOTOK 'm' */, 0 /* NOTOK 'n' */, 0 /* NOTOK 'o' */,
 0 /* NOTOK 'p' */, 0 /* NOTOK 'q' */, 0 /* NOTOK 'r' */, 0 /* NOTOK 's' */, 0 /* NOTOK 't' */, 0 /* NOTOK 'u' */, 0 /* NOTOK 'v' */, 0 /* NOTOK 'w' */,
 0 /* NOTOK 'x' */, 0 /* NOTOK 'y' */, 0 /* NOTOK 'z' */, 0 /* NOTOK '%7b' */, 0 /* NOTOK '|' */, 0 /* NOTOK '%7d' */, 0 /* NOTOK '%7e' */, 1 /* SPEC '\u007f' */,
 0
};
 
static
void _TJson_ObjStrToDString(Tcl_DString *ds, Tcl_Obj *inObj)
{
  const char *start, *str = Tcl_GetString(inObj);
  int len = inObj->length;
  int cl;
  Tcl_UniChar ch;
  char c, buf[2+8+1] = "\\_";
 
  if (!len) {
    Tcl_DStringAppend(ds, "\"\"", 2);
    return;
  }
 
  Tcl_DStringAppend(ds, "\"", 1);
  start = str;
  while (len > 0) {
    if ( !((ch = *str) & 0x80) ) {
      c = _TJson_TokTab[(unsigned)*str];
      if (!c) { len--; str++; continue; };
      cl = 1;
    } else {
      cl = Tcl_UtfToUniChar(str, &ch);
      c = 1;
    }
    if (str > start) {
      Tcl_DStringAppend(ds, start, str - start);
    }
    if (c == 1) { /* SPEC escape \uxxxx */
      if (ch <= 0xffff) {
        buf[1] = 'u';
        sprintf(&buf[2], "%04x", (unsigned)ch);
        Tcl_DStringAppend(ds, buf, 2+4);
      } else { /* TCL_UTF_MAX > 4, special JSON */
        buf[1] = 'U';
        sprintf(&buf[2], "%08x", (unsigned)ch);
        Tcl_DStringAppend(ds, buf, 2+8);
      }
    } else {  /* ESC char \c */
      buf[1] = c;
      Tcl_DStringAppend(ds, buf, 2);
    }
    len -= cl, str += cl;
    start = str;
  }
  if (str > start) {
    Tcl_DStringAppend(ds, start, str - start);
  }
  Tcl_DStringAppend(ds, "\"", 1);
}
 
/* ------------------------------------------------------------- */
 
int JsonEncodeObjCmd(
  ClientData dummy,
  Tcl_Interp* interp,
  int objc,
  Tcl_Obj * const objv[]
) {
  Tcl_DString ds;
 
  if (objc != 2) {
    Tcl_WrongNumArgs(interp, 1, objv, "string");
    return TCL_ERROR;
  }
 
  Tcl_DStringInit(&ds);
 
  #if 1
  _TJson_ObjStrToDString(&ds, objv[1]);
  #else
  if (_TJson_ObjToDString(interp, &ds, objv[1]) != TCL_OK) {
    Tcl_DStringFree(&ds);
    return TCL_ERROR;
  }
  #endif
 
  #if 1
  Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
  #else
  Tcl_SetObjResult(interp, Tcl_DStringAsObj(&ds));
  #endif
  return TCL_OK;
}
 
int Json_Init(Tcl_Interp *interp) {
  if (!Tcl_InitStubs(interp, "8.5", 0)) {
    return TCL_ERROR;
  }
  Tcl_CreateObjCommand(interp, "json-encode", JsonEncodeObjCmd, NULL, NULL);
  return TCL_OK;
}