JSON-DWIW-0.18/0000755000076500007650000000000010706025213011113 5ustar dondonJSON-DWIW-0.18/Artistic0000444000076500007650000001373710670143713012637 0ustar dondon The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End JSON-DWIW-0.18/DWIW.xs0000644000076500007650000022166210706023436012257 0ustar dondon/* Copyright (c) 2007 Don Owens . All rights reserved. This is free software; you can redistribute it and/or modify it under the Perl Artistic license. You should have received a copy of the Artistic license with this distribution, in the file named "Artistic". You may also obtain a copy from http://regexguy.com/license/Artistic This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ /* #define PERL_NO_GET_CONTEXT */ #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #if PERL_VERSION >= 8 #define IS_PERL_5_8 #else #if PERL_VERSION <= 5 #error "This module requires at least Perl 5.6" #else #define IS_PERL_5_6 #endif #endif #define DEBUG_UTF8 0 #define JSON_DO_DEBUG 0 #define JSON_DO_TRACE 0 #define JSON_DUMP_OPTIONS 0 #define JSON_DO_EXTENDED_ERRORS 0 #include #define MAYBE_USE_MMAP 0 #if MAYBE_USE_MMAP #ifdef HAS_MMAP #define USE_MMAP 1 #else #define USE_MMAP 0 #endif #else #define USE_MMAP 0 #endif #if USE_MMAP #include #include #include #endif #define debug_level 9 #ifndef PERL_MAGIC_tied #define PERL_MAGIC_tied 'P' /* Tied array or hash */ #endif #define MOD_NAME "JSON::DWIW" #define MOD_VERSION VERSION #ifdef __GNUC__ #if JSON_DO_DEBUG #define JSON_DEBUG(...) printf("%s (%d) - ", __FILE__, __LINE__); printf(__VA_ARGS__); printf("\n"); fflush(stdout) #else #define JSON_DEBUG(...) #endif #else static void JSON_DEBUG(char *fmt, ...) { #if JSON_DO_DEBUG va_list ap; va_start(ap, fmt); vprintf(fmt, ap); printf("\n"); va_end(ap); #endif } #endif #ifdef __GNUC__ #if JSON_DO_TRACE #define JSON_TRACE(...) printf("%s (%d) - ", __FILE__, __LINE__); printf(__VA_ARGS__); printf("\n"); fflush(stdout) #else #define JSON_TRACE(...) #endif #else static void JSON_TRACE(char *fmt, ...) { #if JSON_DO_TRACE va_list ap; va_start(ap, fmt); vprintf(fmt, ap); printf("\n"); va_end(ap); #endif } #endif #ifndef UTF8_IS_INVARIANT #define UTF8_IS_INVARIANT(c) (((UV)c) < 0x80) #endif #define kCommasAreWhitespace 1 #define UNLESS(stuff) if (! (stuff)) /* for converting from JSON */ typedef struct { STRLEN len; char * data; STRLEN pos; SV * error; SV * error_data; SV * self; int flags; UV bad_char_policy; unsigned int line; unsigned int col; unsigned int char_pos; unsigned int char_col; UV cur_char; unsigned int cur_char_len; unsigned int error_pos; unsigned int error_char_pos; unsigned int error_line; unsigned int error_col; unsigned int error_char_col; unsigned int string_count; unsigned int longest_string_bytes; unsigned int longest_string_chars; unsigned int number_count; unsigned int bool_count; unsigned int null_count; unsigned int hash_count; unsigned int array_count; unsigned int deepest_level; } json_context; /* a single set of flags for json_context and self_context */ #define kUseExceptions 1 #define kDumpVars (1 << 1) #define kPrettyPrint (1 << 2) #define kEscapeMultiByte (1 << 3) #define kConvertBool (1 << 4) #define kBadCharError 0 #define kBadCharConvert 1 #define kBadCharPassThrough 2 /* for converting to JSON */ typedef struct { SV * error; SV * error_data; int bare_keys; UV bad_char_policy; int use_exceptions; int flags; unsigned int string_count; unsigned int longest_string_bytes; unsigned int longest_string_chars; unsigned int number_count; unsigned int bool_count; unsigned int null_count; unsigned int hash_count; unsigned int array_count; unsigned int deepest_level; } self_context; static SV * vjson_parse_error(json_context * ctx, const char * file, unsigned int line_num, const char * fmt, va_list ap) { SV * error = Nullsv; bool junk = 0; HV * error_data; if (ctx->error) { return ctx->error; } error = newSVpv("", 0); sv_setpvf(error, "%s v%s ", MOD_NAME, MOD_VERSION); if (file && line_num) { sv_catpvf(error, "line %u of %s ", line_num, file); } sv_catpvn(error, " - ", 3); sv_vcatpvfn(error, fmt, strlen(fmt), &ap, (SV **)0, 0, &junk); sv_catpvf(error, " - at char %u (byte %u), line %u, col %u (byte col %u)", ctx->char_pos, ctx->pos, ctx->line, ctx->char_col, ctx->col); ctx->error_pos = ctx->pos; ctx->error_line = ctx->line; ctx->error_col = ctx->col; ctx->error_char_col = ctx->char_col; error_data = newHV(); ctx->error_data = newRV_noinc((SV *)error_data); hv_store(error_data, "version", 7, newSVpvf("%s", MOD_VERSION), 0); hv_store(error_data, "char", 4, newSVuv(ctx->char_pos), 0); hv_store(error_data, "byte", 4, newSVuv(ctx->pos), 0); hv_store(error_data, "line", 4, newSVuv(ctx->line), 0); hv_store(error_data, "col", 3, newSVuv(ctx->char_col), 0); hv_store(error_data, "byte_col", 8, newSVuv(ctx->col), 0); ctx->error = error; return error; } static SV * json_parse_error(json_context * ctx, const char * file, unsigned int line_num, const char * fmt, ...) { SV * error; va_list ap; va_start(ap, fmt); error = vjson_parse_error(ctx, file, line_num, fmt, ap); va_end(ap); return error; } static SV * vjson_encode_error(self_context * ctx, const char * file, int line_num, const char * fmt, va_list ap) { SV * error = newSVpv("", 0); bool junk = 0; HV * error_data = Nullhv; sv_setpvf(error, "JSON::DWIW v%s - ", MOD_VERSION); sv_vcatpvfn(error, fmt, strlen(fmt), &ap, (SV **)0, 0, &junk); error_data = newHV(); ctx->error_data = newRV_noinc((SV *)error_data); hv_store(error_data, "version", 7, newSVpvf("%s", MOD_VERSION), 0); return error; } static SV * json_encode_error(self_context * ctx, const char * file, int line_num, const char * fmt, ...) { va_list ap; SV * error; va_start(ap, fmt); error = vjson_encode_error(ctx, file, line_num, fmt, ap); va_end(ap); return error; } #ifdef __GNUC__ #if JSON_DO_EXTENDED_ERRORS /* static SV * _build_error_str(const char *file, STRLEN line_num, SV *error_str) { SV * where_str = newSVpvf(" (%s line %d)", file, line_num); sv_catsv(error_str, where_str); SvREFCNT_dec(where_str); return error_str; } static SV * build_parse_error_str(ctx, ...) { SV * error = NULL; va_list ap; va_start(ap, ctx); va_end(ap); return error; } */ /* #define JSON_ERROR(...) _build_error_str(__FILE__, __LINE__, newSVpvf(__VA_ARGS__)) */ #define JSON_PARSE_ERROR(ctx, ...) json_parse_error(ctx, __FILE__, __LINE__, __VA__ARGS__) #define JSON_ENCODE_ERROR(ctx, ...) json_encode_error(ctx, __FILE__, __LINE__, __VA_ARGS__) #else /* #define JSON_ERROR(...) newSVpvf(__VA_ARGS__) */ #define JSON_PARSE_ERROR(ctx, ...) json_parse_error(ctx, NULL, 0, __VA_ARGS__) #endif #define JSON_ENCODE_ERROR(ctx, ...) json_encode_error(ctx, NULL, 0, __VA_ARGS__) #else static SV * JSON_PARSE_ERROR(json_context * ctx, const char * fmt, ...) { SV * error; va_list ap; va_start(ap, fmt); error = vjson_parse_error(ctx, NULL, 0, fmt, ap); va_end(ap); return error; } static SV * JSON_ENCODE_ERROR(self_context * ctx, const char * fmt, ...) { va_list ap; SV * error; va_start(ap, fmt); error = vjson_encode_error(ctx, NULL, 0, fmt, ap); va_end(ap); return error; } /* static SV * JSON_ERROR(char * fmt, ...) { va_list ap; SV * error = newSVpv("", 0); bool junk = 0; va_start(ap, fmt); sv_vsetpvfn(error, fmt, strlen(fmt), &ap, NULL, 0, &junk); va_end(ap); return error; } */ #endif #define UPDATE_CUR_LEVEL(ctx, cur_level) (cur_level > ctx->deepest_level ? (ctx->deepest_level = cur_level) : cur_level ) #if DEBUG_UTF8 static STRLEN print_hex(FILE * fp, const unsigned char * buf, STRLEN buf_len) { STRLEN i; UV c; for (i = 0; i < buf_len; i++) { c = buf[i]; if (c & 0x80) { fprintf(fp, "\\x{%02"UVxf"}", c); } else { fwrite(&buf[i], 1, 1, fp); } } return i; } static STRLEN print_hex_line(FILE * fp, const unsigned char * buf, STRLEN buf_len) { STRLEN i = print_hex(fp, buf, buf_len); fwrite("\n", 1, 1, fp); i++; return i; } #endif static SV * json_parse_value(json_context *ctx, int is_identifier, unsigned int cur_level); static SV * to_json(self_context * self, SV * data_ref, int indent_level, unsigned int cur_level); static UV get_bad_char_policy(HV * self_hash) { SV ** ptr = NULL; U8 * data_str = NULL; STRLEN data_str_len = 0; ptr = hv_fetch((HV *)self_hash, "bad_char_policy", 15, 0); if (ptr && SvTRUE(*ptr)) { data_str = (U8 *)SvPV(*ptr, data_str_len); if (data_str && data_str_len) { if (strnEQ("error", (char *)data_str, data_str_len)) { return kBadCharError; } else if (strnEQ("convert", (char *)data_str, data_str_len)) { return kBadCharConvert; } else if (strnEQ("pass_through", (char *)data_str, data_str_len)) { return kBadCharPassThrough; } } } return kBadCharError; } #define kHaveModuleNotChecked 0 #define kHaveModule 1 #define kHaveModuleDontHave 2 static int g_have_big_int = kHaveModuleNotChecked; static int g_have_big_float = kHaveModuleNotChecked; static int have_bigint() { SV *rv; if (g_have_big_int != kHaveModuleNotChecked) { if (g_have_big_int == kHaveModule) { return 1; } else { return 0; } } rv = eval_pv("require Math::BigInt", 0); if (rv && SvTRUE(rv)) { /* module loaded successfully */ g_have_big_int = kHaveModule; return 1; } else { /* we don't have it */ g_have_big_int = kHaveModuleDontHave; return 0; } return 0; } static int have_bigfloat() { SV *rv; if (g_have_big_float != kHaveModuleNotChecked) { if (g_have_big_float == kHaveModule) { return 1; } else { return 0; } } rv = eval_pv("require Math::BigFloat", 0); if (rv && SvTRUE(rv)) { /* module loaded successfully */ g_have_big_float = kHaveModule; return 1; } else { /* we don't have it */ g_have_big_float = kHaveModuleDontHave; return 0; } return 0; } static void _json_call_method_one_arg_one_return(SV * obj_or_class, char * method, SV * arg, SV ** rv_ptr) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(obj_or_class); XPUSHs(arg); PUTBACK; call_method(method, G_SCALAR); SPAGAIN; *rv_ptr = POPs; if (SvOK(*rv_ptr)) { SvREFCNT_inc(*rv_ptr); } PUTBACK; FREETMPS; LEAVE; } static void _json_call_method_no_arg_one_return(SV * obj_or_class, char * method, SV ** rv_ptr) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(obj_or_class); PUTBACK; call_method(method, G_SCALAR); SPAGAIN; *rv_ptr = POPs; if (SvOK(*rv_ptr)) { SvREFCNT_inc(*rv_ptr); } PUTBACK; FREETMPS; LEAVE; } static SV * json_call_method_one_arg_one_return(SV * obj_or_class, char * method, SV * arg) { SV * rv = NULL; _json_call_method_one_arg_one_return(obj_or_class, method, arg, &rv); return rv; } static SV * json_call_method_no_arg_one_return(SV * obj_or_class, char * method) { SV * rv = NULL; _json_call_method_no_arg_one_return(obj_or_class, method, &rv); return rv; } static SV * get_new_big_int(SV * num_string) { SV * class_name = newSVpv("Math::BigInt", 12); SV * rv = NULL; rv = json_call_method_one_arg_one_return(class_name, "new", num_string); SvREFCNT_dec(class_name); return rv; } static SV * get_new_big_float(SV * num_string) { SV * class_name = newSVpv("Math::BigFloat", 14); SV * rv = NULL; rv = json_call_method_one_arg_one_return(class_name, "new", num_string); SvREFCNT_dec(class_name); return rv; } static SV * get_new_bool_obj(int bool_val) { SV * class_name = newSVpv("JSON::DWIW::Boolean", 19); SV * obj; if (bool_val) { obj = json_call_method_no_arg_one_return(class_name, "true"); } else { obj = json_call_method_no_arg_one_return(class_name, "false"); } SvREFCNT_dec(class_name); return obj; } #define JsSvLen(val) sv_len(val) #define JsDumpSv(sv, flags) ( (flags & kDumpVars) ? sv_dump(sv) : 0 ) #ifdef IS_PERL_5_6 #define convert_utf8_to_uv(utf8, len_ptr) utf8_to_uv_simple(utf8, len_ptr) #else #define convert_utf8_to_uv(utf8, len_ptr) utf8_to_uvuni(utf8, len_ptr) #endif #ifdef IS_PERL_5_6 #define convert_uv_to_utf8(buf, uv) uv_to_utf8(buf, uv) #else #define convert_uv_to_utf8(buf, uv) uvuni_to_utf8(buf, uv) #endif #define JsHaveMoreChars(ctx) ( (ctx)->pos < (ctx)->len ) #define UC2UV(c) ( (UV)(c) ) #define JsCurChar(ctx) ( JsHaveMoreChars(ctx) ? ( UTF8_IS_INVARIANT(ctx->data[ctx->pos]) ? UC2UV(ctx->data[ctx->pos]) : ( convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), NULL))) : 0 ) #define JsNextChar(ctx) ( JsHaveMoreChars(ctx) ? (UTF8_IS_INVARIANT(ctx->data[ctx->pos]) ? (ctx->col++, ctx->char_pos++, ctx->char_col++, UC2UV(ctx->data[ctx->pos++])) : json_next_multibyte_char(ctx)) : 0 ) #define JsNextCharWithArg(ctx, uv, len) ( JsHaveMoreChars(ctx) ? (UTF8_IS_INVARIANT(ctx->data[ctx->pos]) ? (ctx->col++, ctx->char_pos++, ctx->char_col++, UC2UV(ctx->data[ctx->pos++])) : (uv = convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), &len), ctx->pos += len, ctx->col += len, ctx->char_pos++, ctx->char_col++, uv) ) : 0 ) static UV json_next_multibyte_char(json_context * ctx) { UV uv = 0; STRLEN len = 0; /* FIXME: should use is_utf8_char() so we know whether we got a NULL char back or an error */ uv = convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), &len); ctx->pos += len; ctx->col += len; ctx->char_pos++; ctx->char_col++; return uv; } /* static UV json_next_char(json_context *ctx) { UV uv = 0; STRLEN len = 0; if (UTF8_IS_INVARIANT(ctx->data[ctx->pos])) { uv = ctx->data[ctx->pos]; ctx->pos++; ctx->col++; } else { uv = convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), &len); ctx->pos += len; ctx->col += len; } JSON_DEBUG("pos=%d, len=%d, char=%c (%#04x), line %u, col %u", ctx->pos, ctx->len, (uv>0x80 ? '?' : (char)uv), uv, ctx->line, ctx->col); return uv; } */ static void json_eat_whitespace(json_context *ctx, UV flags) { UV this_char; int break_out = 0; UV tmp_uv; STRLEN tmp_len; JSON_DEBUG("json_eat_whitespace: starting pos %d", ctx->pos); while (ctx->pos < ctx->len) { this_char = JsCurChar(ctx); JSON_DEBUG("looking at %04x at pos %d", this_char, ctx->pos); switch (this_char) { case 0x20: /* space */ case 0x09: /* tab */ case 0x0b: /* vertical tab */ case 0x0c: /* form feed */ case 0x0d: /* carriage return */ case 0x00a0: /* NSBP - non-breaking space */ case 0x200b: /* ZWSP - zero width space */ case 0x2029: /* PS - paragraph separator */ case 0x2060: /* WJ - word joiner */ JsNextCharWithArg(ctx, tmp_uv, tmp_len); break; case 0x0a: /* newline */ case 0x0085: /* NEL - next line */ case 0x2028: /* LS - line separator */ JsNextCharWithArg(ctx, tmp_uv, tmp_len); ctx->line++; ctx->col = 0; ctx->char_col = 0; break; case ',': if (flags & kCommasAreWhitespace) { JsNextCharWithArg(ctx, tmp_uv, tmp_len); } else { break_out = 1; } break; case '/': JsNextCharWithArg(ctx, tmp_uv, tmp_len); this_char = JsCurChar(ctx); JSON_DEBUG("looking at %04x at pos %d", this_char, ctx->pos); if (this_char == '/') { JSON_DEBUG("in C++ style comment at pos %d", ctx->pos); while (ctx->pos < ctx->len) { JsNextCharWithArg(ctx, tmp_uv, tmp_len); this_char = JsCurChar(ctx); if (this_char == 0x0a || this_char == 0x0d) { /* FIXME: should peak at the next to see if windows line ending, etc. */ break; } } } else if (this_char == '*') { JsNextCharWithArg(ctx, tmp_uv, tmp_len); this_char = JsCurChar(ctx); JSON_DEBUG("in comment at pos %d, looking at %04x", ctx->pos, this_char); while (ctx->pos < ctx->len) { if (this_char == '*') { JsNextCharWithArg(ctx, tmp_uv, tmp_len); this_char = JsCurChar(ctx); if (this_char == '/') { /* end of comment */ JsNextCharWithArg(ctx, tmp_uv, tmp_len); break; } } else { JsNextCharWithArg(ctx, tmp_uv, tmp_len); this_char = JsCurChar(ctx); } } } else { /* syntax error -- can't have a '/' by itself */ JSON_DEBUG("syntax error at %d -- can't have '/' by itself", ctx->pos); } break; default: break_out = 1; break; } if (break_out) { break; } } JSON_DEBUG("json_eat_whitespace: ending pos %d", ctx->pos); } #define JsAppendBuf(str, ctx, start_pos, offset) ( str ? (sv_catpvn(str, ctx->data + start_pos, ctx->pos - start_pos - offset), str) : newSVpv(ctx->data + start_pos, ctx->pos - start_pos - offset) ) #define JsAppendCBuf(str, buf, len) ( str ? (sv_catpvn(str, buf, len), str) : newSVpv(buf, len) ) static void json_eat_digits(json_context *ctx) { unsigned char looking_at; looking_at = JsCurChar(ctx); while (ctx->pos < ctx->len && looking_at >= '0' && looking_at <= '9') { JsNextChar(ctx); looking_at = JsCurChar(ctx); } } #define kParseNumberHaveSign 1 #define kParseNumberHaveDecimal (1 << 1) #define kParseNumberHaveExponent (1 << 2) #define kParseNumberDone (1 << 3) #define kParseNumberTryBigNum (1 << 4) static SV * json_parse_number(json_context *ctx, SV * tmp_str) { SV * rv = NULL; unsigned char looking_at; STRLEN start_pos = ctx->pos; NV nv_value = 0; /* double */ UV uv_value = 0; IV iv_value = 0; SV * tmp_sv = NULL; UV flags = 0; char *uv_str = NULL; /* char uv_str[(IV_DIG > UV_DIG ? IV_DIG : UV_DIG) + 1]; */ STRLEN size = 0; looking_at = JsNextChar(ctx); if (looking_at == '-') { JsNextChar(ctx); looking_at = JsNextChar(ctx); flags |= kParseNumberHaveSign; } if (looking_at < '0' || looking_at > '9') { JSON_DEBUG("syntax error at byte %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "syntax error (not a digit)"); return (SV *)&PL_sv_undef; } ctx->number_count++; json_eat_digits(ctx); if (tmp_str) { sv_setpvn(tmp_str, "", 0); rv = tmp_str; } if (ctx->pos < ctx->len) { looking_at = JsCurChar(ctx); if (looking_at == '.') { JsNextChar(ctx); json_eat_digits(ctx); looking_at = JsCurChar(ctx); flags |= kParseNumberHaveDecimal; } if (ctx->pos < ctx->len) { if (looking_at == 'E' || looking_at == 'e') { /* exponential notation */ flags |= kParseNumberHaveExponent; JsNextChar(ctx); if (ctx->pos < ctx->len) { looking_at = JsCurChar(ctx); if (looking_at == '+' || looking_at == '-') { JsNextChar(ctx); looking_at = JsCurChar(ctx); } json_eat_digits(ctx); looking_at = JsCurChar(ctx); } } } } rv = JsAppendBuf(rv, ctx, start_pos, 0); size = ctx->pos - start_pos; if (flags & (kParseNumberHaveDecimal | kParseNumberHaveExponent)) { if (flags & kParseNumberHaveSign) { if (size - 1 >= DBL_DIG) { flags |= kParseNumberTryBigNum; } } else { if (size >= DBL_DIG) { flags |= kParseNumberTryBigNum; } } } else { if (flags & kParseNumberHaveSign) { if (size - 1 >= IV_DIG) { if (size - 1 == IV_DIG) { uv_str = form("%"IVdf"", IV_MIN); if (strncmp(ctx->data + start_pos, uv_str, size) > 0) { flags |= kParseNumberTryBigNum; } } else { flags |= kParseNumberTryBigNum; } } } else { if (size >= UV_DIG) { if (size == UV_DIG) { uv_str = form("%"UVuf"", UV_MAX); if (strncmp(ctx->data + start_pos, uv_str, size) > 0) { flags |= kParseNumberTryBigNum; } } else { flags |= kParseNumberTryBigNum; } } } } if (flags & kParseNumberTryBigNum) { tmp_sv = rv; rv = NULL; if (flags & (kParseNumberHaveDecimal | kParseNumberHaveExponent)) { if (have_bigfloat()) { rv = get_new_big_float(tmp_sv); } } else { if (have_bigint()) { rv = get_new_big_int(tmp_sv); } } if (rv) { if (SvOK(rv)) { if (tmp_str) { sv_setsv(tmp_str, rv); SvREFCNT_dec(rv); rv = tmp_str; } else { SvREFCNT_dec(tmp_sv); } flags |= kParseNumberDone; } else { JSON_DEBUG("got undef when creating big num"); rv = tmp_sv; } } else { rv = tmp_sv; } } if (! (flags & kParseNumberDone) && ! (flags & kParseNumberTryBigNum)) { if (flags & (kParseNumberHaveDecimal | kParseNumberHaveExponent)) { nv_value = SvNV(rv); sv_setnv(rv, nv_value); } else if (flags & kParseNumberHaveSign) { iv_value = SvIV(rv); sv_setiv(rv, iv_value); } else { uv_value = SvUV(rv); sv_setuv(rv, uv_value); } } return rv; } static SV * json_parse_word(json_context *ctx, SV * tmp_str, int is_identifier) { SV * rv = NULL; UV looking_at; UV this_char; STRLEN start_pos = 0; UV tmp_uv; STRLEN tmp_len; looking_at = JsCurChar(ctx); if (looking_at >= '0' && looking_at <= '9') { JSON_DEBUG("json_parse_word(): starts with digit, so calling json_parse_number()"); return json_parse_number(ctx, tmp_str); } if (tmp_str) { sv_setpvn(tmp_str, "", 0); rv = tmp_str; } start_pos = ctx->pos; while (ctx->pos < ctx->len) { looking_at = JsCurChar(ctx); JSON_DEBUG("looking at %04x", looking_at); if ( (looking_at >= '0' && looking_at <= '9') || (looking_at >= 'A' && looking_at <= 'Z') || (looking_at >= 'a' && looking_at <= 'z') || looking_at == '_' ) { JSON_DEBUG("json_parse_word(): got %04x at %d", looking_at, ctx->pos); this_char = JsNextCharWithArg(ctx, tmp_uv, tmp_len); } else { if (ctx->pos == start_pos) { /* syntax error */ JSON_DEBUG("syntax error at byte %d, looking_at = %04x", ctx->pos, looking_at); ctx->error = JSON_PARSE_ERROR(ctx, "syntax error (invalid char)"); return (SV *)&PL_sv_undef; } else { UNLESS (is_identifier) { if (strnEQ("true", ctx->data + start_pos, ctx->pos - start_pos)) { JSON_DEBUG("returning true from json_parse_word() at byte %d", ctx->pos); ctx->bool_count++; if (ctx->flags & kConvertBool) { return get_new_bool_obj(1); } else { return JsAppendCBuf(rv, "1", 1); } } else if (strnEQ("false", ctx->data + start_pos, ctx->pos - start_pos)) { JSON_DEBUG("returning false from json_parse_word() at byte %d", ctx->pos); ctx->bool_count++; if (ctx->flags & kConvertBool) { return get_new_bool_obj(0); } else { return JsAppendCBuf(rv, "0", 1); } } else if (strnEQ("null", ctx->data + start_pos, ctx->pos - start_pos)) { JSON_DEBUG("returning undef from json_parse_word() at byte %d", ctx->pos); ctx->null_count++; return (SV *)newSV(0); } } JSON_DEBUG("returning from json_parse_word() at byte %d", ctx->pos); ctx->string_count++; return JsAppendBuf(rv, ctx, start_pos, 0); } break; } } JSON_DEBUG("syntax error at byte %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "syntax error"); return (SV *)&PL_sv_undef; } /* Finds the end of the current string by looking for the appropriate closing quote char that is not escaped. Since the parsed string will always be less than or equal to the size of the encoded string, this function returns an upper boundary on the size needed for the resulting string. If the Perl string is preallocated at this length, parsing runs faster. */ static STRLEN find_length_of_string(json_context *ctx, UV boundary) { STRLEN pos = ctx->pos; STRLEN len = 0; UV this_char = 0x00; int escaped = 0; while (pos < ctx->len) { if (UTF8_IS_INVARIANT(ctx->data[pos])) { this_char = ctx->data[pos]; pos++; } else { this_char = convert_utf8_to_uv((unsigned char *)&(ctx->data[pos]), &len); pos += len; } if (escaped) { escaped = 0; } else { if (this_char == boundary) { return pos - ctx->pos; } else if (this_char == '\\') { escaped = 1; } } } return 0; } static SV * json_parse_string(json_context *ctx, SV * tmp_str) { UV looking_at; UV boundary; UV this_uv = 0; UV next_uv = 0; U8 unicode_digits[5]; /* STRLEN grok_len = 0; */ /* I32 grok_flags = 0; */ STRLEN orig_start_pos; SV * rv = NULL; char * char_buf; int i; U8 * tmp_buf = NULL; STRLEN max_str_size = 0; UV tmp_uv; STRLEN tmp_len; unsigned int start_char_pos = 0; unicode_digits[4] = '\x00'; looking_at = JsCurChar(ctx); if (looking_at != '"' && looking_at != '\'') { return (SV *)&PL_sv_undef; } ctx->string_count++; boundary = looking_at; this_uv = JsNextCharWithArg(ctx, tmp_uv, tmp_len); next_uv = JsCurChar(ctx); orig_start_pos = ctx->pos; start_char_pos = ctx->char_pos; /* FIXME: compute an estimate for the buffer size instead of passing zero */ max_str_size = find_length_of_string(ctx, boundary); JSON_DEBUG("computed max size %d at pos %d", max_str_size, ctx->pos); /* tmp_str = NULL; */ if (tmp_str) { rv = tmp_str; SvGROW(rv, max_str_size); } else { rv = newSV(max_str_size); } sv_setpvn(rv, "", 0); /* rv = newSVpv("", 0); */ JSON_DEBUG("HERE, json_parse_string(), looking for boundary %04x", boundary); while (ctx->pos < ctx->len) { JSON_DEBUG("pos %d, looking at %04x", ctx->pos, next_uv); this_uv = JsNextCharWithArg(ctx, tmp_uv, tmp_len); if (next_uv == boundary) { JSON_DEBUG("found boundary %04x", boundary); tmp_len = SvCUR(rv); if (tmp_len > ctx->longest_string_bytes) { ctx->longest_string_bytes = tmp_len; } tmp_len = ctx->char_pos - start_char_pos - 1; if (tmp_len > ctx->longest_string_chars) { ctx->longest_string_chars = tmp_len; } return rv; } else if (this_uv == '\\') { this_uv = JsNextCharWithArg(ctx, tmp_uv, tmp_len); next_uv = JsCurChar(ctx); char_buf = NULL; switch (this_uv) { case 'b': char_buf = "\b"; break; case 'f': char_buf = "\f"; break; case 'n': char_buf = "\x0a"; break; case 'r': char_buf = "\x0d"; break; case 't': char_buf = "\t"; break; /* these go through as themselves */ case '\\': case '/': case '"': case '\'': char_buf = ctx->data + ctx->pos - 1; break; case 'u': break; default: /* unrecognized escape sequence, so send the escaped char through as itself */ char_buf = ctx->data + ctx->pos - 1; break; } if (char_buf) { sv_catpvn(rv, char_buf, 1); } else { switch (this_uv) { case 'u': for (i = 0; i < 4 && ctx->pos < ctx->len; i++) { this_uv = JsNextCharWithArg(ctx, tmp_uv, tmp_len); if ( (this_uv >= '0' && this_uv <= '9') || (this_uv >= 'A' && this_uv <= 'F') || (this_uv >= 'a' && this_uv <= 'f') ) { unicode_digits[i] = (U8)this_uv; } else { unicode_digits[i] = '\x00'; ctx->error = JSON_PARSE_ERROR(ctx, "bad unicode character specification \"\\u%s\"", unicode_digits); if (rv && !tmp_str) { SvREFCNT_dec(rv); rv = NULL; } return (SV *)&PL_sv_undef; } } if (i != 4) { unicode_digits[i] = '\x00'; ctx->error = JSON_PARSE_ERROR(ctx, "bad unicode character specification \"\\u%s\"", unicode_digits); if (rv && !tmp_str) { SvREFCNT_dec(rv); rv = NULL; } return (SV *)&PL_sv_undef; } JSON_DEBUG("found wide char %s\n", unicode_digits); next_uv = JsCurChar(ctx); /* grok_hex() not available in perl 5.6 */ /* grok_len = 4;*/ /* this_uv = grok_hex((char *)unicode_digits, &grok_len, &grok_flags, NULL); */ sscanf((char *)unicode_digits, "%04"UVxf, &this_uv); tmp_buf = convert_uv_to_utf8(unicode_digits, this_uv); UNLESS (SvUTF8(rv)) { SvUTF8_on(rv); /* sv_utf8_upgrade(rv); */ } sv_catpvn(rv, (char *)unicode_digits, PTR2UV(tmp_buf) - PTR2UV(unicode_digits)); break; default: break; } } } else { tmp_buf = convert_uv_to_utf8(unicode_digits, this_uv); sv_catpvn(rv, (char *)unicode_digits, PTR2UV(tmp_buf) - PTR2UV(unicode_digits)); JSON_DEBUG("before JsCurChar()"); next_uv = JsCurChar(ctx); JSON_DEBUG("after next_char(), got %04x", next_uv); } } ctx->error = JSON_PARSE_ERROR(ctx, "unterminated string starting at byte %d", orig_start_pos); return (SV *)&PL_sv_undef; } static SV * json_parse_object(json_context *ctx, unsigned int cur_level) { UV looking_at; HV * hash; SV * key = Nullsv; SV * val = Nullsv; SV * tmp_str; int found_comma = 0; UV tmp_uv; STRLEN tmp_len; looking_at = JsCurChar(ctx); if (looking_at != '{') { JSON_DEBUG("json_parse_object: looking at %04x", looking_at); return (SV *)&PL_sv_undef; } ctx->hash_count++; cur_level++; UPDATE_CUR_LEVEL(ctx, cur_level); hash = newHV(); JsNextCharWithArg(ctx, tmp_uv, tmp_len); json_eat_whitespace(ctx, kCommasAreWhitespace); looking_at = JsCurChar(ctx); JSON_DEBUG("json_parse_object: looking at %04x", looking_at); if (looking_at == '}') { JsNextCharWithArg(ctx, tmp_uv, tmp_len); return (SV *)newRV_noinc((SV *)hash); } /* key = tmp_str = sv_newmortal(); */ key = tmp_str = newSVpv("DEADBEEF", 8); /* assign something so we can call SvGROW() later without causing a bus error */ /* sv_setpvn(key, "DEADBEEF", 8); */ while (ctx->pos < ctx->len) { looking_at = JsCurChar(ctx); found_comma = 0; if (looking_at == '"' || looking_at == '\'') { key = json_parse_string(ctx, key); } else { JSON_DEBUG("looking at %04x at %d", looking_at, ctx->pos); key = json_parse_word(ctx, key, 1); } if (ctx->error) { SvREFCNT_dec(tmp_str); SvREFCNT_dec((SV *)hash); return val; } JSON_DEBUG("looking at %04x at %d", looking_at, ctx->pos); json_eat_whitespace(ctx, 0); looking_at = JsCurChar(ctx); JSON_DEBUG("looking at %04x at %d", looking_at, ctx->pos); if (looking_at != ':') { JSON_DEBUG("bad object at %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "bad object (expected ':')"); SvREFCNT_dec(tmp_str); SvREFCNT_dec((SV *)hash); return (SV *)&PL_sv_undef; } JsNextCharWithArg(ctx, tmp_uv, tmp_len); json_eat_whitespace(ctx, 0); val = json_parse_value(ctx, 0, cur_level); if (ctx->error) { SvREFCNT_dec(tmp_str); SvREFCNT_dec((SV *)hash); return val; } hv_store_ent(hash, key, val, 0); key = tmp_str; json_eat_whitespace(ctx, 0); looking_at = JsCurChar(ctx); if (looking_at == ',') { found_comma = 1; json_eat_whitespace(ctx, kCommasAreWhitespace); looking_at = JsCurChar(ctx); } switch (looking_at) { case '}': JsNextCharWithArg(ctx, tmp_uv, tmp_len); SvREFCNT_dec(tmp_str); return (SV *)newRV_noinc((SV *)hash); break; case ',': JsNextCharWithArg(ctx, tmp_uv, tmp_len); json_eat_whitespace(ctx, 0); break; default: UNLESS (found_comma) { JSON_DEBUG("bad object at %d (%c)", ctx->pos, looking_at); ctx->error = JSON_PARSE_ERROR(ctx, "bad object (expected ',' or '}'"); SvREFCNT_dec(tmp_str); return (SV *)&PL_sv_undef; } break; } } SvREFCNT_dec(tmp_str); JSON_DEBUG("bad object at %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "bad object"); return (SV *)&PL_sv_undef; } static SV * json_parse_array(json_context *ctx, unsigned int cur_level) { unsigned char looking_at; AV * array; SV * val; int found_comma = 0; looking_at = JsCurChar(ctx); if (looking_at != '[') { return (SV *)&PL_sv_undef; } ctx->array_count++; cur_level++; UPDATE_CUR_LEVEL(ctx, cur_level); JsNextChar(ctx); json_eat_whitespace(ctx, 0); array = newAV(); looking_at = JsCurChar(ctx); if (looking_at == ']') { JsNextChar(ctx); return (SV *)newRV_noinc((SV *)array); } while (ctx->pos < ctx->len) { found_comma = 0; json_eat_whitespace(ctx, kCommasAreWhitespace); val = json_parse_value(ctx, 0, cur_level); av_push(array, val); json_eat_whitespace(ctx, 0); looking_at = JsCurChar(ctx); if (looking_at == ',') { found_comma = 1; json_eat_whitespace(ctx, kCommasAreWhitespace); looking_at = JsCurChar(ctx); } switch (looking_at) { case ']': JsNextChar(ctx); return (SV *)newRV_noinc((SV *)array); break; case ',': JsNextChar(ctx); json_eat_whitespace(ctx, kCommasAreWhitespace); /* json_eat_whitespace(ctx, 0); */ break; default: UNLESS (found_comma) { JSON_DEBUG("bad array at %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "syntax error in array (expected ',' or ']')"); return (SV *)&PL_sv_undef; } break; } } JSON_DEBUG("bad array at %d", ctx->pos); ctx->error = JSON_PARSE_ERROR(ctx, "bad array"); return (SV *)&PL_sv_undef; } static SV * json_parse_value(json_context *ctx, int is_identifier, unsigned int cur_level) { UV looking_at; SV * rv; JSON_DEBUG("before eat_whitespace"); json_eat_whitespace(ctx, 0); JSON_DEBUG("after eat_whitespace"); if (ctx->pos >= ctx->len || !ctx->data) { ctx->error = JSON_PARSE_ERROR(ctx, "bad object"); return (SV *)&PL_sv_undef; } looking_at = JsCurChar(ctx); JSON_DEBUG("json_parse_value: looking at %04x", looking_at); switch (looking_at) { case '{': JSON_DEBUG("before json_parse_object()"); rv = json_parse_object(ctx, cur_level); JSON_DEBUG("after json_parse_object"); return rv; break; case '[': JSON_DEBUG("before json_parse_array()"); rv = json_parse_array(ctx, cur_level); JSON_DEBUG("after json_parse_array()"); return rv; break; case '"': case '\'': JSON_DEBUG("before json_parse_string(), found %04x", looking_at); rv = json_parse_string(ctx, 0); JSON_DEBUG("after json_parse_string()"); return rv; break; case '-': rv = json_parse_number(ctx, 0); return rv; break; default: rv = json_parse_word(ctx, 0, is_identifier); return rv; break; } } static SV * parse_json(json_context * ctx) { SV * rv = json_parse_value(ctx, 0, 0); json_eat_whitespace(ctx, 0); if (! ctx->error && ctx->pos < ctx->len) { ctx->error = JSON_PARSE_ERROR(ctx, "syntax error"); SvREFCNT_dec(rv); rv = &PL_sv_undef; } return rv; } static SV * from_json (SV * self, char * data_str, STRLEN data_str_len, SV ** error_msg, int *throw_exception, SV * error_data_ref, SV * stats_data_ref) { json_context ctx; SV * val; SV ** ptr; SV * self_hash = SvRV(self); SV * data = Nullsv; SV * passed_error_data_sv = Nullsv; /* int is_utf8 = 0; int is_utf_16be = 0; int is_utf_32be = 0; */ /* data_str = SvPV(data_sv, data_str_len); */ UNLESS (data_str) { /* return undef */ return (SV *)&PL_sv_undef; } if (data_str_len == 0) { /* return empty string */ val = newSVpv("", 0); return val; } /* if (data_str_len >= 2) { if (data_str[0] != '\x00' && data_str[1] != '\x00') { is_utf8 = 1; } else if (data_str_len >= 4) { if (data_str[0] == '\x00') { if (data_str[1] != '\x00' && data_str[2] == '\x00' && data_str[3] != '\x00') { is_utf_16be = 1; } else if (data_str[1] == '\x00' && data_str[2] == '\x00' && data_str[3] != '\x00') { is_utf_32be = 1; } } else { } } } */ memzero(&ctx, sizeof(json_context)); ctx.len = data_str_len; ctx.data = data_str; ctx.pos = 0; ctx.error = (SV *)0; ctx.self = self; ctx.bad_char_policy = get_bad_char_policy((HV *)self_hash); ctx.line = 1; ctx.col = 0; ptr = hv_fetch((HV *)self_hash, "convert_bool", 12, 0); if (ptr && SvTRUE(*ptr)) { ctx.flags |= kConvertBool; } val = parse_json(&ctx); if (ctx.error) { *error_msg = ctx.error; if (SvOK(error_data_ref) && SvROK(error_data_ref) && ctx.error_data) { passed_error_data_sv = SvRV(error_data_ref); sv_setsv(passed_error_data_sv, ctx.error_data); } } else { *error_msg = (SV *)&PL_sv_undef; } /* if do stats */ if (SvOK(stats_data_ref) && SvROK(stats_data_ref)) { data = SvRV(stats_data_ref); /* FIXME: should destroy these if the store fails */ hv_store((HV *)data, "strings", 7, newSVuv(ctx.string_count), 0); hv_store((HV *)data, "max_string_bytes", 16, newSVuv(ctx.longest_string_bytes), 0); hv_store((HV *)data, "max_string_chars", 16, newSVuv(ctx.longest_string_chars), 0); hv_store((HV *)data, "numbers", 7, newSVuv(ctx.number_count), 0); hv_store((HV *)data, "bools", 5, newSVuv(ctx.bool_count), 0); hv_store((HV *)data, "nulls", 5, newSVuv(ctx.null_count), 0); hv_store((HV *)data, "hashes", 6, newSVuv(ctx.hash_count), 0); hv_store((HV *)data, "arrays", 6, newSVuv(ctx.array_count), 0); hv_store((HV *)data, "max_depth", 9, newSVuv(ctx.deepest_level), 0); hv_store((HV *)data, "lines", 5, newSVuv(ctx.line), 0); hv_store((HV *)data, "bytes", 5, newSVuv(ctx.pos), 0); hv_store((HV *)data, "chars", 5, newSVuv(ctx.char_pos), 0); } return (SV *)val; } static SV * from_json_sv (SV * self, SV * data_sv, SV ** error_msg, int *throw_exception, SV * error_data_ref, SV * stats_data_ref) { STRLEN data_str_len; char * data_str; data_str = SvPV(data_sv, data_str_len); return from_json(self, data_str, data_str_len, error_msg, throw_exception, error_data_ref, stats_data_ref); } /* static int get_unicode_char_count(SV * self, U8 *c_str, STRLEN len) { STRLEN i; U32 count = 0; for (i = 0; i < len; i++) { if (! UTF8_IS_INVARIANT(c_str[i])) { len = UTF8SKIP(&c_str[i]); i += len - 1; count++; } } return count; } */ #if 0 static SV * parse_json_file(SV * self, SV * file, SV * error_msg_ref) { SV * rv; SV * error_msg; SV * passed_error_msg_sv; int throw_exception = 0; char * data; STRLEN data_len; char * filename; char * filename_len; FILE * fp; filename = SvPV(file, filename_len); if (! filename || ! (fp = fopen(filename, "r")) ) { /* FIXME: put a good error msg here */ return &PL_sv_undef; } /* FIXME: read from file here */ error_msg = (SV *)&PL_sv_undef; rv = from_json(self, data, data_len, &error_msg, &throw_exception); if (SvOK(error_msg) && SvROK(error_msg_ref)) { passed_error_msg_sv = SvRV(error_msg_ref); sv_setsv(passed_error_msg_sv, error_msg); } return rv; } #endif static SV * escape_json_str(self_context * self, SV * sv_str) { U8 * data_str; STRLEN data_str_len; STRLEN needed_len = 0; STRLEN sv_pos = 0; STRLEN len = 0; U8 * tmp_str = NULL; U8 tmp_char = 0x00; SV * rv; int check_unicode = 1; /* FIXME: get rid of this */ UV this_uv = 0; U8 unicode_bytes[5]; int escape_unicode = 0; int pass_bad_char = 0; memzero(unicode_bytes, 5); /* memzero macro provided by Perl */ UNLESS (SvOK(sv_str)) { return newSVpv("null", 4); } data_str = (U8 *)SvPV(sv_str, data_str_len); UNLESS (data_str) { return newSVpv("null", 4); } self->string_count++; if (data_str_len == 0) { /* empty string */ return newSVpv("\"\"", 2); } if (self->flags & kEscapeMultiByte) { escape_unicode = 1; } /* get a better estimate of needed buffer size */ needed_len = data_str_len * 2 + 2; /* check_unicode = SvUTF8(sv_str); */ rv = newSV(needed_len); if (check_unicode) { SvUTF8_on(rv); } sv_setpvn(rv, "\"", 1); /* printf("\tencoding string %s\n", data_str); */ #if DEBUG_UTF8 fprintf(stderr, "\tencoding string "); print_hex_line(stderr, data_str, data_str_len); /* if (data_str[0] == 0xe4) { */ sv_dump(sv_str); /* } */ fprintf(stderr, "==========\n"); #endif for (sv_pos = 0; sv_pos < data_str_len; sv_pos++) { pass_bad_char = 0; if (check_unicode) { len = UTF8SKIP(&data_str[sv_pos]); if (len > 1) { this_uv = convert_utf8_to_uv(&data_str[sv_pos], &len); if (this_uv == 0 && data_str[sv_pos] != 0) { UNLESS (self->bad_char_policy) { /* default */ if (data_str_len < 40) { self->error = JSON_ENCODE_ERROR(self, "bad utf8 sequence starting with %#02x - %s", (UV)data_str[sv_pos], data_str); } else { self->error = JSON_ENCODE_ERROR(self, "bad utf8 sequence starting with %#02x", (UV)data_str[sv_pos]); } sv_catpvn(rv, "\"", 1); return rv; } else if (self->bad_char_policy & kBadCharConvert) { this_uv = (UV)data_str[sv_pos]; } else if (self->bad_char_policy & kBadCharPassThrough) { this_uv = (UV)data_str[sv_pos]; pass_bad_char = 1; } } sv_pos += len - 1; } else { this_uv = data_str[sv_pos]; } } else { this_uv = data_str[sv_pos]; } switch (this_uv) { case '\\': sv_catpvn(rv, "\\\\", 2); break; case '"': sv_catpvn(rv, "\\\"", 2); break; /* case '\'': sv_catpvn(rv, "\\'", 2); break; */ case '/': sv_catpvn(rv, "\\/", 2); break; case 0x08: sv_catpvn(rv, "\\b", 2); break; case 0x0c: sv_catpvn(rv, "\\f", 2); break; case 0x0a: sv_catpvn(rv, "\\n", 2); break; case 0x0d: sv_catpvn(rv, "\\r", 2); break; case 0x09: sv_catpvn(rv, "\\t", 2); break; default: if (this_uv < 0x1f) { sv_catpvf(rv, "\\u%04x", this_uv); } else if (escape_unicode && ! UTF8_IS_INVARIANT(this_uv)) { sv_catpvf(rv, "\\u%04x", this_uv); } else if (check_unicode && !pass_bad_char) { tmp_str = convert_uv_to_utf8(unicode_bytes, this_uv); if (PTR2UV(tmp_str) - PTR2UV(unicode_bytes) > 1) { UNLESS (SvUTF8(rv)) { SvUTF8_on(rv); } } sv_catpvn(rv, (char *)unicode_bytes, PTR2UV(tmp_str) - PTR2UV(unicode_bytes)); } else { tmp_char = (U8)this_uv; sv_catpvn(rv, (char *)&tmp_char, 1); } break; } } sv_catpvn(rv, "\"", 1); return rv; } static SV * encode_array(self_context * self, AV * array, int indent_level, unsigned int cur_level) { SV * rsv = NULL; SV * tmp_sv = NULL; I32 max_i = av_len(array); /* max index, not length */ I32 i; I32 j; SV ** element = NULL; I32 num_spaces = 0; MAGIC * magic_ptr = NULL; JsDumpSv((SV *)array, self->flags); cur_level++; UPDATE_CUR_LEVEL(self, cur_level); self->array_count++; if (self->flags & kPrettyPrint) { if (indent_level == 0) { rsv = newSVpv("[", 1); } else { num_spaces = indent_level * 4; rsv = newSV(num_spaces + 3); sv_setpvn(rsv, "\n", 1); for (i = 0; i < num_spaces; i++) { sv_catpvn(rsv, " ", 1); } sv_catpvn(rsv, "[", 1); } } else { rsv = newSVpv("[", 1); } num_spaces = (indent_level + 1) * 4; magic_ptr = mg_find((SV *)array, PERL_MAGIC_tied); for (i = 0; i <= max_i; i++) { element = av_fetch(array, i, 0); if (element && *element) { if (self->flags & kDumpVars) { fprintf(stderr, "array element:\n"); } /* need to call mg_get(val) to get the actual value if this is a tied array */ /* see sv_magic */ if (magic_ptr || SvTYPE(*element) == SVt_PVMG) { /* mg_get(*element); */ /* causes assertion failure in perl 5.8.5 if tied scalar */ SvGETMAGIC(*element); } tmp_sv = to_json(self, *element, indent_level + 1, cur_level); if (self->flags & kPrettyPrint) { sv_catpvn(rsv, "\n", 1); for (j = 0; j < num_spaces; j++) { sv_catpvn(rsv, " ", 1); } } sv_catsv(rsv, tmp_sv); SvREFCNT_dec(tmp_sv); if (self->error) { SvREFCNT_dec(rsv); return (SV *)&PL_sv_undef; } tmp_sv = NULL; } else { /* error? */ sv_catpvn(rsv, "null", 4); } if (i != max_i) { sv_catpvn(rsv, ",", 1); } } if (self->flags & kPrettyPrint) { sv_catpvn(rsv, "\n", 1); num_spaces = indent_level * 4; for (j = 0; j < num_spaces; j++) { sv_catpvn(rsv, " ", 1); } } sv_catpvn(rsv, "]", 1); return rsv; } static void setup_self_context(SV *self_sv, self_context *self) { SV ** ptr = NULL; SV * self_hash = NULL; memzero((void *)self, sizeof(self_context)); UNLESS (SvROK(self_sv)) { /* hmmm, this should always be a reference */ return; } self_hash = SvRV(self_sv); ptr = hv_fetch((HV *)self_hash, "bare_keys", 9, 0); if (ptr && SvTRUE(*ptr)) { self->bare_keys = 1; } ptr = hv_fetch((HV *)self_hash, "use_exceptions", 14, 0); if (ptr && SvTRUE(*ptr)) { self->flags |= kUseExceptions; } self->bad_char_policy = get_bad_char_policy((HV *)self_hash); ptr = hv_fetch((HV *)self_hash, "dump_vars", 9, 0); if (ptr && SvTRUE(*ptr)) { self->flags |= kDumpVars; } ptr = hv_fetch((HV *)self_hash, "pretty", 6, 0); if (ptr && SvTRUE(*ptr)) { self->flags |= kPrettyPrint; } ptr = hv_fetch((HV *)self_hash, "escape_multi_byte", 17, 0); if (ptr && SvTRUE(*ptr)) { self->flags |= kEscapeMultiByte; } #if JSON_DUMP_OPTIONS { char * char_policy = NULL; switch (self->bad_char_policy) { case kBadCharError: char_policy = "error"; break; case kBadCharConvert: char_policy = "convert"; break; case kBadCharPassThrough: char_policy = "pass_through"; break; default: char_policy = "unrecognized bad_char policy"; break; } fprintf(stderr, "\nBad char policy: %s\n", char_policy); if (self->flags & kUseExceptions) { fprintf(stderr, "Use Exceptions\n"); } if (self->flags & kDumpVars) { fprintf(stderr, "Dump Vars\n"); } if (self->flags & kPrettyPrint) { fprintf(stderr, "Pretty Print\n"); } if (self->flags & kEscapeMultiByte) { fprintf(stderr, "Escape Multi-Byte Characters\n"); } fprintf(stderr, "\n"); fflush(stderr); } #endif } static int hash_key_can_be_bare(self_context * self, U8 *key, STRLEN key_len) { U8 this_byte; STRLEN i; UNLESS (self->bare_keys) { return 0; } /* Only allow if 7-bit ascii, so use byte semantics, and only allow if alphanumeric and '_'. */ for (i = 0; i < key_len; i++) { this_byte = *key; key++; UNLESS (this_byte == '_' || (this_byte >= 'A' && this_byte <= 'Z') || (this_byte >= 'a' && this_byte <= 'z') || (this_byte >= '0' && this_byte <= '9') ) { return 0; } } return 1; } static SV * encode_hash(self_context * self, HV * hash, int indent_level, unsigned int cur_level) { SV * rsv = NULL; SV * tmp_sv = NULL; SV * tmp_sv2 = NULL; U8 * key; I32 key_len; SV * val; int first = 1; int i; int num_spaces = 0; MAGIC * magic_ptr = NULL; HE * entry; SV * key_sv = NULL; cur_level++; UPDATE_CUR_LEVEL(self, cur_level); self->hash_count++; if (self->flags & kPrettyPrint) { if (indent_level == 0) { rsv = newSVpv("{", 1); } else { num_spaces = indent_level * 4; rsv = newSV(num_spaces + 3); sv_setpvn(rsv, "\n", 1); for (i = 0; i < num_spaces; i++) { sv_catpvn(rsv, " ", 1); } sv_catpvn(rsv, "{", 1); } } else { rsv = newSVpv("{", 1); } JsDumpSv((SV *)hash, self->flags); magic_ptr = mg_find((SV *)hash, PERL_MAGIC_tied); num_spaces = (indent_level + 1) * 4; /* non-sorted keys */ hv_iterinit(hash); /* while ( (val = hv_iternextsv(hash, (char **)&key, &key_len)) ) { */ while (1) { entry = hv_iternext(hash); UNLESS (entry) { break; } key_sv = HeSVKEY(entry); key = (unsigned char *)hv_iterkey(entry, &key_len); /* key = (U8 *)HePV(entry, key_len); */ val = hv_iterval(hash, entry); UNLESS (first) { sv_catpvn(rsv, ",", 1); } first = 0; /* need to call mg_get(val) to get the actual value if this is a tied hash */ /* see sv_magic */ if (magic_ptr || SvTYPE(val) == SVt_PVMG) { /* mg_get(val); */ /* crashes in Perl 5.8.5 if doesn't have "get magic" */ SvGETMAGIC(val); } if (self->flags & kDumpVars) { fprintf(stderr, "hash key = %s\nval:\n", key); } if (self->flags & kPrettyPrint) { sv_catpvn(rsv, "\n", 1); for (i = 0; i < num_spaces; i++) { sv_catpvn(rsv, " ", 1); } } if (hash_key_can_be_bare(self, key, key_len)) { /* if the key can be bare, then it cannot have any hi-bits set, so no need to upgrade to utf-8 */ sv_catpvn(rsv, (char *)key, key_len); } else { tmp_sv = newSVpv((char *)key, key_len); #ifdef IS_PERL_5_8 if (HeKWASUTF8(entry)) { /* The hash key was utf-8 encoding, but the char * was given to us with as the decoded bytes (e.g., utf-8 => latin1), so convert back to utf-8 */ sv_utf8_upgrade(tmp_sv); } #endif tmp_sv2 = escape_json_str(self, tmp_sv); if (self->error) { SvREFCNT_dec(tmp_sv); SvREFCNT_dec(tmp_sv2); SvREFCNT_dec(rsv); return (SV *)&PL_sv_undef; } sv_catsv(rsv, tmp_sv2); SvREFCNT_dec(tmp_sv); SvREFCNT_dec(tmp_sv2); } sv_catpvn(rsv, ":", 1); tmp_sv = to_json(self, val, indent_level + 2, cur_level); if (self->error) { SvREFCNT_dec(tmp_sv); SvREFCNT_dec(rsv); return (SV *)&PL_sv_undef; } sv_catsv(rsv, tmp_sv); SvREFCNT_dec(tmp_sv); } if (self->flags & kPrettyPrint) { sv_catpvn(rsv, "\n", 1); num_spaces = indent_level * 4; for (i = 0; i < num_spaces; i++) { sv_catpvn(rsv, " ", 1); } } sv_catpvn(rsv, "}", 1); return rsv; } static SV * to_json(self_context * self, SV * data_ref, int indent_level, unsigned int cur_level) { SV * data; int type; SV * rsv = newSVpv("", 0); SV * tmp = NULL; STRLEN before_len = 0; U8 * data_str = NULL; STRLEN start = 0; STRLEN len = 0; JSON_DEBUG("to_json() called"); JsDumpSv(data_ref, self->flags); UNLESS (SvROK(data_ref)) { JSON_DEBUG("not a reference"); data = data_ref; if (SvOK(data)) { /* scalar */ type = SvTYPE(data); JSON_TRACE("found type %u", type); switch (type) { case SVt_NULL: /* undef? */ sv_setpvn(rsv, "null", 4); return rsv; break; case SVt_IV: case SVt_NV: before_len = JsSvLen(rsv); sv_catsv(rsv, data); self->number_count++; if (JsSvLen(rsv) == before_len) { sv_catpvn(rsv, "\"\"", 2); } return rsv; break; case SVt_PV: JSON_TRACE("found SVt_PV"); sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; /* this works for the error case as well */ break; case SVt_PVIV: case SVt_PVNV: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVLV: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; default: /* now what? */ JSON_DEBUG("unkown data type"); sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; } } else { /* undef */ sv_setpvn(rsv, "null", 4); return rsv; } } JSON_DEBUG("is a reference"); if (sv_isobject(data_ref)) { if (sv_isa(data_ref, "JSON::DWIW::Boolean")) { if (SvTRUE(data_ref)) { sv_setpvn(rsv, "true", 4); self->bool_count++; return rsv; } else { sv_setpvn(rsv, "false", 5); self->bool_count++; return rsv; } } else if (sv_derived_from(data_ref, "Math::BigInt") || sv_derived_from(data_ref, "Math::BigFloat")) { JSON_DEBUG("found big number"); tmp = newSVpv("", 0); sv_catsv(tmp, data_ref); data_str = (U8 *)SvPV(tmp, before_len); if (before_len > 0) { start = 0; len = before_len; if (data_str[0] == '+') { start++; len--; } if (data_str[before_len - 1] == '.') { len--; } sv_catpvn(rsv, (char *)data_str + start, len); } else { sv_setpvn(rsv, "\"\"", 2); } SvREFCNT_dec(tmp); return rsv; } } data = SvRV(data_ref); type = SvTYPE(data); switch (type) { case SVt_NULL: /* undef ? */ sv_setpvn(rsv, "null", 4); return rsv; break; case SVt_IV: case SVt_NV: before_len = JsSvLen(rsv); sv_catsv(rsv, data); if (JsSvLen(rsv) == before_len) { sv_catpvn(rsv, "\"\"", 2); } return rsv; break; case SVt_PV: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVIV: case SVt_PVNV: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; /* before_len = JsSvLen(rsv); sv_catsv(rsv, data); if (JsSvLen(rsv) == before_len) { sv_catpvn(rsv, "\"\"", 2); } return rsv; break; */ case SVt_RV: /* reference to a reference */ /* FIXME: implement */ sv_catsv(rsv, data_ref); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); /* sv_catpvn(rsv, "\"\"", 2); */ return rsv; break; case SVt_PVAV: /* array */ JSON_DEBUG("==========> found array ref"); SvREFCNT_dec(rsv); return encode_array(self, (AV *)data, indent_level, cur_level); break; case SVt_PVHV: /* hash */ JSON_DEBUG("==========> found hash ref"); SvREFCNT_dec(rsv); return encode_hash(self, (HV *)data, indent_level, cur_level); break; case SVt_PVCV: /* code */ sv_catsv(rsv, data_ref); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; /* sv_setpvn(rsv, "\"code\"", 6); return rsv; */ break; case SVt_PVGV: /* glob */ sv_catsv(rsv, data_ref); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVIO: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVMG: /* blessed or magical scalar */ if (sv_isobject(data_ref)) { sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; } else { sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; } break; default: sv_catsv(rsv, data); tmp = rsv; rsv = escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; /* sv_setpvn(rsv, "unknown type", 12); */ /* return rsv; */ break; } sv_setpvn(rsv, "unknown type 2", 14); return rsv; } static int set_encode_stats(self_context * ctx, SV * stats_data_ref) { SV * data = Nullsv; if (SvOK(stats_data_ref) && SvROK(stats_data_ref)) { data = SvRV(stats_data_ref); /* FIXME: should destroy these if the store fails */ /* hv_store((HV *)data, "max_string_bytes", 16, newSVuv(ctx->longest_string_bytes), 0); hv_store((HV *)data, "max_string_chars", 16, newSVuv(ctx->longest_string_chars), 0); hv_store((HV *)data, "nulls", 5, newSVuv(ctx->null_count), 0); */ /* hv_store((HV *)data, "strings", 7, newSVuv(ctx->string_count), 0); hv_store((HV *)data, "bools", 5, newSVuv(ctx->bool_count), 0); hv_store((HV *)data, "numbers", 7, newSVuv(ctx->number_count), 0); */ hv_store((HV *)data, "hashes", 6, newSVuv(ctx->hash_count), 0); hv_store((HV *)data, "arrays", 6, newSVuv(ctx->array_count), 0); hv_store((HV *)data, "max_depth", 9, newSVuv(ctx->deepest_level), 0); } return 1; } static SV * has_mmap() { #ifdef HAS_MMAP return &PL_sv_yes; #else return &PL_sv_no; #endif } static SV * parse_mmap_file(SV * self, SV * file, SV * error_msg_ref) { #if USE_MMAP char * filename; STRLEN filename_len; void * base; int fd = -1; struct stat file_info; size_t len = 0; SV * rv; int throw_exception = 0; SV * error_msg = &PL_sv_undef; SV * passed_error_msg_sv; UNLESS (SvOK(file)) { return &PL_sv_undef; } filename = (char *)SvPV(file, filename_len); fd = open(filename, O_RDONLY, 0644); if (fd < 0) { return &PL_sv_undef; } if (fstat(fd, &file_info)) { return &PL_sv_undef; } printf("HERE - filename='%s'\n", filename); /* FIXME: check here to see if file size too big, e.g., > 2GB */ len = file_info.st_size; base = mmap(NULL, len, PROT_READ, MAP_FILE, fd, 0); if (base == MAP_FAILED) { printf("mmap failed\n"); return &PL_sv_undef; } printf("HERE 2 - len=%u, base=%p\n", len, base); printf("data: "); fread(base, 1, len, stdout); printf("\n"); rv = from_json(self, base, len, &error_msg, &throw_exception); if (SvOK(error_msg) && SvROK(error_msg_ref)) { passed_error_msg_sv = SvRV(error_msg_ref); sv_setsv(passed_error_msg_sv, error_msg); } munmap(base, len); #else return &PL_sv_undef; #endif } MODULE = JSON::DWIW PACKAGE = JSON::DWIW PROTOTYPES: DISABLE SV * _xs_from_json(SV * self, SV * data, SV * error_msg_ref, SV * error_data_ref, SV * stats_data_ref) PREINIT: SV * rv; SV * error_msg; SV * passed_error_msg_sv; int throw_exception = 0; CODE: error_msg = (SV *)&PL_sv_undef; rv = from_json_sv(self, data, &error_msg, &throw_exception, error_data_ref, stats_data_ref); if (SvOK(error_msg) && SvROK(error_msg_ref)) { passed_error_msg_sv = SvRV(error_msg_ref); sv_setsv(passed_error_msg_sv, error_msg); } RETVAL = rv; OUTPUT: RETVAL SV * _xs_to_json(SV * self, SV * data, SV * error_msg_ref, SV * error_data_ref, SV * stats_ref) PREINIT: self_context self_context; SV * rv; int indent_level = 0; SV * passed_error_data_sv = Nullsv; CODE: setup_self_context(self, &self_context); rv = to_json(&self_context, data, indent_level, 0); if (SvOK(stats_ref)) { set_encode_stats(&self_context, stats_ref); } if (self_context.error) { sv_setsv(SvRV(error_msg_ref), self_context.error); if (SvOK(error_data_ref) && SvROK(error_data_ref) && self_context.error_data) { passed_error_data_sv = SvRV(error_data_ref); sv_setsv(passed_error_data_sv, self_context.error_data); } } RETVAL = rv; OUTPUT: RETVAL SV * have_big_int(SV * self) PREINIT: SV * rsv = newSV(0); int rv; CODE: self = self; rv = have_bigint(); if (rv) { sv_setsv(rsv, &PL_sv_yes); } else { sv_setsv(rsv, &PL_sv_no); } RETVAL = rsv; OUTPUT: RETVAL SV * have_big_float(SV * self) PREINIT: SV * rsv = newSV(0); int rv; CODE: self = self; /* get rid of compiler warnings */ rv = have_bigfloat(); if (rv) { sv_setsv(rsv, &PL_sv_yes); } else { sv_setsv(rsv, &PL_sv_no); } RETVAL = rsv; OUTPUT: RETVAL SV * size_of_uv(SV * self) PREINIT: SV * rsv = newSV(0); CODE: self = self; /* get rid of compiler warnings */ sv_setuv(rsv, UVSIZE); RETVAL = rsv; OUTPUT: RETVAL SV * peek_scalar(SV * self, SV * val) CODE: self = self; /* get rid of compiler warnings */ sv_dump(val); if (SvROK(val)) { sv_dump(SvRV(val)); } RETVAL = &PL_sv_yes; OUTPUT: RETVAL SV * is_valid_utf8(SV * self, SV * str) PREINIT: SV * rv = &PL_sv_no; U8 * s; STRLEN len; CODE: self = self; s = (U8 *)SvPV(str, len); if (is_utf8_string(s, len)) { rv = &PL_sv_yes; } RETVAL = rv; OUTPUT: RETVAL SV * flagged_as_utf8(SV * self, SV * str) PREINIT: SV * rv = &PL_sv_no; CODE: self = self; if (SvUTF8(str)) { rv = &PL_sv_yes; } RETVAL = rv; OUTPUT: RETVAL SV * flag_as_utf8(SV * self, SV * str) PREINIT: SV * rv = &PL_sv_yes; CODE: self = self; SvUTF8_on(str); RETVAL = rv; OUTPUT: RETVAL SV * unflag_as_utf8(SV * self, SV * str) PREINIT: SV * rv = &PL_sv_yes; CODE: self = self; SvUTF8_off(str); RETVAL = rv; OUTPUT: RETVAL SV * code_point_to_hex_bytes(SV *, SV * code_point_sv) PREINIT: UV code_point; U8 utf8_bytes[5]; U8 * tmp; STRLEN len = 0; SV * rv; CODE: utf8_bytes[4] = '\x00'; code_point = SvUV(code_point_sv); tmp = convert_uv_to_utf8(utf8_bytes, code_point); rv = newSVpv("", 0); if (PTR2UV(tmp) > PTR2UV(utf8_bytes)) { STRLEN i; len = PTR2UV(tmp) - PTR2UV(utf8_bytes); for (i = 0; i < len; i++) { sv_catpvf(rv, "\\x%02x", (unsigned int)utf8_bytes[i]); } } else { } RETVAL = rv; OUTPUT: RETVAL SV * bytes_to_code_points(SV *, SV * bytes) PREINIT: U8 * data_str; STRLEN data_str_len; AV * array = newAV(); STRLEN len = 0; UV this_char; STRLEN pos = 0; I32 max_i; SV * sv = NULL; STRLEN i; SV ** element; CODE: if (SvROK(bytes) && SvTYPE(SvRV(bytes)) == SVt_PVAV) { AV * av = (AV *)SvRV(bytes); max_i = av_len(av); sv = newSV(max_i); sv_setpvn(sv, "", 0); for (i = 0; i <= max_i; i++) { element = av_fetch(av, i , 0); if (element && *element) { this_char = SvUV(*element); fprintf(stderr, "%02"UVxf"\n", this_char); } else { this_char = 0; } sv_catpvf(sv, "%c", (unsigned char)this_char); } bytes = sv; } data_str = (U8 *)SvPV(bytes, data_str_len); while (pos < data_str_len) { this_char = convert_utf8_to_uv(&data_str[pos], &len); pos += len; av_push(array, newSVuv(this_char)); } if (sv) { SvREFCNT_dec(sv); } RETVAL = newRV_noinc((SV *)array); OUTPUT: RETVAL SV * _has_mmap() CODE: RETVAL = has_mmap(); OUTPUT: RETVAL SV * _parse_mmap_file(SV * self, SV * file, SV * error_msg_ref) CODE: RETVAL = parse_mmap_file(self, file, error_msg_ref); OUTPUT: RETVAL SV * _check_scalar(SV *, SV * the_scalar) CODE: fprintf(stderr, "SV * at addr %p\n", the_scalar); sv_dump(the_scalar); if (SvROK(the_scalar)) { printf("\ndereferenced:\n"); fprintf(stderr, "SV * at addr %p\n", SvRV(the_scalar)); sv_dump(SvRV(the_scalar)); } RETVAL = &PL_sv_yes; OUTPUT: RETVAL JSON-DWIW-0.18/INSTALL0000644000076500007650000000024610567102717012160 0ustar dondonCopyright (c) 2007 Don Owens See the COPYRIGHT section in DWIW.pm for usage and distribution rights. INSTALLATION perl Makefile.PL make make test make install JSON-DWIW-0.18/lib/0000755000076500007650000000000010706025213011661 5ustar dondonJSON-DWIW-0.18/lib/JSON/0000755000076500007650000000000010706025213012432 5ustar dondonJSON-DWIW-0.18/lib/JSON/DWIW/0000755000076500007650000000000010706025213013204 5ustar dondonJSON-DWIW-0.18/lib/JSON/DWIW/Boolean.pm0000644000076500007650000000635210670146604015137 0ustar dondon# Creation date: 2007-05-10 20:29:02 # Authors: don # # Copyright (c) 2007 Don Owens . All rights reserved. # # This is free software; you can redistribute it and/or modify it under # the Perl Artistic license. You should have received a copy of the # Artistic license with this distribution, in the file named # "Artistic". You may also obtain a copy from # http://regexguy.com/license/Artistic # # This program is distributed in the hope that it will be # useful, but WITHOUT ANY WARRANTY; without even the implied # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. =pod =head1 NAME JSON::DWIW::Boolean - Return a true or false value when evaluated in boolean context -- to be used with JSON::DWIW->encode() to explicitly specify a boolean value.` =head1 SYNOPSIS use JSON::DWIW; my $val1 = JSON::DWIW->true; my $val2 = JSON::DWIW->false; or use JSON::DWIW::Boolean; my $val1 = JSON::DWIW::Boolean->new(1); # true value my $val2 = JSON::DWIW::Boolean->new(0); # false value =head1 DESCRIPTION This module is not intended to be used directly. It is intended to be used as part of JSON::DWIW to specify that a true or false value should be output when converting to JSON, since Perl does not have explicit values for true and false. Overloading is used, so if a JSON::DWIW::Boolean object is evaluated in boolean context, it will evaluate to 1 or 0, depending on whether the object was initialized to true or false. =cut use strict; use warnings; use 5.006_00; package JSON::DWIW::Boolean; use overload bool => sub { my $self = shift; my $val = $$self; return $val ? 1 : 0; }, '0+' => sub { my $self = shift; my $val = $$self; return $val ? 1 : 0; }; our $VERSION = sprintf("%d.%02d",(q$Revision: 1.4 $ =~ /\d+/g)); =pod =head1 METHODS =head2 new($val) Return an object initialized with $val as its boolean value. =cut sub new { my $proto = shift; my $val = shift; my $obj = $val; my $self = bless \$obj, ref($proto) || $proto; return $self; } =pod =head2 true() Class method that returns a new object initialized to a true value. =cut sub true { my $proto = shift; return $proto->new(1); } =pod =head2 false() Class method that returns a new object initialized to a false value. =cut sub false { my $proto = shift; return $proto->new(0); } sub as_bool { my $self = shift; my $val = $$self; if ($val) { return 1; } return; } =pod =head1 EXAMPLES =head1 DEPENDENCIES =head1 AUTHOR Don Owens =head1 LICENSE AND COPYRIGHT Copyright (c) 2007 Don Owens . All rights reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =head1 SEE ALSO =head1 VERSION 0.01 =cut 1; # Local Variables: # # mode: perl # # tab-width: 4 # # indent-tabs-mode: nil # # cperl-indent-level: 4 # # perl-indent-level: 4 # # End: # # vim:set ai si et sta ts=4 sw=4 sts=4: JSON-DWIW-0.18/lib/JSON/DWIW.pm0000644000076500007650000005010110706025010013532 0ustar dondon# Creation date: 2007-02-19 16:54:44 # Authors: don # # Copyright (c) 2007 Don Owens . All rights reserved. # # This is free software; you can redistribute it and/or modify it under # the Perl Artistic license. You should have received a copy of the # Artistic license with this distribution, in the file named # "Artistic". You may also obtain a copy from # http://regexguy.com/license/Artistic # # This program is distributed in the hope that it will be # useful, but WITHOUT ANY WARRANTY; without even the implied # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. =pod =head1 NAME JSON::DWIW - JSON converter that Does What I Want =head1 SYNOPSIS use JSON::DWIW; my $json_obj = JSON::DWIW->new; my $data = $json_obj->from_json($json_str); my $str = $json_obj->to_json($data); my $error_string = $json_obj->get_error_string; my $error_data = $json_obj->get_error_data; my $stats = $json_obj->get_stats; my $data = $json_obj->from_json_file($file) my $ok = $json_obj->to_json_file($data, $file); my $data = JSON::DWIW->from_json($json_str); my $str = JSON:DWIW->to_json($data); my $data = JSON::DWIW->from_json($json_str, \%options); my $str = JSON::DWIW->to_json($data, \%options); my $true_value = JSON::DWIW->true; my $false_value = JSON::DWIW->false; my $data = { var1 => "stuff", var2 => $true_value, var3 => $false_value, }; my $str = JSON::DWIW->to_json($data); use JSON::DWIW qw(:all); my $data = from_json($json_str); my $str = to_json($data); =head1 DESCRIPTION Other JSON modules require setting several parameters before calling the conversion methods to do what I want. This module does things by default that I think should be done when working with JSON in Perl. This module also encodes and decodes faster than JSON.pm and JSON::Syck in my benchmarks. This means that any piece of data in Perl (assuming it's valid unicode) will get converted to something in JSON instead of throwing an exception. It also means that output will be strict JSON, while accepted input will be flexible, without having to set any options. =head2 Encoding Perl objects get encoded as their underlying data structure, with the exception of Math::BigInt and Math::BigFloat, which will be output as numbers, and JSON::DWIW::Boolean, which will get output as a true or false value (see the true() and false() methods). For example, a blessed hash ref will be represented as an object in JSON, a blessed array will be represented as an array. etc. A reference to a scalar is dereferenced and represented as the scalar itself. Globs, Code refs, etc., get stringified, and undef becomes null. Scalars that have been used as both a string and a number will be output as a string. A reference to a reference is currently output as an empty string, but this may change. =head2 Decoding When decoding, null, true, and false become undef, 1, and 0, repectively. Numbers that appear to be too long to be supported natively are converted to Math::BigInt or Math::BigFloat objects, if you have them installed. Otherwise, long numbers are turned into strings to prevent data loss. The parser is flexible in what it accepts and handles some things not in the JSON spec: =over 4 =item quotes Both single and double quotes are allowed for quoting a string, e.g., [ "string1", 'string2' ] =item bare keys Object/hash keys can be bare if they look like an identifier, e.g., { var1: "myval1", var2: "myval2" } =item extra commas Extra commas in objects/hashes and arrays are ignored, e.g., [1,2,3,,,4,] becomes a 4 element array containing 1, 2, 3, and 4. =back =cut use strict; use warnings; use 5.006_00; use JSON::DWIW::Boolean; package JSON::DWIW; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); require Exporter; require DynaLoader; @ISA = qw(DynaLoader); @EXPORT = ( ); @EXPORT_OK = (); %EXPORT_TAGS = (all => [ 'to_json', 'from_json' ]); Exporter::export_ok_tags('all'); # change in POD as well! our $VERSION = '0.18'; { package JSON::DWIW::Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); @ISA = qw(Exporter); *EXPORT = \@JSON::DWIW::EXPORT; *EXPORT_OK = \@JSON::DWIW::EXPORT_OK; *EXPORT_TAGS = \%JSON::DWIW::EXPORT_TAGS; sub import { JSON::DWIW::Exporter->export_to_level(2, @_); } sub to_json { return JSON::DWIW->to_json(@_); } sub from_json { return JSON::DWIW->from_json(@_); } } sub import { JSON::DWIW::Exporter::import(@_); } JSON::DWIW->bootstrap($VERSION); { # workaround for weird importing bug on some installations local($SIG{__DIE__}); eval qq{ use Math::BigInt; use Math::BigFloat; }; } =pod =head1 METHODS =head2 new(\%options) Create a new JSON::DWIW object. %options is an optional hash of parameters that will change the bahavior of this module when encoding to JSON. You may also pass these options as the second argument to to_json() and from_json(). The following options are supported: =head3 bare_keys If set to a true value, keys in hashes will not be quoted when converted to JSON if they look like identifiers. This is valid Javascript in current browsers, but not in JSON. =head3 use_exceptions If set to a true value, errors found when converting to or from JSON will result in die() being called with the error message. The default is to not use exceptions. =head3 bad_char_policy This options indicates what should be done if bad characters are found, e.g., bad utf-8 sequence. The default is to return an error and drop all the output. The following values for bad_char_policy are supported: =head4 error default action, i.e., drop any output built up and return an error =head4 convert Convert to a utf-8 char using the value of the byte as a code point. This is basically the same as assuming the bad character is in latin-1 and converting it to utf-8. =head4 pass_through Ignore the error and pass through the raw bytes (invalid JSON) =head3 escape_multi_byte If set to a true value, escape all multi-byte characters (e.g., \u00e9) when converting to JSON. =head3 pretty Add white space to the output when calling to_json() to make the output easier for humans to read. =head3 convert_bool When converting from JSON, return objects for booleans so that "true" and "false" can be maintained when encoding and decoding. If this flag is set, then "true" becomes a JSON::DWIW::Boolean object that evaluates to true in a boolean context, and "false" becomes an object that evaluates to false in a boolean context. These objects are recognized by the to_json() method, so they will be output as "true" or "false" instead of "1" or "0". =cut sub new { my $proto = shift; my $self = bless {}, ref($proto) || $proto; my $params = shift; return $self unless $params; unless (defined($params) and UNIVERSAL::isa($params, 'HASH')) { return $self; } foreach my $field (qw/bare_keys use_exceptions bad_char_policy dump_vars pretty escape_multi_byte convert_bool/) { if (exists($params->{$field})) { $self->{$field} = $params->{$field}; } } return $self; } =pod =head2 to_json Returns the JSON representation of $data (arbitrary datastructure). See http://www.json.org/ for details. Called in list context, this method returns a list whose first element is the encoded JSON string and the second element is an error message, if any. If $error_msg is defined, there was a problem converting to JSON. You may also pass a second argument to to_json() that is a reference to a hash of options -- see new(). my $json_str = JSON::DWIW->to_json($data); my ($json_str, $error_msg) = JSON::DWIW->to_json($data); my $json_str = JSON::DWIW->to_json($data, { use_exceptions => 1 }); Aliases: toJson, toJSON, objToJson =cut sub to_json { my $proto = shift; my $data; my $self; if (UNIVERSAL::isa($proto, 'JSON::DWIW')) { $data = shift; my $options = shift; if ($options) { if (ref($proto) and $proto->isa('HASH')) { if (UNIVERSAL::isa($options, 'HASH')) { $options = { %$proto, %$options }; } } $self = $proto->new($options, @_); } else { $self = ref($proto) ? $proto : $proto->new(@_); } } else { $data = $proto; $self = JSON::DWIW->new(@_); } my $error_msg; my $error_data; my $stats_data = { }; my $str = _xs_to_json($self, $data, \$error_msg, \$error_data, $stats_data); if ($stats_data) { $JSON::DWIW::Last_Stats = $stats_data; $self->{last_stats} = $stats_data; } $JSON::DWIW::LastError = $error_msg; $self->{last_error} = $error_msg; $JSON::DWIW::LastErrorData = $error_data; $self->{last_error_data} = $error_data; if (defined($error_msg) and $self->{use_exceptions}) { die $error_msg; } return wantarray ? ($str, $error_msg) : $str; } { no warnings 'once'; *toJson = \&to_json; *toJSON = \&to_json; *objToJson = \&to_json; } =pod =head2 from_json Returns the Perl data structure for the given JSON string. The value for true becomes 1, false becomes 0, and null gets converted to undef. Called in list context, this method returns a list whose first element is the data and the second element is the error message, if any. If $error_msg is defined, there was a problem parsing the JSON string, and $data will be undef. You may also pass a second argument to from_json() that is a reference to a hash of options -- see new(). my $data = from_json($json_str) my ($data, $error_msg) = from_json($json_str) my $data = from_json($json_str, { use_exceptions => 1 }) Aliases: fromJson, fromJSON, jsonToObj =cut sub from_json { my $proto = shift; my $json; my $self; if (UNIVERSAL::isa($proto, 'JSON::DWIW')) { $json = shift; my $options = shift; if ($options) { if (ref($proto) and $proto->isa('HASH')) { if (UNIVERSAL::isa($options, 'HASH')) { $options = { %$proto, %$options }; } } $self = $proto->new($options, @_); } else { $self = ref($proto) ? $proto : $proto->new(@_); } } else { $json = $proto; $self = JSON::DWIW->new(@_); } my $error_msg; my $error_data; my $stats_data = { }; my $data = _xs_from_json($self, $json, \$error_msg, \$error_data, $stats_data); if ($stats_data) { $JSON::DWIW::Last_Stats = $stats_data; $self->{last_stats} = $stats_data; } $JSON::DWIW::LastError = $error_msg; $self->{last_error} = $error_msg; $JSON::DWIW::LastErrorData = $error_data; $self->{last_error_data} = $error_data; if (defined($error_msg) and $self->{use_exceptions}) { die $error_msg; } return wantarray ? ($data, $error_msg) : $data; } { no warnings 'once'; *jsonToObj = \&from_json; *fromJson = \&from_json; *fromJSON = \&from_json; } =pod =head2 from_json_file Returns the Perl data structure for the JSON object in the given file. Currently, this method slurps in the whole file, then parses it. my ($data, $error_msg) = $json->from_json_file($file, \%options) =cut sub from_json_file { my $proto = shift; my $file; my $self; if (UNIVERSAL::isa($proto, 'JSON::DWIW')) { $file = shift; my $options = shift; if ($options) { if (ref($proto) and $proto->isa('HASH')) { if (UNIVERSAL::isa($options, 'HASH')) { $options = { %$proto, %$options }; } } $self = $proto->new($options, @_); } else { $self = ref($proto) ? $proto : $proto->new(@_); } } else { $file = $proto; $self = JSON::DWIW->new(@_); } my $in_fh; unless (open($in_fh, '<', $file)) { my $msg = "JSON::DWIW v$VERSION - couldn't open input file $file"; $JSON::DWIW::LastError = $msg; $self->{last_error} = $msg; if ($self->{use_exceptions}) { die $msg; } else { return wantarray ? ( undef, $msg ) : undef; } } my $json; { local($/); $json = <$in_fh>; } close $in_fh; my $error_msg; my $error_data; my $stats_data = { }; my $data = _xs_from_json($self, $json, \$error_msg, \$error_data, $stats_data); if ($stats_data) { $JSON::DWIW::Last_Stats = $stats_data; $self->{last_stats} = $stats_data; } $JSON::DWIW::LastError = $error_msg; $self->{last_error} = $error_msg; $JSON::DWIW::LastErrorData = $error_data; $self->{last_error_data} = $error_data; if (defined($error_msg) and $self->{use_exceptions}) { die $error_msg; } return wantarray ? ($data, $error_msg) : $data; } =pod =head2 to_json_file Converts $data to JSON and writes the result to the file $file. Currently, this is simply a convenience routine that converts the data to a JSON string and then writes it to the file. my ($ok, $error) = $json->to_json_file($data, $file, \%options); =cut sub to_json_file { my $proto = shift; my $file; my $data; my $self; if (UNIVERSAL::isa($proto, 'JSON::DWIW')) { $data = shift; $file = shift; my $options = shift; if ($options) { if (ref($proto) and $proto->isa('HASH')) { if (UNIVERSAL::isa($options, 'HASH')) { $options = { %$proto, %$options }; } } $self = $proto->new($options, @_); } else { $self = ref($proto) ? $proto : $proto->new(@_); } } else { $data = $proto; $file = shift; $self = JSON::DWIW->new(@_); } my $out_fh; unless (open($out_fh, '>', $file)) { my $msg = "JSON::DWIW v$VERSION - couldn't open output file $file"; if ($self->{use_exceptions}) { die $msg; } else { return wantarray ? ( undef, $msg ) : undef; } } my $error_msg; my $error_data; my $stats_data = { }; my $str = _xs_to_json($self, $data, \$error_msg, \$error_data, $stats_data); if ($stats_data) { $JSON::DWIW::Last_Stats = $stats_data; $self->{last_stats} = $stats_data; } $JSON::DWIW::LastError = $error_msg; $self->{last_error} = $error_msg; $JSON::DWIW::LastErrorData = $error_data; $self->{last_error_data} = $error_data; if (defined($error_msg) and $self->{use_exceptions}) { die $error_msg; } if ($error_msg) { return wantarray ? (undef, $error_msg) : undef; } print $out_fh $str; close $out_fh; # if (_has_mmap()) { # print "*** has mmap\n"; # } return wantarray ? (1, $error_msg) : 1; } sub parse_mmap_file { my $proto = shift; my $file = shift; my $error_msg; my $self = $proto->new; my $data = _parse_mmap_file($self, $file, \$error_msg); if ($error_msg) { return wantarray ? (undef, $error_msg) : undef; } } =pod =head2 get_error_string Returns the error message from the last call, if there was one, e.g., my $data = JSON::DWIW->from_json($json_str) or die "JSON error: " . JSON::DWIW->get_error_string; my $data = $json_obj->from_json($json_str) or die "JSON error: " . $json_obj->get_error_string; Aliases: get_err_str(), errstr() =cut sub get_error_string { my $self = shift; if (ref($self)) { return $self->{last_error}; } return $JSON::DWIW::LastError; } *get_err_str = \&get_error_string; *errstr = \&get_error_string; =pod =head2 get_error_data Returns the error details from the last call, in a hash ref, e.g., $error_data = { 'byte' => 23, 'byte_col' => 23, 'col' => 22, 'char' => 22, 'version' => '0.15a', 'line' => 1 }; This is really only useful when decoding JSON. Aliases: get_error(), error() =cut sub get_error_data { my $self = shift; if (ref($self)) { return $self->{last_error_data}; } return $JSON::DWIW::LastErrorData; } *get_error = \&get_error_data; *error = \&get_error_data; =pod =head2 get_stats Returns statistics from the last method called to encode or decode. E.g., for an encoding (to_json() or to_json_file()), $stats = { 'bytes' => 78, 'nulls' => 1, 'max_string_bytes' => 5, 'max_depth' => 2, 'arrays' => 1, 'numbers' => 6, 'lines' => 1, 'max_string_chars' => 5, 'strings' => 6, 'bools' => 1, 'chars' => 78, 'hashes' => 1 }; =cut sub get_stats { my $self = shift; if (ref($self)) { return $self->{last_stats}; } return $JSON::DWIW::Last_Stats; } *stats = \&get_stats; =pod =head2 true Returns an object that will get output as a true value when encoding to JSON. =cut sub true { return JSON::DWIW::Boolean->true; } =pod =head2 false Returns an object that will get output as a false value when encoding to JSON. =cut sub false { return JSON::DWIW::Boolean->false; } =pod =head1 BENCHMARKS Latest benchmarks against JSON and JSON::Syck run on my MacBook Pro: Using a small data set: Encode (50000 iterations): ========================== Rate JSON JSON::Syck JSON::DWIW JSON 2648/s -- -72% -86% JSON::Syck 9416/s 256% -- -51% JSON::DWIW 19380/s 632% 106% -- Decode (50000 iterations): ========================== Rate JSON JSON::Syck JSON::DWIW JSON 2288/s -- -81% -93% JSON::Syck 12195/s 433% -- -60% JSON::DWIW 30675/s 1240% 152% -- Using a larger data set (8KB JSON string) generated from Yahoo! Local's search API (http://nanoref.com/yahooapis/mgPdGg) Encode (1000 iterations): ========================= Rate JSON JSON::Syck JSON::DWIW JSON 133/s -- -54% -66% JSON::Syck 289/s 118% -- -26% JSON::DWIW 389/s 193% 35% -- Decode (1000 iterations): ========================= Rate JSON JSON::Syck JSON::DWIW JSON 35.5/s -- -92% -94% JSON::Syck 427/s 1103% -- -25% JSON::DWIW 571/s 1508% 34% -- =head1 DEPENDENCIES Perl 5.6 or later =head1 BUGS/LIMITATIONS If you find a bug, please file a tracker request at . When decoding a JSON string, it is a assumed to be utf-8 encoded. The module should detect whether the input is utf-8, utf-16, or utf-32. =head1 AUTHOR Don Owens =head1 ACKNOWLEDGEMENTS Thanks to Asher Blum for help with testing. Thanks to Nigel Bowden for helping with compilation on Windows. =head1 LICENSE AND COPYRIGHT Copyright (c) 2007 Don Owens . All rights reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =head1 SEE ALSO The JSON home page: L The JSON spec: L The JSON-RPC spec: L L L (included in L) =head1 VERSION 0.18 =cut 1; # Local Variables: # # mode: perl # # tab-width: 4 # # indent-tabs-mode: nil # # cperl-indent-level: 4 # # perl-indent-level: 4 # # End: # # vim:set ai si et sta ts=4 sw=4 sts=4: JSON-DWIW-0.18/Makefile.PL0000755000076500007650000000212210706024362013071 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-02-19 16:49:01 # Authors: don use strict; use Carp; # main { local($SIG{__DIE__}) = sub { &Carp::confess }; use 5.006_00; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'JSON::DWIW', DISTNAME => 'JSON-DWIW', VERSION_FROM => 'lib/JSON/DWIW.pm', ABSTRACT => 'JSON converter that does what I want', AUTHOR => 'DON OWENS ', PM => { 'lib/JSON/DWIW.pm' => '$(INST_LIBDIR)/DWIW.pm', 'lib/JSON/DWIW/Boolean.pm' => '$(INST_LIBDIR)/DWIW/Boolean.pm', }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, DIR => [], EXE_FILES => [], PREREQ_PM => { }, # OPTIMIZE => '-Wall -O3 -fno-non-lvalue-assign', ); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/META.yml0000644000076500007650000000060510706025213012365 0ustar dondon--- #YAML:1.0 name: JSON-DWIW version: 0.18 abstract: JSON converter that does what I want license: ~ generated_by: ExtUtils::MakeMaker version 6.36 distribution_type: module requires: meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 author: - DON OWENS JSON-DWIW-0.18/README0000644000076500007650000002646710706025210012007 0ustar dondonNAME JSON::DWIW - JSON converter that Does What I Want SYNOPSIS use JSON::DWIW; my $json_obj = JSON::DWIW->new; my $data = $json_obj->from_json($json_str); my $str = $json_obj->to_json($data); my $error_string = $json_obj->get_error_string; my $error_data = $json_obj->get_error_data; my $stats = $json_obj->get_stats; my $data = $json_obj->from_json_file($file) my $ok = $json_obj->to_json_file($data, $file); my $data = JSON::DWIW->from_json($json_str); my $str = JSON:DWIW->to_json($data); my $data = JSON::DWIW->from_json($json_str, \%options); my $str = JSON::DWIW->to_json($data, \%options); my $true_value = JSON::DWIW->true; my $false_value = JSON::DWIW->false; my $data = { var1 => "stuff", var2 => $true_value, var3 => $false_value, }; my $str = JSON::DWIW->to_json($data); use JSON::DWIW qw(:all); my $data = from_json($json_str); my $str = to_json($data); DESCRIPTION Other JSON modules require setting several parameters before calling the conversion methods to do what I want. This module does things by default that I think should be done when working with JSON in Perl. This module also encodes and decodes faster than JSON.pm and JSON::Syck in my benchmarks. This means that any piece of data in Perl (assuming it's valid unicode) will get converted to something in JSON instead of throwing an exception. It also means that output will be strict JSON, while accepted input will be flexible, without having to set any options. Encoding Perl objects get encoded as their underlying data structure, with the exception of Math::BigInt and Math::BigFloat, which will be output as numbers, and JSON::DWIW::Boolean, which will get output as a true or false value (see the true() and false() methods). For example, a blessed hash ref will be represented as an object in JSON, a blessed array will be represented as an array. etc. A reference to a scalar is dereferenced and represented as the scalar itself. Globs, Code refs, etc., get stringified, and undef becomes null. Scalars that have been used as both a string and a number will be output as a string. A reference to a reference is currently output as an empty string, but this may change. Decoding When decoding, null, true, and false become undef, 1, and 0, repectively. Numbers that appear to be too long to be supported natively are converted to Math::BigInt or Math::BigFloat objects, if you have them installed. Otherwise, long numbers are turned into strings to prevent data loss. The parser is flexible in what it accepts and handles some things not in the JSON spec: quotes Both single and double quotes are allowed for quoting a string, e.g., [ "string1", 'string2' ] bare keys Object/hash keys can be bare if they look like an identifier, e.g., { var1: "myval1", var2: "myval2" } extra commas Extra commas in objects/hashes and arrays are ignored, e.g., [1,2,3,,,4,] becomes a 4 element array containing 1, 2, 3, and 4. METHODS new(\%options) Create a new JSON::DWIW object. %options is an optional hash of parameters that will change the bahavior of this module when encoding to JSON. You may also pass these options as the second argument to to_json() and from_json(). The following options are supported: bare_keys If set to a true value, keys in hashes will not be quoted when converted to JSON if they look like identifiers. This is valid Javascript in current browsers, but not in JSON. use_exceptions If set to a true value, errors found when converting to or from JSON will result in die() being called with the error message. The default is to not use exceptions. bad_char_policy This options indicates what should be done if bad characters are found, e.g., bad utf-8 sequence. The default is to return an error and drop all the output. The following values for bad_char_policy are supported: error default action, i.e., drop any output built up and return an error convert Convert to a utf-8 char using the value of the byte as a code point. This is basically the same as assuming the bad character is in latin-1 and converting it to utf-8. pass_through Ignore the error and pass through the raw bytes (invalid JSON) escape_multi_byte If set to a true value, escape all multi-byte characters (e.g., \u00e9) when converting to JSON. pretty Add white space to the output when calling to_json() to make the output easier for humans to read. convert_bool When converting from JSON, return objects for booleans so that "true" and "false" can be maintained when encoding and decoding. If this flag is set, then "true" becomes a JSON::DWIW::Boolean object that evaluates to true in a boolean context, and "false" becomes an object that evaluates to false in a boolean context. These objects are recognized by the to_json() method, so they will be output as "true" or "false" instead of "1" or "0". to_json Returns the JSON representation of $data (arbitrary datastructure). See http://www.json.org/ for details. Called in list context, this method returns a list whose first element is the encoded JSON string and the second element is an error message, if any. If $error_msg is defined, there was a problem converting to JSON. You may also pass a second argument to to_json() that is a reference to a hash of options -- see new(). my $json_str = JSON::DWIW->to_json($data); my ($json_str, $error_msg) = JSON::DWIW->to_json($data); my $json_str = JSON::DWIW->to_json($data, { use_exceptions => 1 }); Aliases: toJson, toJSON, objToJson from_json Returns the Perl data structure for the given JSON string. The value for true becomes 1, false becomes 0, and null gets converted to undef. Called in list context, this method returns a list whose first element is the data and the second element is the error message, if any. If $error_msg is defined, there was a problem parsing the JSON string, and $data will be undef. You may also pass a second argument to from_json() that is a reference to a hash of options -- see new(). my $data = from_json($json_str) my ($data, $error_msg) = from_json($json_str) my $data = from_json($json_str, { use_exceptions => 1 }) Aliases: fromJson, fromJSON, jsonToObj from_json_file Returns the Perl data structure for the JSON object in the given file. Currently, this method slurps in the whole file, then parses it. my ($data, $error_msg) = $json->from_json_file($file, \%options) to_json_file Converts $data to JSON and writes the result to the file $file. Currently, this is simply a convenience routine that converts the data to a JSON string and then writes it to the file. my ($ok, $error) = $json->to_json_file($data, $file, \%options); get_error_string Returns the error message from the last call, if there was one, e.g., my $data = JSON::DWIW->from_json($json_str) or die "JSON error: " . JSON::DWIW->get_error_string; my $data = $json_obj->from_json($json_str) or die "JSON error: " . $json_obj->get_error_string; Aliases: get_err_str(), errstr() get_error_data Returns the error details from the last call, in a hash ref, e.g., $error_data = { 'byte' => 23, 'byte_col' => 23, 'col' => 22, 'char' => 22, 'version' => '0.15a', 'line' => 1 }; This is really only useful when decoding JSON. Aliases: get_error(), error() get_stats Returns statistics from the last method called to encode or decode. E.g., for an encoding (to_json() or to_json_file()), $stats = { 'bytes' => 78, 'nulls' => 1, 'max_string_bytes' => 5, 'max_depth' => 2, 'arrays' => 1, 'numbers' => 6, 'lines' => 1, 'max_string_chars' => 5, 'strings' => 6, 'bools' => 1, 'chars' => 78, 'hashes' => 1 }; true Returns an object that will get output as a true value when encoding to JSON. false Returns an object that will get output as a false value when encoding to JSON. BENCHMARKS Latest benchmarks against JSON and JSON::Syck run on my MacBook Pro: Using a small data set: Encode (50000 iterations): ========================== Rate JSON JSON::Syck JSON::DWIW JSON 2648/s -- -72% -86% JSON::Syck 9416/s 256% -- -51% JSON::DWIW 19380/s 632% 106% -- Decode (50000 iterations): ========================== Rate JSON JSON::Syck JSON::DWIW JSON 2288/s -- -81% -93% JSON::Syck 12195/s 433% -- -60% JSON::DWIW 30675/s 1240% 152% -- Using a larger data set (8KB JSON string) generated from Yahoo! Local's search API (http://nanoref.com/yahooapis/mgPdGg) Encode (1000 iterations): ========================= Rate JSON JSON::Syck JSON::DWIW JSON 133/s -- -54% -66% JSON::Syck 289/s 118% -- -26% JSON::DWIW 389/s 193% 35% -- Decode (1000 iterations): ========================= Rate JSON JSON::Syck JSON::DWIW JSON 35.5/s -- -92% -94% JSON::Syck 427/s 1103% -- -25% JSON::DWIW 571/s 1508% 34% -- DEPENDENCIES Perl 5.6 or later BUGS/LIMITATIONS If you find a bug, please file a tracker request at . When decoding a JSON string, it is a assumed to be utf-8 encoded. The module should detect whether the input is utf-8, utf-16, or utf-32. AUTHOR Don Owens ACKNOWLEDGEMENTS Thanks to Asher Blum for help with testing. Thanks to Nigel Bowden for helping with compilation on Windows. LICENSE AND COPYRIGHT Copyright (c) 2007 Don Owens . All rights reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See perlartistic. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. SEE ALSO The JSON home page: L The JSON spec: L The JSON-RPC spec: L L L (included in L) VERSION 0.18 JSON-DWIW-0.18/t/0000755000076500007650000000000010706025213011356 5ustar dondonJSON-DWIW-0.18/t/00use.t0000755000076500007650000000043410567102717012515 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-02-20 19:48:50 # Authors: don # main { use strict; use Test; BEGIN { plan tests => 1 } use JSON::DWIW; ok(1); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/01encode.t0000755000076500007650000000624310670143415013156 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-02-20 19:51:06 # Authors: don use strict; use Test; # main { BEGIN { plan tests => 14 } use JSON::DWIW; my $data; # my $expected_str = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var3":"val3"}'; my $expected_str1 = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}]}'; my $expected_str2 = '{"var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var1":"val1"}'; my $expected_str3 = '{"var2":["first_element",{"sub_element2":"sub_val2","sub_element":"sub_val"}],"var1":"val1"}'; my $expected_str4 = '{"var1":"val1","var2":["first_element",{"sub_element2":"sub_val2","sub_element":"sub_val"}]}'; my $json_obj = JSON::DWIW->new; my $json_str; # print STDERR "\n" . $json_str . "\n\n"; my $expected_str; $data = 'stuff'; $json_str = $json_obj->to_json($data); ok($json_str eq '"stuff"'); $data = "stu\nff"; $json_str = $json_obj->to_json($data); ok($json_str eq '"stu\nff"'); $data = [ 1, 2, 3 ]; $expected_str = '[1,2,3]'; $json_str = $json_obj->to_json($data); ok($json_str eq $expected_str); $data = { var1 => 'val1', var2 => 'val2' }; $json_str = $json_obj->to_json($data); ok($json_str eq '{"var1":"val1","var2":"val2"}' or $json_str eq '{"var2":"val2","var1":"val1"}'); $data = { var1 => 'val1', var2 => [ 'first_element', { sub_element => 'sub_val', sub_element2 => 'sub_val2' }, ], # var3 => 'val3', }; $json_str = $json_obj->to_json($data); ok($json_str eq $expected_str1 or $json_str eq $expected_str2 or $json_str eq $expected_str3 or $json_str eq $expected_str4); $data = ''; $json_str = $json_obj->to_json($data); ok($json_str eq '""'); $data = { str => '' }; $json_str = $json_obj->to_json($data); ok($json_str eq '{"str":""}'); $data = [ "1", "" ]; $json_str = $json_obj->to_json($data); ok($json_str eq '["1",""]'); $data = undef; $json_str = $json_obj->to_json($data); ok($json_str eq 'null'); $data = [undef]; $json_str = $json_obj->to_json($data); ok($json_str eq '[null]'); $data = { var => undef }; $json_str = $json_obj->to_json($data); ok($json_str eq '{"var":null}'); $data = { body => 'foo blarg adfasdf', }; $json_str = $json_obj->to_json($data); ok($json_str eq '{"body":"foo blarg adfasdf<\/a>"}'); $data = { stuff => "Don's test string" }; $json_str = $json_obj->to_json($data); ok($json_str eq q{{"stuff":"Don's test string"}}); $data = { stuff => "http://example.com/" }; $json_str = $json_obj->to_json($data); $json_str = $json_obj->to_json({ test => $json_str }); ok($json_str eq '{"test":"{\\"stuff\\":\\"http:\\\\\\/\\\\\\/example.com\\\\\\/\\"}"}'); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/02decode.t0000755000076500007650000000666310600115126013142 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-02-20 21:54:09 # Authors: don use strict; use warnings; use Test; # main { BEGIN { plan tests => 13 } use JSON::DWIW; my $json_str = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var3":"val3"}'; my $json_obj = JSON::DWIW->new; my $data = $json_obj->from_json($json_str); # complex value my $pass = 1; if ($data->{var1} eq 'val1' and $data->{var3} eq 'val3') { if ($data->{var2}) { my $array = $data->{var2}; if (ref($array) eq 'ARRAY') { if ($array->[0] eq 'first_element') { my $hash = $array->[1]; if (ref($hash) eq 'HASH') { unless ($hash->{sub_element} eq 'sub_val' and $hash->{sub_element2} eq 'sub_val2') { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } ok($pass); # string $json_str = '"val1"'; $data = $json_obj->from_json($json_str); ok($data eq 'val1'); # numbers $json_str = '567'; $data = $json_obj->from_json($json_str); ok($data == 567); $json_str = "5e1"; $data = $json_obj->from_json($json_str); ok($data == 50); $json_str = "5e3"; $data = $json_obj->from_json($json_str); ok($data == 5000); $json_str = "5e+1"; $data = $json_obj->from_json($json_str); ok($data == 50); $json_str = "5e-1"; $data = $json_obj->from_json($json_str); ok($data == 0.5); # empty array $json_str = '[]'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'ARRAY' and scalar(@$data) == 0); # empty hash $json_str = '{}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 0); # empty array as value in hash $json_str = '{"test_empty":[]}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 1 and ref($data->{test_empty}) eq 'ARRAY' and scalar(@{$data->{test_empty}}) == 0); # empty hash as value in a hash $json_str = '{"test_empty":{}}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 1 and ref($data->{test_empty}) eq 'HASH' and scalar(keys %{$data->{test_empty}}) == 0); $json_str = '{"test_empty_hash":{},"test_empty_array":[]}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 2 and ref($data->{test_empty_hash}) eq 'HASH' and scalar(keys %{$data->{test_empty_hash}}) == 0 and ref($data->{test_empty_array}) eq 'ARRAY' and scalar(@{$data->{test_empty_array}}) == 0 ); # comment $json_str = '{"test_empty_hash":{} /*,"test_empty_array":[] */}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 1 and ref($data->{test_empty_hash}) eq 'HASH' and scalar(keys %{$data->{test_empty_hash}}) == 0); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/03parse_constants.t0000755000076500007650000000114710600115247015122 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-03-20 18:01:54 # Authors: don use strict; use warnings; use Test; # main { BEGIN { plan tests => 4 } use JSON::DWIW; my $json_str = '{"var1":true,"var2":false,"var3":null}'; my $data = JSON::DWIW->from_json($json_str); ok(ref($data) eq 'HASH'); ok(ref($data) eq 'HASH' and $data->{var1}); ok(ref($data) eq 'HASH' and not $data->{var2}); ok(ref($data) eq 'HASH' and exists($data->{var3}) and not defined($data->{var3})); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/04extras.t0000755000076500007650000000642510630653450013235 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-03-20 18:01:54 # Authors: don use strict; use warnings; use Test; # main { BEGIN { plan tests => 22 } use JSON::DWIW; # bare keys (called as class method) my $json_str = '{var1:true,var2:false,var3:null}'; my $data = JSON::DWIW->from_json($json_str); ok(ref($data) eq 'HASH'); ok(ref($data) eq 'HASH' and $data->{var1}); ok(ref($data) eq 'HASH' and not $data->{var2}); ok(ref($data) eq 'HASH' and exists($data->{var3}) and not defined($data->{var3})); # call as subroutine (possible imported) $json_str = '{var1:true,var2:false,var3:null}'; $data = JSON::DWIW::from_json($json_str); ok(ref($data) eq 'HASH'); ok(ref($data) eq 'HASH' and $data->{var1}); ok(ref($data) eq 'HASH' and not $data->{var2}); ok(ref($data) eq 'HASH' and exists($data->{var3}) and not defined($data->{var3})); # call as instance method my $json_obj = JSON::DWIW->new; $json_str = '{var1:true,var2:false,var3:null}'; $data = $json_obj->from_json($json_str); ok(ref($data) eq 'HASH'); ok(ref($data) eq 'HASH' and $data->{var1}); ok(ref($data) eq 'HASH' and not $data->{var2}); ok(ref($data) eq 'HASH' and exists($data->{var3}) and not defined($data->{var3})); # extra commas $json_str = '{,"var1":true,,"var2":false,"var3":null,, ,}'; $data = JSON::DWIW->from_json($json_str); ok(ref($data) eq 'HASH'); ok(ref($data) eq 'HASH' and $data->{var1}); ok(ref($data) eq 'HASH' and not $data->{var2}); ok(ref($data) eq 'HASH' and exists($data->{var3}) and not defined($data->{var3})); # C++ style comments $json_str = '{"test_empty_hash":{} ' . "\n" . '//,"test_empty_array":[] ' . "\n" . '}'; $data = JSON::DWIW->from_json($json_str); ok(ref($data) eq 'HASH' and scalar(keys(%$data)) == 1 and ref($data->{test_empty_hash}) eq 'HASH' and scalar(keys %{$data->{test_empty_hash}}) == 0); # encoding bare keys $json_obj = JSON::DWIW->new({ bare_keys => 1 }); $data = { var1 => "val2" }; $json_str = $json_obj->to_json($data); ok($json_str eq '{var1:"val2"}'); $json_str = JSON::DWIW->to_json($data, { bare_keys => 1 }); ok($json_str eq '{var1:"val2"}'); $json_str = JSON::DWIW::to_json($data, { bare_keys => 1 }); ok($json_str eq '{var1:"val2"}'); $data = { var => "stuff\xe9stuff" }; undef $json_str; { local $SIG{__WARN__} = sub { }; $json_str = JSON::DWIW->to_json($data, { bad_char_policy => 'convert', escape_multi_byte => 1, }); } ok($json_str eq '{"var":"stuff\u00e9stuff"}'); # make sure no elements are left out when pretty-printing # (bug in version 0.12) $data = { var1 => 'val1', var2 => { stuff1 => 'content2', stuff2 => 1 }, var3 => 'val3', var4 => [ 'test1', 'test2', 'test3' ]}; $json_str = JSON::DWIW->to_json($data, { pretty => 1 }); $data = JSON::DWIW->from_json($json_str); ok(scalar(@{ $data->{var4} }) == 3 and $data->{var2}{stuff1} and $data->{var2}{stuff2} and scalar(keys(%$data)) == 4); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/05exceptions.t0000755000076500007650000000206410611313073014075 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-04-04 21:57:58 # Authors: don use strict; use Test; # main { BEGIN { plan tests => 4 }; use JSON::DWIW; my $converter = JSON::DWIW->new({ use_exceptions => 1 }); local $SIG{__DIE__}; my $bad_str = '{"stuff":}'; eval { my $data = $converter->from_json($bad_str); }; ok($@); eval { my $data = JSON::DWIW->from_json($bad_str, { use_exceptions => 1 }); }; ok($@); eval { my $data = JSON::DWIW::from_json($bad_str, { use_exceptions => 1 }); }; ok($@); my $bad_data = { stuff => "\xf5blah" }; { local $SIG{__WARN__} = sub { my $msg = shift; if ($msg =~ /malformed\s+utf-8/i) { # don't print the message return; } else { warn $msg; return; } }; eval { my $str = $converter->to_json($bad_data); }; } ok($@); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/06big_numbers.t0000755000076500007650000000405110606541466014224 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-04-07 17:08:45 # Authors: don use strict; use Test; # main { use JSON::DWIW; my $converter = JSON::DWIW->new; local $SIG{__DIE__}; my $have_big_int = JSON::DWIW->have_big_int; my $have_big_float = JSON::DWIW->have_big_float; my $num_tests = 1; if ($have_big_int) { $num_tests += 3; } else { $num_tests += 1; } if ($have_big_float) { $num_tests += 1; } else { $num_tests += 1; } plan tests => $num_tests; my $str = '{"stuff":42949672954294967295}'; my $data = $converter->from_json($str); ok($data->{stuff} =~ /\A\+?42949672954294967295\Z/); if ($have_big_int) { my $big_int = Math::BigInt->new('42949672954294967295'); $str = $converter->to_json($big_int); ok($str eq '42949672954294967295'); ok(($data->{stuff} + 500) . '' =~ /\A\+?42949672954294967795\Z/); $data = { stuff => Math::BigInt->new('340282366920938463463374607431768211456') }; # 2^128 $str = $converter->to_json($data); ok($str eq '{"stuff":340282366920938463463374607431768211456}'); } else { skip("don't have Math::BigInt", 0); } if ($have_big_float) { $data = { stuff => Math::BigFloat->new('115792089237316195423570985008687907853269984665640564039457584007913129639936') }; # 2^256 $str = $converter->to_json($data); ok($str eq '{"stuff":115792089237316195423570985008687907853269984665640564039457584007913129639936}'); # my $val = Math::BigFloat->new('2'); # $data = { stuff => $val ** 512 }; # $str = $converter->to_json($data); # ok($str eq '{"stuff":13407807929942597099574024998205846127479365820592393377723561443721764030073546976801874298166903427690031858186486050853753882811946569946433649006084096}'); } else { skip("don't have Math::BigFloat", 0); } } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/07magic.t0000755000076500007650000000577010606544265013022 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-04-08 20:50:44 # Authors: don use strict; use Test; # main { plan tests => 6; use JSON::DWIW; my $magic_scalar; tie $magic_scalar, 'DummyTiedScalar'; my %magic_hash; tie %magic_hash, 'DummyTiedHash'; my @magic_array; tie @magic_array, 'DummyTiedArray'; my $data; my $str; $str = JSON::DWIW->to_json($magic_scalar); ok($str eq '"fetched_val"'); $data = { var2 => $magic_scalar }; $str = JSON::DWIW->to_json($data); ok($str eq '{"var2":"fetched_val"}'); $str = JSON::DWIW->to_json(\%magic_hash); ok($str eq '{"var1":"val1"}'); $data = { magic_hash => \%magic_hash }; $str = JSON::DWIW->to_json($data); ok($str eq '{"magic_hash":{"var1":"val1"}}'); $str = JSON::DWIW->to_json(\@magic_array); ok($str eq '[1,2,3,4]' or $str eq '["1","2","3","4"]'); $data = { magic_array => \@magic_array }; $str = JSON::DWIW->to_json($data); ok($str eq '{"magic_array":[1,2,3,4]}' or $str eq '{"magic_array":["1","2","3","4"]}'); } exit 0; ############################################################################### # Subroutines { package DummyTiedScalar; sub new { my $proto = shift; my $scalar; return bless \$scalar, ref($proto) || $proto; } sub TIESCALAR { my $proto = shift; return $proto->new(@_); } sub FETCH { my $self = shift; return 'fetched_val'; } sub STORE { return; } } { package DummyTiedHash; sub new { my $proto = shift; return bless { data => { var1 => 'val1' } }, ref($proto) || $proto; } sub TIEHASH { my $proto = shift; return $proto->new(@_); } sub FETCH { my $self = shift; my $key = shift; return $self->{data}{$key}; } sub STORE { my ($self, $key, $value) = @_; $self->{data}{$key} = $value; return $value; } sub DELETE { my $self = shift; my $key = shift; delete $self->{data}{$key}; } sub FIRSTKEY { my $self = shift; my $a = keys %{$self->{data}}; return each %{$self->{data}}; } sub NEXTKEY { my $self = shift; my $last_key = shift; return each %{$self->{data}}; } } { package DummyTiedArray; sub new { my $proto = shift; return bless { data => [ 1, 2, 3, 4 ] }, ref($proto) || $proto; } sub TIEARRAY { my $proto = shift; return $proto->new(@_); } sub FETCH { my $self = shift; my $index = shift; return $self->{data}[$index]; } sub STORE { my ($self, $index, $value) = @_; $self->{data}[$index] = $value; } sub FETCHSIZE { my $self = shift; return scalar @{$self->{data}}; } sub STORESIZE { my $self = shift; my $count = shift; return $count; } sub UNTIE { } } JSON-DWIW-0.18/t/08pvxv.t0000755000076500007650000000154210611313073012722 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-04-17 20:39:26 # Authors: don # Test scalars that have types indicating they can be either a string or another type use strict; # main { use Test; plan tests => 3; use JSON::DWIW; # SVt_PVIV my $data = {}; $data->{test_var} = 0; $data->{test_var} = 'blah'; my $str = JSON::DWIW->to_json($data); ok($str eq '{"test_var":"blah"}'); my $data2 = {}; my $test_val = 0; $test_val = 'blah'; $data2->{test_var} = $test_val; $str = JSON::DWIW->to_json($data2); ok($str eq '{"test_var":"blah"}'); # SVt_PVNV $data2 = { test_var => 0.5 }; $data2->{test_var} = 'blah'; $str = JSON::DWIW->to_json($data2); ok($str eq '{"test_var":"blah"}'); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/09bool.t0000755000076500007650000000260610621667501012666 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-05-10 21:02:13 # Authors: don use strict; use Test; # main { plan tests => 8; use JSON::DWIW; my $data; my $str; $data = { var1 => JSON::DWIW::Boolean->true, }; $str = JSON::DWIW->to_json($data); ok($str eq '{"var1":true}'); $data = { var1 => JSON::DWIW::Boolean->false, }; $str = JSON::DWIW->to_json($data); ok($str eq '{"var1":false}'); $data = { var1 => JSON::DWIW->true, }; $str = JSON::DWIW->to_json($data); ok($str eq '{"var1":true}'); $data = { var1 => JSON::DWIW->false, }; $str = JSON::DWIW->to_json($data); ok($str eq '{"var1":false}'); my $json_obj = JSON::DWIW->new; $data = { var1 => JSON::DWIW::Boolean->true, }; $str = $json_obj->to_json($data); ok($str eq '{"var1":true}'); $data = { var1 => JSON::DWIW::Boolean->false, }; $str = $json_obj->to_json($data); ok($str eq '{"var1":false}'); $str = '{"var1":false}'; $data = JSON::DWIW->from_json($str, { convert_bool => 1 }); my $bool = $data->{var1}; ok(ref($bool) eq 'JSON::DWIW::Boolean' and not $bool); $str = '{"var1":true}'; $data = JSON::DWIW->from_json($str, { convert_bool => 1 }); $bool = $data->{var1}; ok(ref($bool) eq 'JSON::DWIW::Boolean' and $bool); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/10unicode.t0000755000076500007650000000174110677532363013360 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-05-11 07:43:10 # Authors: don use strict; use Test; # main { plan tests => 6; use JSON::DWIW; ok(JSON::DWIW->is_valid_utf8("\x{706b}")); ok(not JSON::DWIW->is_valid_utf8("\xe9s")); my $str = ""; ok(not JSON::DWIW->flagged_as_utf8($str)); JSON::DWIW->flag_as_utf8($str); ok(JSON::DWIW->flagged_as_utf8($str)); JSON::DWIW->unflag_as_utf8($str); ok(not JSON::DWIW->flagged_as_utf8($str)); # Test utf8 sequences in hash keys. In Perl 5.8, a utf8 key # that can be represented in latin1 will get converted to # latin1 at the C layer, breaking things if it is not checked # explicitly my $utf8_str = "\xc3\xa4"; JSON::DWIW->flag_as_utf8($str); my %hash; $hash{$utf8_str} = 'blah'; my ($json_str, $error) = JSON::DWIW->to_json(\%hash); ok(not $error); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/11parse_file.t0000755000076500007650000000530010704301514014016 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-09-12 19:27:49 # Authors: don use strict; use warnings; use Test; # main { plan tests => 24; use JSON::DWIW; my $json_obj = JSON::DWIW->new; my $data = $json_obj->from_json_file("t/parse_file/pass0.json"); ok($data and $data->{var1} eq 'val1'); $data = JSON::DWIW->from_json_file("t/parse_file/pass0.json"); ok($data and $data->{var1} eq 'val1'); my $error; ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/pass0.json"); ok(not $error and $data and $data->{var1} eq 'val1'); ($data, $error) = JSON::DWIW->from_json_file("t/non_existent_file.json"); ok($error and $error =~ /couldn't open input file/); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/pass1.json"); ok($data and not $error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/pass2.json"); ok($data and not $error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/pass3.json"); ok($data and not $error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail2.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail2.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail2.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail7.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail8.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail10.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail11.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail12.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail14.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail16.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail19.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail20.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail21.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail22.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail31.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail32.json"); ok($error); ($data, $error) = JSON::DWIW->from_json_file("t/parse_file/fail33.json"); ok($error); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/12error.t0000755000076500007650000000334010703041414013040 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-10-02 18:51:38 # Authors: don use strict; use warnings; # main { use Test; BEGIN { plan tests => 18; } use JSON::DWIW; my $json_obj = JSON::DWIW->new; my $str = qq{{"test":"\xc3\xa4","funky":"\\u70":"key":"val"}}; my ($data, $error) = JSON::DWIW->from_json($str); ok($error); ok(defined $error and $error =~ /bad unicode character specification/); ok(defined $error and $error =~ /char 26/); ok(defined $error and $error =~ /byte 27/); ok(defined $error and $error =~ /line 1/); ok(defined $error and $error =~ /, col 26/); ok(defined $error and $error =~ /byte col 27/); ok(defined JSON::DWIW->get_error_string); $str = qq{{"test":"\xc3\xa4",\n"funky":"\\u70":"key":"val"}}; ($data, $error) = JSON::DWIW->from_json($str); ok(defined $error and $error =~ /char 27/); ok(defined $error and $error =~ /byte 28/); ok(defined $error and $error =~ /line 2/); ok(defined $error and $error =~ /, col 14/); ok(defined $error and $error =~ /byte col 14/); $str = qq{{"test":"\xc3\xa4","test2":"}}; ($data, $error) = JSON::DWIW->from_json($str); ok(defined $error and $error =~ /unterminated string starting at byte 22/); ok(defined $error and $error =~ /char 22/); ok(defined $error and $error =~ /byte 23/); $str = qq|{"var1":1,"var2":"val2","var3":[1,2,3,4,5], "test":true, "check":null}\n{"var4":"val4"}|; ($data, $error) = JSON::DWIW->from_json($str); ok(defined $error); ($data, $error) = $json_obj->from_json($str); ok(defined $json_obj->get_error_string); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.18/t/parse_file/0000755000076500007650000000000010706025213013467 5ustar dondonJSON-DWIW-0.18/t/parse_file/fail10.json0000644000076500007650000000007210704277342015447 0ustar dondon{"Extra value after close": true} "misplaced quoted value"JSON-DWIW-0.18/t/parse_file/fail11.json0000644000076500007650000000003510704277342015447 0ustar dondon{"Illegal expression": 1 + 2}JSON-DWIW-0.18/t/parse_file/fail12.json0000644000076500007650000000003710704277342015452 0ustar dondon{"Illegal invocation": alert()}JSON-DWIW-0.18/t/parse_file/fail14.json0000644000076500007650000000003710704277342015454 0ustar dondon{"Numbers cannot be hex": 0x14}JSON-DWIW-0.18/t/parse_file/fail16.json0000644000076500007650000000001010704277342015445 0ustar dondon[\naked]JSON-DWIW-0.18/t/parse_file/fail19.json0000644000076500007650000000002610704277342015457 0ustar dondon{"Missing colon" null}JSON-DWIW-0.18/t/parse_file/fail2.json0000644000076500007650000000002110704277342015362 0ustar dondon["Unclosed array"JSON-DWIW-0.18/t/parse_file/fail20.json0000644000076500007650000000002710704277342015450 0ustar dondon{"Double colon":: null}JSON-DWIW-0.18/t/parse_file/fail21.json0000644000076500007650000000004010704277342015444 0ustar dondon{"Comma instead of colon", null}JSON-DWIW-0.18/t/parse_file/fail22.json0000644000076500007650000000004110704277342015446 0ustar dondon["Colon instead of comma": false]JSON-DWIW-0.18/t/parse_file/fail31.json0000644000076500007650000000000710704277445015454 0ustar dondon[0e+-1]JSON-DWIW-0.18/t/parse_file/fail32.json0000644000076500007650000000005010704277445015453 0ustar dondon{"Comma instead if closing brace": true,JSON-DWIW-0.18/t/parse_file/fail33.json0000644000076500007650000000001410704277445015454 0ustar dondon["mismatch"}JSON-DWIW-0.18/t/parse_file/fail7.json0000644000076500007650000000003210704277445015375 0ustar dondon["Comma after the close"],JSON-DWIW-0.18/t/parse_file/fail8.json0000644000076500007650000000002010704277445015373 0ustar dondon["Extra close"]]JSON-DWIW-0.18/t/parse_file/pass0.json0000644000076500007650000000002010672120007015377 0ustar dondon{"var1":"val1"} JSON-DWIW-0.18/t/parse_file/pass1.json0000644000076500007650000000264710704266537015440 0ustar dondon[ "JSON Test Pattern pass1", {"object with 1 member":["array with 1 element"]}, {}, [], -42, true, false, null, { "integer": 1234567890, "real": -9876.543210, "e": 0.123456789e-12, "E": 1.234567890E+34, "": 23456789012E66, "zero": 0, "one": 1, "space": " ", "quote": "\"", "backslash": "\\", "controls": "\b\f\n\r\t", "slash": "/ & \/", "alpha": "abcdefghijklmnopqrstuvwyz", "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", "digit": "0123456789", "0123456789": "digit", "special": "`1~!@#$%^&*()_+-={':[,]}|;.?", "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", "true": true, "false": false, "null": null, "array":[ ], "object":{ }, "address": "50 St. James Street", "url": "http://www.JSON.org/", "comment": "// /* */": " ", " s p a c e d " :[1,2 , 3 , 4 , 5 , 6 ,7 ],"compact":[1,2,3,4,5,6,7], "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", "quotes": "" \u0022 %22 0x22 034 "", "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" : "A key can be any string" }, 0.5 ,98.6 , 99.44 , 1066, 1e1, 0.1e1, 0.e2, 1e-1, 1e00,2e+00,2e-00 ,"rosebud"]JSON-DWIW-0.18/t/parse_file/pass2.json0000644000076500007650000000006410704266537015430 0ustar dondon[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]]JSON-DWIW-0.18/t/parse_file/pass3.json0000644000076500007650000000022410704266537015427 0ustar dondon{ "JSON Test Pattern pass3": { "The outermost value": "must be an object or array.", "In this test": "It is an object." } } JSON-DWIW-0.18/WhatsNew0000644000076500007650000000614210706024450012603 0ustar dondonVersion 0.18 * Fixed compilation problem on Windows by removing calls to bzero() Version 0.17 * Fixed bug where unnecessary header files were being included, breaking the build on Windows Version 0.16 * Added get_stats() method * Added get_error_string() method * Added get_error_data() method Version 0.15 * Added from_json_file() method * Added to_json_file() method * Fixed bug where, in Perl version >= 5.8, hash keys with multibyte utf-8 chars were not handled correctly * Changed error messages to include the module name and version, fixed error messages that did not specify where the error occurred, and added line number, character offset, and character column to parse error messages. Version 0.14 * Fixed problem with escaping '\' when decoding * Made some optimizations * Now recognize more whitespace characters The full list of whitespace characters recognized is: case 0x20: /* space */ case 0x09: /* tab */ case 0x0b: /* vertical tab */ case 0x0c: /* form feed */ case 0x0d: /* carriage return */ case 0x00a0: /* NSBP - non-breaking space */ case 0x200b: /* ZWSP - zero width space */ case 0x2029: /* PS - paragraph separator */ case 0x2060: /* WJ - word joiner */ case 0x0a: /* newline */ case 0x0085: /* NEL - next line */ case 0x2028: /* LS - line separator */ Version 0.13 * Fixed problem where array elements may be missing when the "pretty" option is turned on Version 0.12 * Fixed assertion failure in perl 5.8.5 when finding a tied scalar in a hash value Version 0.11 * Changed the way null gets converted to undef when converting from JSON. Instead of returning &PL_sv_undef, it now gets returned as a new, unitialized SV. This keeps Data::Dumper from outputing undef as an alias to another undef value in the data structure. Version 0.10 * Add methods true() and false() to return objects that will get encoded as true and false, respectively, when converting to JSON. Version 0.09 * Fixed the bad_char_policy option -- it was being ignored Version 0.08 * Fixed problem encoding scalars that have been used as both strings and numbers (types SVt_PVN, SVt_PVIV) Version 0.07 * Fixed more problems with Math::BigInt and Math::BigFloat objects Version 0.06 * Fixed problems with tests using Math::BigInt and Math::BigFloat objects Version 0.05 * Bad utf-8 sequences now cause an error unless you pass an option indicating otherwise * Added options for how to react to bad utf8 data * Added option to throw an exception on error * Added option to pretty-print output * Fixed some compilation problems on Windows Version 0.04 * Fixed bug where empty strings got encoded incorrectly Version 0.03 * Fixed bug where parsing an empty array would sometimes cause an error Version 0.02 * Speed optimizations * Fixed a memory leak * Added support for spurious commas in hashes and arrays