JSON-DWIW-0.14/0000755000076500007650000000000010670146634011122 5ustar dondonJSON-DWIW-0.14/Artistic0000444000076500007650000001373710670143713012633 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.14/DWIW.xs0000644000076500007650000016564510670146472012271 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 JSON_DO_DEBUG 0 #define JSON_DO_TRACE 0 #define JSON_DUMP_OPTIONS 0 #define JSON_DO_EXTENDED_ERRORS 0 #include #define debug_level 9 #ifndef PERL_MAGIC_tied #define PERL_MAGIC_tied 'P' /* Tied array or hash */ #endif #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 #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; } #define JSON_ERROR(...) _build_error_str(__FILE__, __LINE__, newSVpvf(__VA_ARGS__)) #else #define JSON_ERROR(...) newSVpvf(__VA_ARGS__) #endif #else 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); vprintf(fmt, ap); va_end(ap); return error; } #endif /* 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) /* for converting from JSON */ typedef struct { STRLEN len; char * data; STRLEN pos; SV * error; SV * self; int flags; UV bad_char_policy; unsigned int line; unsigned int col; UV cur_char; unsigned int cur_char_len; } json_context; #define kBadCharError 0 #define kBadCharConvert 1 #define kBadCharPassThrough 2 /* for converting to JSON */ typedef struct { SV * error; int bare_keys; UV bad_char_policy; int use_exceptions; int flags; } self_context; static SV * json_parse_value(json_context *ctx, int is_identifier); static SV * to_json(self_context * self, SV * data_ref, int indent_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 ) #define json_next_byte(ctx0) ( (ctx)->pos >= (ctx)->len ? 0 : (ctx)->data[(ctx)->pos++] ) #define json_peek_byte(ctx) ( (ctx)->pos >= (ctx)->len ? 0 : (ctx)->data[(ctx)->pos] ) #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 JsCurChar(ctx) ( JsHaveMoreChars(ctx) ? ( UTF8_IS_INVARIANT(ctx->data[ctx->pos]) ? (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->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->data[ctx->pos++]) : (uv = convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), &len), ctx->pos += len, ctx->col += len, uv) ) : 0 ) static UV json_next_multibyte_char(json_context * ctx) { UV uv = 0; STRLEN len = 0; uv = convert_utf8_to_uv((unsigned char *)&(ctx->data[ctx->pos]), &len); ctx->pos += len; ctx->col += len; 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; 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 = json_peek_byte(ctx); while (ctx->pos < ctx->len && looking_at >= '0' && looking_at <= '9') { json_next_byte(ctx); looking_at = json_peek_byte(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 = json_peek_byte(ctx); if (looking_at == '-') { json_next_byte(ctx); looking_at = json_peek_byte(ctx); flags |= kParseNumberHaveSign; } if (looking_at < '0' || looking_at > '9') { JSON_DEBUG("syntax error at byte %d", ctx->pos); ctx->error = JSON_ERROR("syntax error at byte %d, line %u, col %u", ctx->pos, ctx->line, ctx->col); return (SV *)&PL_sv_undef; } json_eat_digits(ctx); if (tmp_str) { sv_setpvn(tmp_str, "", 0); rv = tmp_str; } if (ctx->pos < ctx->len) { looking_at = json_peek_byte(ctx); if (looking_at == '.') { json_next_byte(ctx); json_eat_digits(ctx); looking_at = json_peek_byte(ctx); flags |= kParseNumberHaveDecimal; } if (ctx->pos < ctx->len) { if (looking_at == 'E' || looking_at == 'e') { /* exponential notation */ flags |= kParseNumberHaveExponent; json_next_byte(ctx); if (ctx->pos < ctx->len) { looking_at = json_peek_byte(ctx); if (looking_at == '+' || looking_at == '-') { json_next_byte(ctx); looking_at = json_peek_byte(ctx); } json_eat_digits(ctx); looking_at = json_peek_byte(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_ERROR("syntax error at byte %d", ctx->pos); return (SV *)&PL_sv_undef; } else { if (! 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); 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); 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); return (SV *)newSV(0); } } JSON_DEBUG("returning from json_parse_word() at byte %d", ctx->pos); return JsAppendBuf(rv, ctx, start_pos, 0); } break; } } JSON_DEBUG("syntax error at byte %d", ctx->pos); ctx->error = JSON_ERROR("syntax error at byte %d", ctx->pos); 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; unicode_digits[4] = '\x00'; looking_at = JsCurChar(ctx); if (looking_at != '"' && looking_at != '\'') { return (SV *)&PL_sv_undef; } boundary = looking_at; this_uv = JsNextCharWithArg(ctx, tmp_uv, tmp_len); next_uv = JsCurChar(ctx); orig_start_pos = ctx->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); 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 { ctx->error = JSON_ERROR("bad unicode character specification at byte %d", ctx->pos - 1); if (rv && !tmp_str) { SvREFCNT_dec(rv); rv = NULL; } return (SV *)&PL_sv_undef; } } if (i != 4) { ctx->error = JSON_ERROR("bad unicode character specification at byte %d", ctx->pos - 1); 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, "%04x", &this_uv); tmp_buf = convert_uv_to_utf8(unicode_digits, this_uv); if (!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_ERROR("unterminated string starting at byte %d", orig_start_pos); return (SV *)&PL_sv_undef; } static SV * json_parse_object(json_context *ctx) { UV looking_at; HV * hash; SV * key; SV * val; 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; } 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); } 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_ERROR("bad object at byte %d, line %u, col %u", ctx->pos, ctx->line, ctx->col); SvREFCNT_dec(tmp_str); return (SV *)&PL_sv_undef; } JsNextCharWithArg(ctx, tmp_uv, tmp_len); json_eat_whitespace(ctx, 0); val = json_parse_value(ctx, 0); 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: if (!found_comma) { JSON_DEBUG("bad object at %d (%c)", ctx->pos, looking_at); ctx->error = JSON_ERROR("bad object at byte %d (%04x), line %u, col %u", ctx->pos, looking_at, ctx->line, ctx->col); 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_ERROR("bad object at byte %d", ctx->pos); return (SV *)&PL_sv_undef; } static SV * json_parse_array(json_context *ctx) { unsigned char looking_at; AV * array; SV * val; int found_comma = 0; looking_at = json_peek_byte(ctx); if (looking_at != '[') { return (SV *)&PL_sv_undef; } json_next_byte(ctx); json_eat_whitespace(ctx, 0); array = newAV(); looking_at = json_peek_byte(ctx); if (looking_at == ']') { json_next_byte(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); av_push(array, val); json_eat_whitespace(ctx, 0); looking_at = json_peek_byte(ctx); if (looking_at == ',') { found_comma = 1; json_eat_whitespace(ctx, kCommasAreWhitespace); looking_at = json_peek_byte(ctx); } switch (looking_at) { case ']': json_next_byte(ctx); return (SV *)newRV_noinc((SV *)array); break; case ',': json_next_byte(ctx); json_eat_whitespace(ctx, kCommasAreWhitespace); /* json_eat_whitespace(ctx, 0); */ break; default: if (!found_comma) { JSON_DEBUG("bad array at %d", ctx->pos); ctx->error = JSON_ERROR("bad array at byte %d", ctx->pos); return (SV *)&PL_sv_undef; } break; } } JSON_DEBUG("bad array at %d", ctx->pos); ctx->error = JSON_ERROR("bad array at byte %d", ctx->pos); return (SV *)&PL_sv_undef; } static SV * json_parse_value(json_context *ctx, int is_identifier) { 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_ERROR("bad object at byte %d", ctx->pos); 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); JSON_DEBUG("after json_parse_object"); return rv; break; case '[': JSON_DEBUG("before json_parse_array()"); rv = json_parse_array(ctx); 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) { return json_parse_value(ctx, 0); } static SV * from_json (SV * self, SV * data_sv, SV ** error_msg, int *throw_exception) { STRLEN data_str_len; char * data_str; json_context ctx; SV * val; SV ** ptr; SV * self_hash = SvRV(self); /* int is_utf8 = 0; int is_utf_16be = 0; int is_utf_32be = 0; */ data_str = SvPV(data_sv, data_str_len); if (!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 { } } } */ bzero(&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; } else { *error_msg = (SV *)&PL_sv_undef; } return (SV *)val; } /* 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; } */ static SV * fast_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; 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 */ if (!SvOK(sv_str)) { return newSVpv("null", 4); } data_str = (U8 *)SvPV(sv_str, data_str_len); if (!data_str) { return newSVpv("null", 4); } 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); 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) { if (! self->bad_char_policy) { /* default */ self->error = JSON_ERROR("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) { if (!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) { 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); 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); 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)); if (! 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; if (! 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++; if (! ( 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) { 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; 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)) ) { if (!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)) { sv_catpvn(rsv, (char *)key, key_len); } else { tmp_sv = newSVpv((char *)key, key_len); tmp_sv2 = fast_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); 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) { 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); if (! 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); 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 = fast_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 = fast_escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVLV: sv_catsv(rsv, data); tmp = rsv; rsv = fast_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 = fast_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); return rsv; } else { sv_setpvn(rsv, "false", 5); 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 = fast_escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVIV: case SVt_PVNV: sv_catsv(rsv, data); tmp = rsv; rsv = fast_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 = fast_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); break; case SVt_PVHV: /* hash */ JSON_DEBUG("==========> found hash ref"); SvREFCNT_dec(rsv); return encode_hash(self, (HV *)data, indent_level); break; case SVt_PVCV: /* code */ sv_catsv(rsv, data_ref); tmp = rsv; rsv = fast_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 = fast_escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; break; case SVt_PVIO: sv_catsv(rsv, data); tmp = rsv; rsv = fast_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 = fast_escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; } else { sv_catsv(rsv, data); tmp = rsv; rsv = fast_escape_json_str(self, tmp); SvREFCNT_dec(tmp); return rsv; } break; default: sv_catsv(rsv, data); tmp = rsv; rsv = fast_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; } MODULE = JSON::DWIW PACKAGE = JSON::DWIW PROTOTYPES: DISABLE SV * _xs_from_json(self, data, error_msg_ref) SV * self SV * data SV * error_msg_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(self, data, &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); } RETVAL = rv; OUTPUT: RETVAL SV * _xs_to_json(self, data, error_msg_ref) SV * self SV * data SV * error_msg_ref PREINIT: self_context self_context; SV * rv; int indent_level = 0; CODE: setup_self_context(self, &self_context); rv = to_json(&self_context, data, indent_level); if (self_context.error) { sv_setsv(SvRV(error_msg_ref), self_context.error); } RETVAL = rv; OUTPUT: RETVAL SV * have_big_int(self) 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(self) 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(self) 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(self, val) 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 int is_true(self, val) SV * self SV * val CODE: self = self; /* get rid of compiler warnings */ RETVAL = SvTRUE(val); OUTPUT: RETVAL SV * is_valid_utf8(self, str) 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(self, str) 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(self, str) SV * self SV * str PREINIT: SV * rv = &PL_sv_yes; CODE: self = self; SvUTF8_on(str); RETVAL = rv; OUTPUT: RETVAL SV * unflag_as_utf8(self, str) 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(self, code_point_sv) SV * self 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(self, bytes) SV * self 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, "%02x\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 JSON-DWIW-0.14/INSTALL0000644000076500007650000000024610567102717012154 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.14/lib/0000755000076500007650000000000010670146634011670 5ustar dondonJSON-DWIW-0.14/lib/JSON/0000755000076500007650000000000010670146634012441 5ustar dondonJSON-DWIW-0.14/lib/JSON/DWIW/0000755000076500007650000000000010670146634013213 5ustar dondonJSON-DWIW-0.14/lib/JSON/DWIW/Boolean.pm0000644000076500007650000000635210670146604015133 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.14/lib/JSON/DWIW.pm0000644000076500007650000003237310670146413013554 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 $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(Exporter DynaLoader); @ISA = qw(DynaLoader); package JSON::DWIW; @EXPORT = ( ); @EXPORT_OK = (); %EXPORT_TAGS = (all => [ 'to_json', 'from_json' ]); Exporter::export_ok_tags('all'); our $VERSION = '0.14'; { 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(@_); } package JSON::DWIW; bootstrap JSON::DWIW $VERSION; package JSON::DWIW; { # 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($data) 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 $str = _xs_to_json($self, $data, \$error_msg); 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 my ($data, $error_msg) = from_json($json_str) 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 $data = _xs_from_json($self, $json, \$error_msg); 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 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.14 =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.14/Makefile.PL0000755000076500007650000000177310620765711013105 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 => { }, ); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.14/META.yml0000644000076500007650000000060510670146634012374 0ustar dondon--- #YAML:1.0 name: JSON-DWIW version: 0.14 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.14/README0000644000076500007650000002234510670146631012005 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 $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($data) 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 my ($data, $error_msg) = from_json($json_str) 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 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.14 JSON-DWIW-0.14/t/0000755000076500007650000000000010670146634011365 5ustar dondonJSON-DWIW-0.14/t/00use.t0000755000076500007650000000043410567102717012511 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.14/t/01encode.t0000755000076500007650000000624310670143415013152 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.14/t/02decode.t0000755000076500007650000000666310600115126013136 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.14/t/03parse_constants.t0000755000076500007650000000114710600115247015116 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.14/t/04extras.t0000755000076500007650000000642510630653450013231 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.14/t/05exceptions.t0000755000076500007650000000206410611313073014071 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.14/t/06big_numbers.t0000755000076500007650000000405110606541466014220 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.14/t/07magic.t0000755000076500007650000000577010606544265013016 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.14/t/08pvxv.t0000755000076500007650000000154210611313073012716 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.14/t/09bool.t0000755000076500007650000000260610621667501012662 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.14/t/10unicode.t0000755000076500007650000000112110621102503013316 0ustar dondon#!/usr/bin/env perl # Creation date: 2007-05-11 07:43:10 # Authors: don use strict; use Test; # main { plan tests => 5; 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)); } exit 0; ############################################################################### # Subroutines JSON-DWIW-0.14/WhatsNew0000644000076500007650000000454410670145417012612 0ustar dondonVersion 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