Permalink
Browse files

initial commit

  • Loading branch information...
0 parents commit 36b5369f5ded427a913227e655b8ae4b6fee5577 @mnunberg committed Apr 3, 2012
Showing with 10,004 additions and 0 deletions.
  1. +5 −0 Changes
  2. +34 −0 MANIFEST
  3. +7 −0 MANIFEST.SKIP
  4. +26 −0 Makefile.PL
  5. +55 −0 README
  6. +1,224 −0 SL.xs
  7. +127 −0 eg/bench.pl
  8. +12 −0 ignore.txt
  9. +13 −0 json-sl.kpf
  10. +1 −0 jsonsl.c
  11. +1 −0 jsonsl.h
  12. +240 −0 jsonxs_inline.h
  13. +442 −0 lib/JSON/SL.pm
  14. +53 −0 lib/JSON/SL/EscapeTH.pm
  15. +10 −0 lib/JSON/SL/Tuba.pm
  16. +203 −0 perl-jsonsl.h
  17. +7,063 −0 ppport.h
  18. +10 −0 t/00-load.t
  19. +41 −0 t/01-synopsis.t
  20. +35 −0 t/02-readonly.t
  21. +39 −0 t/03-unescape.t
  22. +50 −0 t/04-errors.t
  23. +24 −0 t/05-types.t
  24. +22 −0 t/06-utf8.t
  25. +82 −0 t/07-dwiw_decode.t
  26. +29 −0 t/08-pc_esc.t
  27. +41 −0 t/09-pc_base.t
  28. +34 −0 t/10-pc_extra_number.t
  29. +28 −0 t/11-pc_expo.t
  30. +33 −0 t/13-limit.t
  31. +20 −0 typemap
5 Changes
@@ -0,0 +1,5 @@
+Revision history for JSON-SL
+
+0.01 Date/time
+ First version, released on an unsuspecting world.
+
34 MANIFEST
@@ -0,0 +1,34 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/JSON/SL.pm
+lib/JSON/SL/EscapeTH.pm
+
+perl-jsonsl.h
+jsonxs_inline.h
+
+jsonsl.h
+jsonsl.c
+ppport.h
+
+SL.xs
+typemap
+
+MANIFEST.SKIP
+
+t/13-limit.t
+t/02-readonly.t
+t/01-synopsis.t
+t/09-pc_base.t
+t/11-pc_expo.t
+t/05-types.t
+t/04-errors.t
+t/10-pc_extra_number.t
+t/07-dwiw_decode.t
+t/00-load.t
+t/08-pc_esc.t
+t/03-unescape.t
+t/06-utf8.t
+
+eg/bench.pl
7 MANIFEST.SKIP
@@ -0,0 +1,7 @@
+#ignore perlall output
+log\.*
+#ignore google-pprof output
+\.out
+
+#ignore komodo project file
+\.kpf
26 Makefile.PL
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'JSON::SL',
+ AUTHOR => q{M. Nunberg <mnunberg@haskalah.org>},
+ VERSION_FROM => 'lib/JSON/SL.pm',
+ ABSTRACT_FROM => 'lib/JSON/SL.pm',
+ META_MERGE => {
+ resources => {
+ repository => 'https://github.com/mnunberg/perl-JSON-SL/'
+ }
+ },
+
+ ($ExtUtils::MakeMaker::VERSION >= 6.3002
+ ? ('LICENSE'=> 'perl')
+ : ()),
+ PL_FILES => {},
+ OPTIMIZE => '-Wall -ggdb3 -O3',
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'JSON-SL-*' },
+);
55 README
@@ -0,0 +1,55 @@
+JSON-SL
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the README
+file from a module distribution so that people browsing the archive
+can use it to get an idea of the module's uses. It is usually a good idea
+to provide version information here so that people can decide whether
+fixes for the module are worth downloading.
+
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+ perldoc JSON::SL
+
+You can also look for information at:
+
+ RT, CPAN's request tracker
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=JSON-SL
+
+ AnnoCPAN, Annotated CPAN documentation
+ http://annocpan.org/dist/JSON-SL
+
+ CPAN Ratings
+ http://cpanratings.perl.org/d/JSON-SL
+
+ Search CPAN
+ http://search.cpan.org/dist/JSON-SL/
+
+
+LICENSE AND COPYRIGHT
+
+Copyright (C) 2012 M. Nunberg
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
1,224 SL.xs
@@ -0,0 +1,1224 @@
+#include "perl-jsonsl.h"
+#include "jsonxs_inline.h"
+
+/*
+ * JSON::SL, JSON::SL::Boolean
+ */
+#define MY_CXT_KEY "JSON::SL::_guts" XS_VERSION
+
+typedef struct {
+ PLJSONSL* quick;
+ HV *stash_obj;
+ HV *stash_boolean;
+ HV *stash_tuba;
+} my_cxt_t;
+START_MY_CXT
+
+static int PLJSONSL_Escape_Table_dfl[0x80];
+#define ESCTBL PLJSONSL_Escape_Table_dfl
+#define ESCAPE_TABLE_DFL_INIT \
+ memset(ESCTBL, 0, sizeof(ESCTBL)); \
+ ESCTBL['"'] = 1; \
+ ESCTBL['\\'] = 1; \
+ ESCTBL['/'] = 1; \
+ ESCTBL['b'] = 1; \
+ ESCTBL['n'] = 1; \
+ ESCTBL['r'] = 1; \
+ ESCTBL['f'] = 1; \
+ ESCTBL['u'] = 1; \
+ ESCTBL['t'] = 1;
+
+
+#if PERL_VERSION >= 10
+#define pljsonsl_hv_storeget_he(pjsn, hv, buf, len, value) \
+ hv_common((HV*)(hv), NULL, buf, len, 0, HV_FETCH_ISSTORE, value, 0)
+
+#define pljsonsl_hv_delete_okey(pjsn, hv, buf, len, flags, hash) \
+ hv_common((HV*)(hv), NULL, buf, len, 0, HV_DELETE|flags, NULL, hash)
+#define PLJSONSL_INIT_KSV(...)
+#define PLJSONSL_DESTROY_KSV(...)
+
+#else
+#warning "You are using a Perl from the stone age. This code might work.."
+/* probably very dangerous, but the beginning of hv_store_common
+ * looks quite simple...
+ */
+
+#define CLOBBER_PV(sv,buf,len) \
+ SvCUR_set(sv, len); \
+ SvPVX(sv) = buf;
+#define UNCLOBBER_PV(sv) \
+ SvCUR_set(sv, 0); \
+ SvPVX(sv) = NULL;
+
+#define PLJSONSL_INIT_KSV(pjsn) \
+ pjsn->ksv = newSV(16); \
+ pjsn->ksv_origpv = SvPVX(pjsn->ksv); \
+ SvLEN_set(pjsn->ksv, 0); \
+ SvPOK_on(pjsn->ksv);
+
+#define PLJSONSL_DESTROY_KSV(pjsn) \
+ CLOBBER_PV(pjsn->ksv, pjsn->ksv_origpv, 0); \
+ SvREFCNT_dec(pjsn->ksv);
+
+#define pljsonsl_hv_storeget_he(...) \
+ pljsonsl_hv_storeget_he_THX(aTHX_ __VA_ARGS__)
+static HE*
+pljsonsl_hv_storeget_he_THX(pTHX_
+ PLJSONSL *pjsn,
+ HV *hv,
+ const char *buf,
+ size_t len, SV *value)
+{
+ HE *ret;
+ CLOBBER_PV(pjsn->ksv, buf, len);
+ ret = hv_store_ent(hv, pjsn->ksv, value, 0);
+ UNCLOBBER_PV(pjsn->ksv);
+ return ret;
+}
+
+#define pljsonsl_hv_delete_okey(...) \
+ pljsonsl_hv_delete_okey_THX(aTHX_ __VA_ARGS__)
+static void
+pljsonsl_hv_delete_okey_THX(pTHX_
+ PLJSONSL *pjsn,
+ HV *hv,
+ const char *buf,
+ size_t len,
+ int flags,
+ U32 hash)
+{
+ CLOBBER_PV(pjsn->ksv, buf, len);
+ (void)hv_delete_ent(hv, pjsn->ksv, flags, hash);
+ UNCLOBBER_PV(pjsn->ksv);
+}
+
+/* fill in for HeUTF8 */
+#warning "Using our own HeUTF8 as HeKUTF8"
+#define HeUTF8(he) HeKUTF8(he)
+
+#endif /* 5.10 */
+
+
+#define GET_STATE_BUFFER(pjsn, pos) \
+ (char*)(SvPVX(pjsn->buf) + (pos - pjsn->pos_min_valid))
+
+/**
+ * This function will try and determine if the current
+ * item is a matched result (which should be returned to
+ * the user).
+ * If this is a complete match, the SV (along with relevant info)
+ * will be pushed to the result stack and return true. Returns
+ * false otherwise.
+ */
+#define object_mkresult(...) object_mkresult_THX(aTHX_ __VA_ARGS__)
+static inline int
+object_mkresult_THX(pTHX_
+ PLJSONSL *pjsn,
+ struct jsonsl_state_st *parent,
+ struct jsonsl_state_st *child)
+{
+#define STORE_INFO(b, v) \
+ (void)hv_stores(info_hv, PLJSONSL_INFO_KEY_##b, v)
+ HV *info_hv;
+
+ if (child->matchres != JSONSL_MATCH_COMPLETE || child->type == JSONSL_T_HKEY) {
+ return 0;
+ }
+ info_hv = newHV();
+ if (SvTYPE(child->sv) == SVt_PVHV || SvTYPE(child->sv) == SVt_PVAV) {
+ STORE_INFO(VALUE, newRV_noinc(child->sv));
+ } else {
+ STORE_INFO(VALUE, child->sv);
+ }
+
+ if (pjsn->options.noqstr == 0) {
+ STORE_INFO(QUERY, newSVpvn_share(child->matchjpr->orig,
+ child->matchjpr->norig, 0));
+ }
+
+ if (pjsn->options.nopath == 0) {
+ SV *pathstr;
+ int ii;
+ pathstr = newSVpvs("/");
+ for (ii = 2; ii <= (child->level); ii++) {
+ struct jsonsl_state_st *cur = pjsn->jsn->stack + ii;
+ struct jsonsl_state_st *prev = jsonsl_last_state(pjsn->jsn, cur);
+ if (prev->type == JSONSL_T_LIST) {
+ sv_catpvf(pathstr, "%d/", cur->u_loc.idx);
+ } else {
+ char *kbuf;
+ STRLEN klen;
+ assert(cur->u_loc.key);
+ kbuf = HePV(cur->u_loc.key, klen);
+ sv_catpvn(pathstr, kbuf, klen);
+ sv_catpvs(pathstr, "/");
+ if (HeUTF8(cur->u_loc.key)) {
+ SvUTF8_on(pathstr);
+ }
+ }
+ }
+ /* Trim the trailing '/' from the path string */
+ if (SvCUR(pathstr) != 1) {
+ SvCUR_set(pathstr, SvCUR(pathstr)-1);
+ }
+ STORE_INFO(PATH, pathstr);
+ }
+
+ /**
+ * For the sake of allowing inspection of the object tree, array
+ * and hash types are always added to their parents, even if they
+ * are a complete match to be removed from the stack.
+ */
+ if (parent->sv) {
+ SvREADONLY_off(parent->sv);
+ SvREFCNT_inc_simple_void_NN(child->sv);
+ if (parent->type == JSONSL_T_LIST) {
+ av_pop((AV*)parent->sv);
+ } else {
+ char *kbuf;
+ STRLEN klen;
+ kbuf = HePV(child->u_loc.key, klen);
+ SvREADONLY_off(HeVAL(child->u_loc.key));
+ pljsonsl_hv_delete_okey(pjsn, parent->sv,
+ kbuf, klen,
+ G_DISCARD,
+ HeHASH(child->u_loc.key));
+ /* is a macro for:
+ hv_common((HV*)parent->sv,
+ NULL,
+ kbuf, klen,
+ 0,
+ HV_DELETE|G_DISCARD,
+ NULL,
+ HeHASH(child->u_loc.key));
+ */
+ child->u_loc.key = NULL;
+ }
+
+ SvREADONLY_on(parent->sv);
+ SvREADONLY_off(child->sv);
+ }
+
+ av_push(pjsn->results, newRV_noinc((SV*)info_hv));
+ return 1;
+#undef STORE_INFO
+}
+
+#define process_special(...) process_special_THX(aTHX_ __VA_ARGS__)
+static inline void
+process_special_THX(pTHX_
+ PLJSONSL *pjsn,
+ struct jsonsl_state_st *state)
+{
+ SV *newsv;
+ char *buf = GET_STATE_BUFFER(pjsn, state->pos_begin);
+
+#define MAKE_BOOLEAN_BLESSED_IV(v) \
+ { SV *newiv = newSViv(v); newsv = newRV_noinc(newiv); sv_bless(newsv, pjsn->stash_boolean); } \
+
+
+ switch (state->special_flags) {
+ case JSONSL_SPECIALf_UNSIGNED:
+ case JSONSL_SPECIALf_SIGNED:
+ newsv = jsonxs_inline_process_number(buf);
+ break;
+
+ case JSONSL_SPECIALf_TRUE:
+ if (state->pos_cur - state->pos_begin != 4) {
+ die("Expected 'true'");
+ }
+ MAKE_BOOLEAN_BLESSED_IV(1);
+ break;
+ case JSONSL_SPECIALf_FALSE: {
+ if (state->pos_cur - state->pos_begin != 5) {
+ die("Expected 'false'");
+ }
+ MAKE_BOOLEAN_BLESSED_IV(0);
+ break;
+ }
+
+ case JSONSL_SPECIALf_NULL:
+ if (state->pos_cur - state->pos_begin != 4) {
+ die("Expected 'null'");
+ }
+ newsv = &PL_sv_undef;
+ break;
+
+ default:
+ warn("Buffer is %p", buf);
+ warn("Length is %lu", state->pos_cur - state->pos_begin);
+ warn("Special flag is %d", state->special_flags);
+ die("WTF!");
+ break;
+ }
+
+ if (newsv == NULL) {
+ newsv = &PL_sv_undef;
+ }
+ state->sv = newsv;
+ return;
+}
+
+/**
+ * This is called to clean up any quotes, and possibly
+ * handle \u-escapes in the future
+ */
+#define process_string(...) process_string_THX(aTHX_ __VA_ARGS__)
+static void
+process_string_THX(pTHX_
+ PLJSONSL* pjsn,
+ struct jsonsl_state_st *state)
+{
+ SV *retsv;
+ char *buf = GET_STATE_BUFFER(pjsn, state->pos_begin);
+ size_t buflen;
+ buf++;
+ buflen = (state->pos_cur - state->pos_begin) - 1;
+ if (state->nescapes == 0) {
+ retsv = newSVpvn(buf, buflen);
+ } else {
+ jsonsl_error_t err;
+ jsonsl_special_t flags;
+ size_t newlen;
+ retsv = newSV(buflen);
+ SvPOK_only(retsv);
+ newlen = jsonsl_util_unescape_ex(buf,
+ SvPVX(retsv),
+ buflen,
+ pjsn->escape_table,
+ &flags,
+ &err, NULL);
+ if (!newlen) {
+ SvREFCNT_dec(retsv);
+ die("Could not unescape string: %s", jsonsl_strerror(err));
+ }
+ /* Shrink the buffer to the effective new size */
+ SvCUR_set(retsv, newlen);
+ if (flags & JSONSL_SPECIALf_NONASCII) {
+ SvUTF8_on(retsv);
+ }
+ }
+
+ state->sv = retsv;
+ if (pjsn->options.utf8) {
+ SvUTF8_on(state->sv);
+ }
+
+}
+
+/**
+ * Because we only want to maintain 'complete' elements, for
+ * strings we ensure that their SVs do not get created until
+ * the entire string is done (as a partial string would
+ * not be of much use to the user anyway).
+ * The opposite is true of hashes and arrays, which we create
+ * immediately.
+ */
+static void body_push_callback(jsonsl_t jsn,
+ jsonsl_action_t action,
+ struct jsonsl_state_st *state,
+ const char *at)
+{
+ struct jsonsl_state_st *parent;
+ SV *newsv;
+ char *mkey;
+ size_t mnkey;
+ PLJSONSL *pjsn = (PLJSONSL*)jsn->data;
+ PLJSONSL_dTHX(pjsn);
+
+ /* Reset the position first */
+
+ pjsn->keep_pos = state->pos_begin;
+ parent = jsonsl_last_state(jsn, state);
+ /* Here we set up parent positioning variables.. */
+
+ if (parent->type == JSONSL_T_OBJECT) {
+ if (state->type == JSONSL_T_HKEY) {
+ return;
+ }
+ assert(pjsn->curhk);
+ mkey = HeKEY(pjsn->curhk);
+ mnkey = HeKLEN(pjsn->curhk);
+ /**
+ * Set the HE of our current value to the current HK, and then
+ * remove curhk's visibility.
+ */
+ state->u_loc.key = pjsn->curhk;
+ pjsn->curhk = NULL;
+ } else {
+ state->u_loc.idx = parent->nelem - 1;
+ mkey = NULL;
+ mnkey = state->u_loc.idx;
+ }
+
+ if (parent->matchres == JSONSL_MATCH_POSSIBLE) {
+ state->matchjpr = jsonsl_jpr_match_state(jsn, state, mkey, mnkey,
+ &state->matchres);
+ }
+
+ /**
+ * Ignore warnings about uninitialized newsv variable.
+ */
+ if (!JSONSL_STATE_IS_CONTAINER(state)) {
+ return; /* nothing more to do here. String types are added at POP */
+ }
+
+ if (state->type == JSONSL_T_OBJECT) {
+ newsv = (SV*)newHV();
+ } else if (state->type == JSONSL_T_LIST) {
+ newsv = (SV*)newAV();
+ } else {
+ die("WTF");
+ }
+
+ SvREADONLY_on(newsv);
+ if (parent->type == JSONSL_T_LIST) {
+ SvREADONLY_off(parent->sv);
+ av_push((AV*)parent->sv, newRV_noinc(newsv));
+ SvREADONLY_on(parent->sv);
+ } else {
+ /* we have the HE. */
+ HeVAL(state->u_loc.key) = newRV_noinc(newsv);
+ SvREADONLY_on(HeVAL(state->u_loc.key));
+ }
+
+ state->sv = newsv;
+}
+
+/**
+ * Creates a new HE*. We use this HE later on using HeVAL to assign the value.
+ */
+
+#define create_hk(...) create_hk_THX(aTHX_ __VA_ARGS__)
+static void
+create_hk_THX(pTHX_ PLJSONSL *pjsn,
+ struct jsonsl_state_st *state,
+ struct jsonsl_state_st *parent)
+{
+ assert(pjsn->curhk == NULL);
+ char *buf = GET_STATE_BUFFER(pjsn, state->pos_begin);
+ STRLEN len = (state->pos_cur - state->pos_begin)-1;
+ buf++;
+
+ SvREADONLY_off(parent->sv);
+
+ if (state->nescapes) {
+ /* we have escapes within a key. rare, but allowable. No choice
+ * but to allocate a new buffer for it
+ */
+ process_string(pjsn, state);
+ pjsn->curhk = hv_store_ent((HV*)parent->sv, state->sv, &PL_sv_undef, 0);
+ SvREFCNT_dec(state->sv);
+ state->sv = NULL;
+ } else {
+
+ /**
+ * Fast path, no copying to new SV.
+ * We need to store &PL_sv_undef first to fool hv_common
+ * into thinking we're not doing anything special. Then
+ * we do fancy
+ */
+ pjsn->curhk = pljsonsl_hv_storeget_he(pjsn,
+ parent->sv,
+ buf, len,
+ &PL_sv_undef);
+ /* which is really this: */
+#if 0
+ pjsn->curhk = hv_common((HV*)parent->sv, /* HV*/
+ NULL, /* keysv */
+ buf, len,
+ 0, /* flags */
+ HV_FETCH_ISSTORE, /*action*/
+ &PL_sv_undef, /*value*/
+ 0);
+#endif
+ if (pjsn->options.utf8 ||
+ state->special_flags == JSONSL_SPECIALf_NONASCII) {
+ HEK_UTF8_on(HeKEY_hek(pjsn->curhk));
+ }
+
+ }
+
+ HeVAL(pjsn->curhk) = &PL_sv_placeholder;
+ SvREADONLY_on(parent->sv);
+}
+
+/* forward-declare initial state handler */
+static void initial_callback(jsonsl_t jsn,
+ jsonsl_action_t action,
+ struct jsonsl_state_st *state,
+ const char *at);
+
+/**
+ * In this callback we ensure to clean up our strings and push it
+ * into the parent SV
+ */
+static void body_pop_callback(jsonsl_t jsn,
+ jsonsl_action_t action,
+ struct jsonsl_state_st *state,
+ const char *at)
+{
+ /* Ending of an element */
+ struct jsonsl_state_st *parent = jsonsl_last_state(jsn, state);
+ register PLJSONSL *pjsn = (PLJSONSL*)jsn->data;
+ PLJSONSL_dTHX(pjsn);
+ register jsonsl_type_t state_type = state->type;
+
+#define INSERT_STRING \
+ if (parent && object_mkresult(pjsn, parent, state) == 0) { \
+ SvREADONLY_off(parent->sv); \
+ if (parent->type == JSONSL_T_OBJECT) { \
+ assert(state->u_loc.key); \
+ HeVAL(state->u_loc.key) = state->sv; \
+ } else { \
+ av_push((AV*)parent->sv, state->sv); \
+ } \
+ SvREADONLY_on(parent->sv); \
+ }
+
+ if (state_type == JSONSL_T_STRING) {
+ process_string(pjsn, state);
+ INSERT_STRING;
+ } else if (state_type == JSONSL_T_HKEY) {
+ assert(parent->type == JSONSL_T_OBJECT);
+ create_hk(pjsn, state, parent);
+ } else if (state_type == JSONSL_T_SPECIAL) {
+ assert(state->special_flags);
+ process_special(pjsn, state);
+ INSERT_STRING;
+ } else {
+ SvREADONLY_off(state->sv);
+ object_mkresult(pjsn, parent, state);
+ }
+
+ #undef INSERT_STRING
+
+ if (state->sv == pjsn->root && pjsn->njprs == 0) {
+ av_push(pjsn->results, newRV_noinc(pjsn->root));
+ pjsn->root = NULL;
+ jsn->action_callback_PUSH = initial_callback;
+ }
+
+ state->u_loc.idx = -1;
+ state->sv = NULL;
+ pjsn->keep_pos = 0;
+
+}
+
+static int error_callback(jsonsl_t jsn,
+ jsonsl_error_t err,
+ struct jsonsl_state_st *state,
+ char *at)
+{
+ PLJSONSL *pjsn = (PLJSONSL*)jsn->data;
+ PLJSONSL_dTHX(pjsn);
+ /**
+ * TODO: allow option for user-defined recovery function
+ */
+
+ die("JSON::SL - Got error %s at position %lu", jsonsl_strerror(err), jsn->pos);
+ return 0;
+}
+
+static void initial_callback(jsonsl_t jsn,
+ jsonsl_action_t action,
+ struct jsonsl_state_st *state,
+ const char *at)
+{
+ PLJSONSL *pjsn = (PLJSONSL*)jsn->data;
+ PLJSONSL_dTHX(pjsn);
+
+ assert(action == JSONSL_ACTION_PUSH);
+ if (state->type == JSONSL_T_LIST) {
+ pjsn->root = (SV*)newAV();
+ } else if (state->type == JSONSL_T_OBJECT) {
+ pjsn->root = (SV*)newHV();
+ } else {
+ die("Found type %s as root element", jsonsl_strtype(state->type));
+ }
+
+ state->sv = pjsn->root;
+ jsn->action_callback = NULL;
+ jsn->action_callback_PUSH = body_push_callback;
+ jsn->action_callback_POP = body_pop_callback;
+ jsonsl_jpr_match_state(jsn, state, NULL, 0, &state->matchres);
+ /* Mark root element as read only */
+ SvREADONLY_on(pjsn->root);
+}
+
+#define CHECK_MAX_SIZE(pjsn,input) \
+ if (pjsn->options.max_size && SvCUR(input) > pjsn->options.max_size) { \
+ die("JSON::SL - max_size is %lu, but input is %lu bytes", \
+ pjsn->options.max_size, SvCUR(input)); \
+ }
+
+#define pljsonsl_feed_incr(...) pljsonsl_feed_incr_THX(aTHX_ __VA_ARGS__)
+static void
+pljsonsl_feed_incr_THX(pTHX_ PLJSONSL* pjsn, SV *input)
+{
+ size_t start_pos = pjsn->jsn->pos;
+ STRLEN cur_len = SvCUR(pjsn->buf);
+ pjsn->pos_min_valid = pjsn->jsn->pos - cur_len;
+ if (SvUTF8(input)) {
+ pjsn->options.utf8 = 1;
+ }
+ CHECK_MAX_SIZE(pjsn, input)
+ sv_catpvn(pjsn->buf, SvPVX_const(input), SvCUR(input));
+ jsonsl_feed(pjsn->jsn,
+ SvPVX_const(pjsn->buf) + (SvCUR(pjsn->buf)-SvCUR(input)),
+ SvCUR(input));
+ /**
+ * Callbacks may detect the beginning of a string, in which case
+ * we need to ensure the continuity of the string. In this case
+ * pos_keep is set to the position of the input stream (not the SV *input,
+ * but rather jsn->pos) from which we should begin buffering data.
+ *
+ * Now we might need to chop. The amount of bytes to chop is the
+ * difference between start_pos and the keep_pos
+ * variable (if any)
+ */
+ if (pjsn->keep_pos == 0) {
+ SvCUR_set(pjsn->buf, 0);
+ } else {
+ assert(pjsn->keep_pos >= start_pos);
+ sv_chop(pjsn->buf, SvPVX_const(pjsn->buf) + (pjsn->keep_pos - start_pos));
+ }
+
+}
+
+static PLJSONSL*
+pljsonsl_get_and_initialize_global(pTHX)
+{
+ dMY_CXT;
+ PLJSONSL *pjsn;
+ if (MY_CXT.quick == NULL) {
+ Newxz(pjsn, 1, PLJSONSL);
+ pjsn->jsn = jsonsl_new(PLJSONSL_MAX_DEFAULT+1);
+ pjsn->stash_boolean = MY_CXT.stash_boolean;
+ pjsn->jsn->data = pjsn;
+ pjsn->priv_global.is_global = 1;
+ memcpy(pjsn->escape_table, ESCTBL, sizeof(ESCTBL));
+ PLJSONSL_mkTHX(pjsn);
+ PLJSONSL_INIT_KSV(pjsn);
+ MY_CXT.quick = pjsn;
+ }
+
+ pjsn = MY_CXT.quick;
+ jsonsl_reset(pjsn->jsn);
+ jsonsl_enable_all_callbacks(pjsn->jsn);
+ pjsn->jsn->error_callback = error_callback;
+ pjsn->jsn->action_callback_PUSH = initial_callback;
+ pjsn->results = sv_2mortal((SV*)newAV());
+ return pjsn;
+}
+
+#define pljsonsl_feed_oneshot(...) pljsonsl_feed_oneshot_THX(aTHX_ __VA_ARGS__)
+static void
+pljsonsl_feed_oneshot_THX(pTHX_ PLJSONSL* pjsn, SV *input)
+{
+ if (!SvPOK(input)) {
+ die("Input is not a string");
+ }
+
+ if (SvUTF8(input)) {
+ pjsn->options.utf8 = 1;
+ }
+ CHECK_MAX_SIZE(pjsn, input);
+ pjsn->buf = input;
+ jsonsl_feed(pjsn->jsn, SvPVX_const(input), SvCUR(input));
+ pjsn->buf = NULL;
+ pjsn->options.utf8 = 0;
+ /* the current root is never in the result stack..
+ * so mortalizing it won't hurt anyone.
+ */
+}
+
+/**
+ * Takes an array ref (or list?) of JSONPointer strings and converts
+ * them to JPR objects. Dies on error
+ */
+#define pljsonsl_set_jsonpointer(...) pljsonsl_set_jsonpointer_THX(aTHX_ __VA_ARGS__)
+static void
+pljsonsl_set_jsonpointer_THX(pTHX_ PLJSONSL *pjsn, AV *paths)
+{
+ jsonsl_jpr_t *jprs;
+ jsonsl_error_t err;
+ int ii;
+ int max = av_len(paths)+1;
+ const char *diestr, *pathstr;
+
+ if (!max) {
+ die("No paths given!");
+ }
+
+ Newxz(jprs, max, jsonsl_jpr_t);
+
+ for (ii = 0; ii < max; ii++) {
+ SV **tmpsv = av_fetch(paths, ii, 0);
+ if (tmpsv == NULL || SvPOK(*tmpsv) == 0) {
+ diestr = "Found empty path";
+ goto GT_ERR;
+ }
+ jprs[ii] = jsonsl_jpr_new(SvPVX_const(*tmpsv), &err);
+ if (jprs[ii] == NULL) {
+ pathstr = SvPVX_const(*tmpsv);
+ goto GT_ERR;
+ }
+ }
+
+ jsonsl_jpr_match_state_init(pjsn->jsn, jprs, max);
+ pjsn->jprs = jprs;
+ pjsn->njprs = max;
+ return;
+
+ GT_ERR:
+ for (ii = 0; ii < max; ii++) {
+ if (jprs[ii] == NULL) {
+ break;
+ }
+ jsonsl_jpr_destroy(jprs[ii]);
+ }
+ Safefree(jprs);
+ if (pathstr) {
+ die("Couldn't convert %s to jsonpointer: %s", pathstr, jsonsl_strerror(err));
+ } else {
+ die(diestr);
+ }
+}
+
+/**
+ * JSON::SL::Tuba functions.
+ * In case you haven't wondered already, 'Tuba' is a play on 'SAX'
+ * The callback handlers will also mark 'regions', that is, they will
+ * first invoke a 'data' callback (if applicable), and then invoke
+ * their special states.
+ *
+ * This process is repeated again when jsonsl_feed returns, to flush any
+ * remaining 'data' not parsed.
+ */
+
+
+#define pltuba_invoke_callback(...) pltuba_invoke_callback_THX(aTHX_ __VA_ARGS__)
+static void
+pltuba_invoke_callback_THX(pTHX_ PLTUBA *tuba,
+ jsonsl_action_t action,
+ pltuba_callback_type cbtype,
+ SV *mextrasv)
+{
+ /**
+ * Make my life easy, just relay this information to Perl
+ */
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSViv(action)));
+ XPUSHs(sv_2mortal(newSViv(cbtype)));
+ if (mextrasv) {
+ XPUSHs(sv_2mortal(mextrasv));
+ }
+ PUTBACK;
+ call_pv(PLTUBA_HELPER_FUNC, G_DISCARD);
+ FREETMPS;
+ LEAVE;
+}
+
+/**
+ * Flush characters between the invocation of the last callback
+ * and the current one. the until argument is the end position (exclusive)
+ * at which we should stop submitting 'character' data.
+ */
+#define pltuba_flush_characters(...) pltuba_flush_characters_THX(aTHX_ __VA_ARGS__)
+static void
+pltuba_flush_characters_THX(pTHX_ PLTUBA *tuba, size_t until)
+{
+ size_t toFlush;
+ const char *buf;
+ SV *chunksv;
+
+ if (until <= tuba->buf_pos) {
+ return;
+ }
+
+ toFlush = until - tuba->buf_pos;
+
+ if (toFlush == 0) {
+ return;
+ }
+
+ toFlush -= tuba->chardata_begin_offset;
+ buf = SvPVX_const(tuba->buf);
+ buf += tuba->chardata_begin_offset;
+ chunksv = newSVpvn(buf, toFlush);
+ pltuba_invoke_callback(tuba,
+ JSONSL_ACTION_PUSH,
+ PLTUBA_CALLBACK_CHARACTER,
+ chunksv);
+ /**
+ * SV has been mortalized by the invoke_callback function
+ */
+ sv_chop(tuba->buf, buf);
+ tuba->buf_pos = until;
+}
+
+/**
+ * Unified callback
+ */
+static void
+pltuba_jsonsl_callback(jsonsl_t jsn,
+ jsonsl_action_t action,
+ struct jsonsl_state_st *state,
+ const char *at)
+{
+ /* Figure out the difference between now and the last callback */
+ PLTUBA *tuba = (PLTUBA*)jsn->data;
+ PLJSONSL_dTHX(tuba);
+ size_t pos = (action == JSONSL_ACTION_POP) ? state->pos_cur : state->pos_begin;
+
+ if (pos && pos > tuba->last_cb_pos) {
+ pltuba_flush_characters(tuba, pos);
+ }
+ tuba->last_cb_pos = pos;
+ /* Piece together a callback specification */
+ if (state->type & JSONSL_Tf_STRINGY) {
+ tuba->chardata_begin_offset = 1;
+ } else {
+ tuba->chardata_begin_offset = 0;
+ }
+#define X(o,c) \
+ if (state->type == JSONSL_T_##o) { \
+ pltuba_invoke_callback(tuba, action, PLTUBA_CALLBACK_##o, NULL); \
+ goto GT_CB_DONE; \
+ }
+ JSONSL_XTYPE;
+#undef X
+ if (state->level == 1 && action == JSONSL_ACTION_POP) {
+ pltuba_invoke_callback(tuba, action, PLTUBA_CALLBACK_DOCUMENT, NULL);
+ }
+ GT_CB_DONE:
+ return;
+}
+
+static int
+pltuba_jsonsl_error_callback(jsonsl_t jsn,
+ jsonsl_error_t error,
+ struct jsonsl_state_st *state,
+ char *at)
+{
+ /**
+ * This needs special handling, as we will be receiving a return
+ * value from Perl for this..
+ */
+ die ("Got error: %s", jsonsl_strerror(error));
+ return 0;
+}
+
+#define pltuba_feed(...) pltuba_feed_THX(aTHX_ __VA_ARGS__)
+static void
+pltuba_feed_THX(pTHX_ PLTUBA *tuba, SV *input)
+{
+ if (!SvPOK(input)) {
+ die("Input is not string!");
+ }
+ tuba->buf = input;
+ tuba->buf_pos = tuba->jsn->pos;
+
+ SvREADONLY_on(input);
+ jsonsl_feed(tuba->jsn, SvPVX_const(input), SvCUR(input));
+ if (SvCUR(input)) {
+ /* Assume the rest is 'character' data */
+ pltuba_flush_characters(tuba, SvCUR(input) + tuba->buf_pos);
+ }
+ SvREADONLY_off(input);
+}
+
+#define XOPTION \
+ X(noqstr) \
+ X(nopath) \
+ X(utf8) \
+ X(max_size)
+
+enum {
+
+#define X(o) \
+ OPTION_IX_##o,
+
+ OPTION_IX_begin = 0,
+ XOPTION
+#undef X
+ OPTION_IX_NONE
+};
+
+#define REFDEC_FIELD(pjsn, fld) \
+ if (pjsn->fld != NULL) { \
+ SvREFCNT_dec(pjsn->fld); \
+ pjsn->fld = NULL; \
+ }
+
+/**
+ * XS interface.
+ */
+
+#define POPULATE_CXT \
+ MY_CXT.stash_obj = gv_stashpv(PLJSONSL_CLASS_NAME, GV_ADD); \
+ MY_CXT.stash_boolean = gv_stashpv(PLJSONSL_BOOLEAN_NAME, GV_ADD); \
+ MY_CXT.stash_tuba = gv_stashpv(PLTUBA_CLASS_NAME, GV_ADD); \
+ MY_CXT.quick = NULL;
+
+
+/**
+ * These two macros arrange for the contents of the result stack to be returned
+ * to perlspace.
+ */
+#define dRESULT_VARS \
+ int result_count; \
+ int result_iter; \
+ SV *result_sv;
+
+#define RETURN_RESULTS(pjsn) \
+ switch(GIMME_V) { \
+ case G_VOID: \
+ result_count = 0; \
+ break; \
+ case G_SCALAR: \
+ result_sv = av_shift(pjsn->results); \
+ if (result_sv == &PL_sv_undef) { \
+ result_count = 0; \
+ break; \
+ } \
+ XPUSHs(sv_2mortal(result_sv)); \
+ result_count = 1; \
+ break; \
+ case G_ARRAY: \
+ result_count = av_len(pjsn->results) + 1; \
+ if (result_count == 0) { \
+ break; \
+ } \
+ EXTEND(SP, result_count); \
+ for (result_iter = 0; result_iter < result_count; result_iter++) { \
+ result_sv = av_delete(pjsn->results, result_iter, 0); \
+ /*already mortal according to av_delete*/ \
+ PUSHs(result_sv); \
+ } \
+ av_clear(pjsn->results); \
+ break; \
+ default: \
+ die("eh? (RETURN_RESULTS)"); \
+ result_count = 0; \
+ break; \
+ }
+
+
+
+
+MODULE = JSON::SL PACKAGE = JSON::SL PREFIX = PLJSONSL_
+
+PROTOTYPES: DISABLED
+
+BOOT:
+{
+ MY_CXT_INIT;
+ POPULATE_CXT;
+ ESCAPE_TABLE_DFL_INIT;
+}
+
+SV *
+PLJSONSL_new(SV *pkg, ...)
+ PREINIT:
+ PLJSONSL *pjsn;
+ SV *ptriv, *retrv;
+ int levels;
+ dMY_CXT;
+ CODE:
+ (void)pkg;
+ if (items > 1) {
+ if (!SvIOK(ST(1))) {
+ die("Second argument (if provided) must be numeric");
+ }
+ levels = SvIV(ST(1));
+ if (levels < 2) {
+ die ("Levels must be at least 2");
+ }
+ } else {
+ levels = PLJSONSL_MAX_DEFAULT;
+ }
+
+ Newxz(pjsn, 1, PLJSONSL);
+ pjsn->jsn = jsonsl_new(levels+2);
+ ptriv = newSViv(PTR2IV(pjsn));
+ retrv = newRV_noinc(ptriv);
+ sv_bless(retrv, MY_CXT.stash_obj);
+ pjsn->buf = newSVpvn("", 0);
+
+ jsonsl_enable_all_callbacks(pjsn->jsn);
+ pjsn->jsn->action_callback = initial_callback;
+ pjsn->jsn->error_callback = error_callback;
+ pjsn->stash_boolean = MY_CXT.stash_boolean;
+ pjsn->jsn->data = pjsn;
+ pjsn->results = newAV();
+ memcpy(pjsn->escape_table, ESCTBL, sizeof(ESCTBL));
+ PLJSONSL_mkTHX(pjsn);
+ PLJSONSL_INIT_KSV(pjsn);
+ RETVAL = retrv;
+
+ OUTPUT: RETVAL
+
+
+void
+PLJSONSL_set_jsonpointer(PLJSONSL *pjsn, AV *paths)
+ PPCODE:
+ pljsonsl_set_jsonpointer(pjsn, paths);
+
+SV *
+PLJSONSL_root(PLJSONSL *pjsn)
+ CODE:
+ if (pjsn->root) {
+ RETVAL = newRV_inc(pjsn->root);
+ } else {
+ RETVAL = &PL_sv_undef;
+ }
+ OUTPUT: RETVAL
+
+void
+PLJSONSL__modify_readonly(PLJSONSL *pjsn, SV *ref)
+ ALIAS:
+ make_referrent_writeable = 1
+ make_referrent_readonly = 2
+ CODE:
+ if (!SvROK(ref)) {
+ die("Variable is not a reference!");
+ }
+ if (ix == 0) {
+ croak_xs_usage(cv, "use make_referrent_writeable or make_referrent_readonly");
+ } else if (ix == 1) {
+ SvREADONLY_off(SvRV(ref));
+ } else if (ix == 2) {
+ SvREADONLY_on(SvRV(ref));
+ }
+
+int
+PLJSONSL_referrent_is_writeable(PLJSONSL *pjsn, SV *ref)
+ CODE:
+ if (!SvROK(ref)) {
+ die("Variable is not a reference!");
+ }
+ RETVAL = SvREADONLY(SvRV(ref)) == 0;
+ OUTPUT: RETVAL
+
+
+void
+PLJSONSL_feed(PLJSONSL *pjsn, SV *input)
+ ALIAS:
+ incr_parse =1
+
+ PREINIT:
+ dRESULT_VARS;
+
+ PPCODE:
+ pljsonsl_feed_incr(pjsn, input);
+ RETURN_RESULTS(pjsn);
+
+void
+PLJSONSL_fetch(PLJSONSL *pjsn)
+ PREINIT:
+ dRESULT_VARS;
+
+ PPCODE:
+ RETURN_RESULTS(pjsn);
+
+int
+PLJSONSL__option(PLJSONSL *pjsn, ...)
+ ALIAS:
+ utf8 = OPTION_IX_utf8
+ nopath = OPTION_IX_nopath
+ noqstr = OPTION_IX_noqstr
+ max_size = OPTION_IX_max_size
+
+ CODE:
+ RETVAL = 0;
+ if (ix == 0) {
+ die("Do not call this function (_options) directly");
+ }
+#define X(o) \
+ if (ix == OPTION_IX_##o) \
+ RETVAL = pjsn->options.o;
+ XOPTION
+#undef X
+ if (items == 2) {
+ int value = SvIV(ST(1));
+#define X(o) if (ix == OPTION_IX_##o) pjsn->options.o = value;
+ XOPTION
+#undef X
+ } else if (items > 2) {
+ croak_xs_usage(cv, "... boolean");
+ }
+
+ OUTPUT: RETVAL
+
+int
+PLJSONSL__escape_table_chr(PLJSONSL *pjsn, U8 chrc, ...)
+ CODE:
+ if (chrc > 0x7f) {
+ warn("Attempted to set non-ASCII escape preference");
+ RETVAL = -1;
+ } else {
+ RETVAL = pjsn->escape_table[chrc];
+ if (items == 3) {
+ pjsn->escape_table[chrc] = SvIV(ST(2));
+ }
+ }
+ OUTPUT: RETVAL
+
+void
+PLJSONSL_reset(PLJSONSL *pjsn)
+ CODE:
+ REFDEC_FIELD(pjsn, root);
+
+ if (pjsn->results) {
+ av_clear(pjsn->results);
+ }
+ if (pjsn->buf) {
+ SvCUR_set(pjsn->buf, 0);
+ }
+
+ jsonsl_reset(pjsn->jsn);
+ pjsn->pos_min_valid = 0;
+ pjsn->keep_pos = 0;
+ pjsn->curhk = NULL;
+ pjsn->jsn->action_callback_PUSH = initial_callback;
+
+
+void
+PLJSONSL_DESTROY(PLJSONSL *pjsn)
+ PREINIT:
+ int ii;
+
+ CODE:
+ if (pjsn->priv_global.is_global == 0) {
+ REFDEC_FIELD(pjsn, root);
+ REFDEC_FIELD(pjsn, results);
+ REFDEC_FIELD(pjsn, buf);
+ } /* else, it's a mortal and shouldn't be freed */
+ jsonsl_jpr_match_state_cleanup(pjsn->jsn);
+ if (pjsn->jprs) {
+ for ( ii = 0; ii < pjsn->njprs; ii++) {
+ if (pjsn->jprs[ii] == NULL) {
+ break;
+ }
+ jsonsl_jpr_destroy(pjsn->jprs[ii]);
+ }
+ Safefree(pjsn->jprs);
+ pjsn->jprs = NULL;
+ }
+ if (pjsn->jsn) {
+ jsonsl_destroy(pjsn->jsn);
+ pjsn->jsn = NULL;
+ }
+ PLJSONSL_DESTROY_KSV(pjsn);
+ Safefree(pjsn);
+
+void
+PLJSONSL_decode_json(SV *input)
+ PREINIT:
+ PLJSONSL* pjsn;
+ dRESULT_VARS;
+
+ PPCODE:
+ pjsn = pljsonsl_get_and_initialize_global(aTHX);
+ pljsonsl_feed_oneshot(pjsn, input);
+
+ pjsn->curhk = NULL;
+ pjsn->keep_pos = 0;
+ pjsn->pos_min_valid = 0;
+ pjsn->jsn->action_callback_PUSH = initial_callback;
+
+ RETURN_RESULTS(pjsn);
+ if (!result_count) {
+ die("Incomplete JSON string?");
+ }
+
+SV *
+PLJSONSL_unescape_json_string(SV *input)
+ PREINIT:
+ size_t origlen, newlen;
+ SV *retsv = NULL;
+ char *errpos;
+ jsonsl_error_t err;
+ jsonsl_special_t flags;
+
+ CODE:
+ if (!SvPOK(input)) {
+ die("Input is not a valid string");
+ }
+ origlen = SvCUR(input);
+ if (origlen) {
+ retsv = newSV(origlen);
+ newlen = jsonsl_util_unescape_ex(SvPVX_const(input), SvPVX(retsv),
+ SvCUR(input), ESCTBL, &flags,
+ &err, (const char**)&errpos);
+ if (newlen == 0) {
+ SvREFCNT_dec(retsv);
+ die("Could not unescape: %s at pos %lu ('%c'..)",
+ jsonsl_strerror(err),
+ errpos - SvPVX_const(input),
+ *errpos
+ );
+ }
+
+ SvCUR_set(retsv, newlen);
+ SvPOK_only(retsv);
+ if (SvUTF8(input) || (flags & JSONSL_SPECIALf_NONASCII)) {
+ SvUTF8_on(retsv);
+ }
+ } else {
+ retsv = &PL_sv_undef;
+ }
+ RETVAL = retsv;
+ OUTPUT: RETVAL
+
+
+
+void
+PLJSONSL_CLONE(PLJSONSL *pjsn)
+ CODE:
+ MY_CXT_CLONE;
+ POPULATE_CXT;
+
+MODULE = JSON::SL PACKAGE = JSON::SL::Tuba PREFIX = PLTUBA_
+
+SV *
+PLTUBA__initialize(SV *pkg)
+ PREINIT:
+ PLTUBA *tuba;
+ SV *ptriv, *retrv;
+ dMY_CXT;
+
+ CODE:
+ (void)pkg;
+
+ Newxz(tuba, 1, PLTUBA);
+ tuba->jsn = jsonsl_new(PLJSONSL_MAX_DEFAULT);
+ ptriv = newSViv(PTR2IV(tuba));
+ retrv = newRV_noinc(ptriv);
+ sv_bless(retrv, MY_CXT.stash_tuba);
+
+ tuba->jsn->action_callback = pltuba_jsonsl_callback;
+ tuba->jsn->error_callback = pltuba_jsonsl_error_callback;
+ jsonsl_enable_all_callbacks(tuba->jsn);
+ PLJSONSL_mkTHX(tuba);
+ RETVAL = retrv;
+
+ OUTPUT: RETVAL
+
+void
+PLTUBA__parse(PLTUBA* tuba, SV *input)
+ CODE:
+ pltuba_feed(tuba, input);
+
+void
+PLTUBA_DESTROY(PLTUBA* tuba)
+ CODE:
+ jsonsl_destroy(tuba->jsn);
+ tuba->jsn = NULL;
+ Safefree(tuba);
127 eg/bench.pl
@@ -0,0 +1,127 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use blib;
+use JSON::SL;
+use Data::Dumper::Concise;
+use JSON::XS qw(decode_json);
+use Time::HiRes qw(time);
+use Getopt::Long;
+
+GetOptions(
+ 'i|iterations=i' => \my $Iterations,
+ 'x|jsonxs' => \my $TestJsonxs,
+ 's|jsonsl' => \my $TestJsonsl,
+ 'j|jpr' => \my $TestJsonpointer,
+ 'c|chunked=i' => \my $TestChunks,
+ 'f|file=s' => \my $TESTFILE,
+ 'r|recursion=i' => \my $RecursionLimit,
+ 'd|dump' => \my $DumpTree,
+ 'h|help' => \my $PrintHelp
+);
+
+if ($PrintHelp) {
+ print STDERR <<EOF;
+$0 [options]
+ -i --iterations=NUM Number of iterations
+ -x --jsonxs Benchmark JSON::XS
+ -s --jsonsl Benchmark JSON::SL
+ -j --jpr Test JSONPointer functionality
+ -f --file=FILE Run benchmarks on FILE
+ -c --chunked=SIZE Test incremental chunks of SIZE bytes
+ -r --recursion=LEVEL Set JSON::SL recursion limit
+ -d --dump Dump object tree on completion
+EOF
+ exit(1);
+}
+
+$Iterations ||= 20;
+
+if ($ENV{PERL_JSONSL_DEFAULTS}) {
+ $TestJsonsl = 1;
+ $TestJsonxs = 1;
+ $TestJsonpointer = 1;
+ $TestChunks = 8192;
+}
+
+$TESTFILE ||= "share/auction";
+$RecursionLimit ||= 256;
+
+my $o = JSON::SL->new($RecursionLimit);
+open my $fh, "<", $TESTFILE or die "$TESTFILE: $!";
+my $txt = join("", <$fh>);
+close($fh);
+
+if ($TestJsonpointer) {
+ $o->set_jsonpointer(["/alliance/auctions/^/auc"]);
+ my $copy = substr($txt, 0, 246);
+ my @all = $o->feed($copy);
+ print $copy ."\n";
+ print Dumper(\@all);
+ print Dumper($o->root);
+}
+my ($begin,$duration);
+
+if ($TestJsonxs) {
+ $begin = time();
+ foreach (0..$Iterations) {
+ my $res = decode_json($txt);
+ }
+ $duration = time() - $begin;
+ printf("$Iterations Iterations: JSON::XS %0.2f\n", $duration);
+}
+
+if ($TestJsonsl) {
+ $begin = time();
+ foreach (0..$Iterations) {
+ my $res = JSON::SL::decode_json($txt);
+ }
+ my $duration = time() - $begin;
+ printf("$Iterations Iterations: JSON::SL %0.2f\n", $duration);
+}
+
+my @Chunks;
+if ($TestChunks) {
+ my $copy = $txt;
+ while ($copy) {
+ my $len = length($copy);
+ my $chunk = $TestChunks;
+ $chunk = $len if $chunk > $len;
+ my $frag = substr($copy, 0, $chunk);
+ $copy = substr($copy, $chunk);
+ push @Chunks, $frag;
+ }
+
+ printf("Testing chunked/incremental parsing with %d %dB chunks\n",
+ scalar @Chunks, $TestChunks);
+ if ($TestJsonxs) {
+ $begin = time();
+ my $xs = JSON::XS->new();
+ for (0..$Iterations) {
+ $xs->incr_reset();
+ foreach my $chunk (@Chunks) {
+ last if !$chunk;
+ my @o = $xs->incr_parse($chunk);
+ }
+ }
+ $duration = time() - $begin;
+ printf("$Iterations iterations: JSON::XS %0.2f\n",
+ $duration);
+ }
+
+ if ($TestJsonsl) {
+ my $sl = JSON::SL->new($RecursionLimit);
+ $begin = time();
+
+ for (0..$Iterations) {
+ $sl->reset();
+ foreach my $chunk (@Chunks) {
+ last if !$chunk;
+ my @o = $sl->feed($chunk);
+ }
+ }
+ $duration = time() - $begin;
+ printf("$Iterations iterations: JSON::SL %0.2f\n",
+ $duration);
+ }
+}
12 ignore.txt
@@ -0,0 +1,12 @@
+blib*
+Makefile
+Makefile.old
+Build
+Build.bat
+_build*
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+JSON-SL-*
13 json-sl.kpf
@@ -0,0 +1,13 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!-- Komodo Project File - DO NOT EDIT -->
+<project id="06fc1957-533b-4ba9-804d-36bd4df6664c" kpf_version="4" name="json-sl.kpf">
+<preference-set idref="06fc1957-533b-4ba9-804d-36bd4df6664c">
+ <string id="import_exclude_matches">*.*~;*.bak;*.tmp;CVS;.#*;*.pyo;*.pyc;.svn;*%*;tmp*.html;.DS_Store</string>
+ <string id="import_include_matches"></string>
+ <boolean id="import_live">1</boolean>
+ <boolean id="import_recursive">1</boolean>
+ <string id="import_type">useFolders</string>
+ <string id="perlExtraPaths">/usr/local/share/perl/5.10.1:/usr/local/lib/perl/5.10.1:/home/mordy/src/JSON-SL:/home/mordy/src/JSON-SL/lib:/home/mordy/src/JSON-SL/blib/lib:/home/mordy/src/JSON-SL/blib/arch/auto:/home/mordy/src/JSON-SL/blib/arch</string>
+ <boolean id="perl_lintOption_includeCurrentDirForLinter">1</boolean>
+</preference-set>
+</project>
1 jsonsl.c
1 jsonsl.h
240 jsonxs_inline.h
@@ -0,0 +1,240 @@
+/**
+ * This header file contains static functions adapted from
+ * Marc Lehmanns' JSON::XS, particularly because it's fast,
+ * doesn't seem to rely on any external structures, and because
+ * numeric conversions aren't my ideas of fun.
+ */
+
+#ifndef JSONXS_INLINE_H_
+#define JSONXS_INLINE_H_
+
+#include "perl-jsonsl.h"
+#if __GNUC__ >= 3
+# define expect(expr,value) __builtin_expect ((expr), (value))
+# define INLINE static inline
+#else
+# define expect(expr,value) (expr)
+# define INLINE static
+#endif
+
+#define ERR die
+#define expect_false(expr) expect ((expr) != 0, 0)
+#define expect_true(expr) expect ((expr) != 0, 1)
+
+#define jsonxs__atof_scan1(...) jsonxs__atof_scan1_THX(aTHX_ __VA_ARGS__)
+INLINE void
+jsonxs__atof_scan1_THX(pTHX_ const char *s,
+ NV *accum, int *expo, int postdp,
+ int maxdepth)
+{
+ UV uaccum = 0;
+ int eaccum = 0;
+
+ // if we recurse too deep, skip all remaining digits
+ // to avoid a stack overflow attack
+ if (expect_false (--maxdepth <= 0))
+ while (((U8)*s - '0') < 10)
+ ++s;
+
+ for (;;)
+ {
+ U8 dig = (U8)*s - '0';
+
+ if (expect_false (dig >= 10))
+ {
+ if (dig == (U8)((U8)'.' - (U8)'0'))
+ {
+ ++s;
+ jsonxs__atof_scan1(s, accum, expo, 1, maxdepth);
+ }
+ else if ((dig | ' ') == 'e' - '0')
+ {
+ int exp2 = 0;
+ int neg = 0;
+
+ ++s;
+
+ if (*s == '-')
+ {
+ ++s;
+ neg = 1;
+ }
+ else if (*s == '+')
+ ++s;
+
+ while ((dig = (U8)*s - '0') < 10)
+ exp2 = exp2 * 10 + *s++ - '0';
+
+ *expo += neg ? -exp2 : exp2;
+ }
+
+ break;
+ }
+
+ ++s;
+
+ uaccum = uaccum * 10 + dig;
+ ++eaccum;
+
+ // if we have too many digits, then recurse for more
+ // we actually do this for rather few digits
+ if (uaccum >= (UV_MAX - 9) / 10)
+ {
+ if (postdp) *expo -= eaccum;
+ jsonxs__atof_scan1 (s, accum, expo, postdp, maxdepth);
+ if (postdp) *expo += eaccum;
+
+ break;
+ }
+ }
+
+ // this relies greatly on the quality of the pow ()
+ // implementation of the platform, but a good
+ // implementation is hard to beat.
+ // (IEEE 754 conformant ones are required to be exact)
+ if (postdp) *expo -= eaccum;
+ *accum += uaccum * Perl_pow (10., *expo);
+ *expo += eaccum;
+}
+
+#define jsonxs__atof(...) jsonxs__atof_THX(aTHX_ __VA_ARGS__)
+INLINE NV
+jsonxs__atof_THX (pTHX_ const char *s)
+{
+ NV accum = 0.;
+ int expo = 0;
+ int neg = 0;
+
+ if (*s == '-')
+ {
+ ++s;
+ neg = 1;
+ }
+
+ // a recursion depth of ten gives us >>500 bits
+ jsonxs__atof_scan1(s, &accum, &expo, 0, 10);
+
+ return neg ? -accum : accum;
+}
+
+#define jsonxs_inline_process_number(...) jsonxs_inline_process_number_THX(aTHX_ __VA_ARGS__)
+
+INLINE SV *
+jsonxs_inline_process_number_THX(pTHX_ const char *start)
+{
+
+ int is_nv = 0;
+ const char *c = start;
+
+ if (*c == '-')
+ ++c;
+
+ if (*c == '0') {
+ ++c;
+ if (*c >= '0' && *c <= '9') {
+ ERR("malformed number (leading zero must not be followed by another digit)");
+ }
+ } else if (*c < '0' || *c > '9') {
+ ERR("malformed number (no digits after initial minus)");
+ } else {
+ do {
+ ++c;
+ } while (*c >= '0' && *c <= '9');
+ }
+
+ if (*c == '.') {
+ ++c;
+
+ if (*c < '0' || *c > '9')
+ ERR("malformed number (no digits after decimal point)");
+
+ do {
+ ++c;
+ } while (*c >= '0' && *c <= '9');
+
+ is_nv = 1;
+ }
+
+ if (*c == 'e' || *c == 'E') {
+ ++c;
+
+ if (*c == '-' || *c == '+')
+ ++c;
+
+ if (*c < '0' || *c > '9')
+ ERR("malformed number (no digits after exp sign)");
+
+ do {
+ ++c;
+ } while (*c >= '0' && *c <= '9');
+
+ is_nv = 1;
+ }
+
+ if (!is_nv) {
+ int len = c - start;
+
+ // special case the rather common 1..5-digit-int case
+ if (*start == '-')
+ switch (len) {
+ case 2:
+ return newSViv (-(IV)( start [1] - '0' * 1));
+ case 3:
+ return newSViv (-(IV)( start [1] * 10 + start [2] - '0' * 11));
+ case 4:
+ return newSViv (-(IV)( start [1] * 100 + start [2] * 10 + start [3] - '0' * 111));
+ case 5:
+ return newSViv (-(IV)( start [1] * 1000 + start [2] * 100 + start [3] * 10 + start [4] - '0' * 1111));
+ case 6:
+ return newSViv (-(IV)(start [1] * 10000 + start [2] * 1000 + start [3] * 100 + start [4] * 10 + start [5] - '0' * 11111));
+ }
+ else
+ switch (len) {
+ case 1:
+ return newSViv ( start [0] - '0' * 1);
+ case 2:
+ return newSViv ( start [0] * 10 + start [1] - '0' * 11);
+ case 3:
+ return newSViv ( start [0] * 100 + start [1] * 10 + start [2] - '0' * 111);
+ case 4:
+ return newSViv ( start [0] * 1000 + start [1] * 100 + start [2] * 10 + start [3] - '0' * 1111);
+ case 5:
+ return newSViv ( start [0] * 10000 + start [1] * 1000 + start [2] * 100 + start [3] * 10 + start [4] - '0' * 11111);
+ }
+
+ {
+ UV uv;
+ int numtype = grok_number (start, len, &uv);
+ if (numtype & IS_NUMBER_IN_UV
+ )
+ if (numtype & IS_NUMBER_NEG)
+ {
+ if (uv < (UV) IV_MIN
+ )
+ return newSViv (-(IV)uv);
+ } else
+ return newSVuv (uv);
+ }
+
+ len -= *start == '-' ? 1 : 0;
+
+ // does not fit into IV or UV, try NV
+ if (len <= NV_DIG
+ )
+ // fits into NV without loss of precision
+ return newSVnv (jsonxs__atof (start));
+
+ // everything else fails, convert it to a string
+ return newSVpvn (start, c - start);
+ }
+
+ // loss of precision here
+ return newSVnv (jsonxs__atof (start));
+ fail: return 0;
+}
+
+#undef ERR
+#undef expect_false
+#undef expect_true
+
+#endif /* JSONXS_INLINE_H_ */
442 lib/JSON/SL.pm
@@ -0,0 +1,442 @@
+package JSON::SL;
+
+use warnings;
+use strict;
+our $VERSION;
+use base qw(Exporter);
+our @EXPORT_OK = qw(decode_json unescape_json_string);
+
+BEGIN {
+ $VERSION = '0.0_1';
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
+}
+
+sub CLONE_SKIP {
+ return 1;
+}
+
+sub unescape_settings {
+ my ($self,$c) = @_;
+ if (!defined $c) {
+ require JSON::SL::EscapeTH;
+ my $ret = {};
+ tie(%$ret, 'JSON::SL::EscapeTH', $self);
+ return $ret;
+ } else {
+ $c = ord($c);
+ if (@_ == 3) {
+ return $self->_escape_table_chr($c, $_[2]);
+ } else {
+ return $self->_escape_table_chr($c);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+JSON::SL - Fast, Streaming, and Searchable JSON decoder.
+
+=head1 SYNOPSIS
+
+ # An incomplete stream..
+
+ my $txt = <<'EOT'
+ {
+ "some" : {
+ "partial" : [42]
+ },
+ "other" : {
+ "partial" : "a string"
+ },
+ "more" : {
+ "more" :
+ EOT
+
+ my $json = JSON::SL->new(512);
+ $json->set_jsonpointer( ["/some/^/partial"] );
+ my @results = $json->feed($txt);
+
+ $results[0]->{Value}->[0] == 42;
+ $results[1]->{Value} eq 'a string';
+
+ $results[0]->{Path} eq '/some/partial';
+ $results[1]->{Path} eq '/other/partial';
+
+=head2 DESCRIPTION
+
+JSON::SL was designed from the ground up to be easily accessible and
+searchable for partially received streamining content.
+
+It uses an embedded C library (C<jsonsl>) to do the streaming and most
+of the dirty work.
+
+JSON::SL allows you to use the
+L<JSONPointer|http://tools.ietf.org/html/draft-pbryan-zyp-json-pointer-02>
+URI/path syntax to tell it about certain objects and elements which are of
+interest to you. JSON::SL will then incrementally parse the input stream,
+returning those selected objects to you as soon as they arrive.
+
+In addition, the objects are returned with extra context information, which is
+itself another JSONPointer path specifying the path from the root of the JSON
+stream until the current object.
+
+Since I hate SAX's callback interface, and since almost all the boilerplate
+for a SAX interface needs to be done for just about every usage case, I have
+decided to move over the core work of state stacking and such to the C library
+itself. This means minimal boilerplate and ultra fast performance on your part.
+
+=head2 GENERIC METHODS
+
+=head3 new()
+
+=head3 new($max_levels)
+
+Creates a new C<JSON::SL> object
+
+If C<$max_levels> is provided, then it is taken as the maximum recursion depth
+the parser will be able to descend. This can only be set during construction time
+as it affects the amount of memory allocated for the internal structures.
+
+The amount of memory allocated for each structure is around 64 bytes on 64-bit
+(i.e. C<sizeof (char*) == 8>) systems
+and around 48 bytes on 32 bit (i.e. C<sizeof (char*) == 4>) systems.
+
+The default is 512, or a total of 32KB allocated
+
+=head3 set_jsonpointer(["/arrayref/of", "/json/paths/^"])
+
+Set the I<JSONPointer> query paths for this object. Note this can only be
+done once per the object's lifetime, and only before you have started calling
+the L</feed> method.
+
+The JSONPointer notation is quite simple, and follows URI scheme conventions.
+Each C</> represents a level of descent into an object, and each path component
+represents a hash key or array index (whether something is indeed a key or an
+index is derived from the context of the JSON stream itself, in case you were
+wondering).
+
+http://tools.ietf.org/html/draft-pbryan-zyp-json-pointer-02 Contains the draft
+for the JSONPointer specification.
+
+As an extension to the specification, C<JSON::SL> allows you to use the C<^>
+(caret) character as a wildcard. Placing the lone C<^> in any path component
+means to match any value in the current level, effectively providing glob-style
+semantics.
+
+=head3 feed($input_text)
+
+=head3 incr_parse($input_text)
+
+This is the meat and potatoes of C<JSON::SL>. Call it with C<$input> being a
+JSON input stream, with likely partial data.
+
+The module will do its magic and decode elements for you according to the queries
+set in L</set_jsonpointer>.
+
+If called in scalar context, returns one matching item from the partial stream.
+If called in list context, returns all remaining matching items.
+If called in void context, the JSON is still decoded, but nothing is returned.
+
+The return value is one or a list of (depending on the context) hash references
+with the following keys
+
+=over
+
+=item Value
+
+This is the actual value selected by the query. This can be a string, number,
+hash reference, array reference, undef, or a C<JSON::SL::Boolean> object.
+
+=item Path
+
+This is a JSONPointer path, which can be used to get context information (and
+perhaps be able to locate 'neighbors' in the object graph using L</root>).
+
+=item JSONPointer
+
+The original matching query path used to select this object. Can be used to
+associate this object with some extra user-defined context.
+
+=back
+
+N.B. C<incr_parse> is an alias to this method, for familiarity.
+
+=head3 fetch()
+
+Returns remaining decoded JSON objects. Returns the same kinds of things that
+L</feed> does (with the same semantics dependent on scalar and list context),
+except that it does not accept any arguments. This is helpful for a usage pattern
+as such:
+
+ $sl->feed($large_json);
+ while (my ($res = $sl->fetch)) {
+ # do something with the result object..
+ }
+
+
+=head3 reset()
+
+Resets the state. Any cached objects, result queues, and such are deleted and
+freed. Note that the JSONPointer query will still remain (and is static for
+the duration of the JSON::SL instance).
+
+=head2 OBJECT GRAPH INSPECTION AND MANIPULATION
+
+One of C<JSON::SL>'s features is the ability to get a perl-representation of
+incomplete JSON data. As soon as a JSON element can be converted to some kind of
+shell which resembles a Perl object, it is inserted into the object graph, or
+object tree
+
+=head3 root()
+
+This returns the partial object graph formed from the JSON stream. In other words,
+this is the object tree.
+
+Items whihc have been selected to be filtered via L</set_jsonpointer> are not
+present in this object graph, and neither are incomplete strings.
+
+It is an error to modify anything in the object returned by root, and Perl will
+croak if you try so with an 'attempted modification of read-only value' error.
+(but see L</make_referrent_writeable> for a way to override this)
+
+Nevertheless it is useful to get a glimpse of the 'rest' of the JSON document
+not returned via the feed method
+
+=head3 referrent_is_writeable($ref)
+
+Returns true if the object pointed to by C<$ref> has the C<SvREADONLY> flag
+off. In other words, if the flag is off then it is safe to modify its contents.
+
+=head3 make_referrent_writeable($ref)
+
+=head3 make_referrent_readonly($ref)
+
+Convenience methods to make the perl variable referred to by C<$ref> read-only
+or writeable.
+
+C<make_referrent_writeable> will make the object pointed to by C<$ref> as
+writeable, and C<make_referrent_readonly> will make the object pointed to by
+C<$ref> as readonly.
+
+You may 'poll' to see when an object has become writeable by doing the following
+
+ 1) Locate your initial object in the object graph using my $v = $sl->root()
+ 2) Check its initial status by using $sl->referrent_is_writeable($v)
+ 3) Stash the reference somewhere, and repeat step 2 as necessary.
+
+Using the C<make_referrent_writeable> you may modify the object graph as needed.
+Modification of the object graph is not always safe and performing disallowed
+modifications can make your application crash (which is why incomplete objects
+are marked as read-only in the first place).
+
+In the event where you need to make modifications to the object graph, following
+these guidelines will prevent an application crash:
+
+=over
+
+=item Strings, Integers, Booleans
+
+These are always safe to modify (and will never be read-only) because they are
+only inserted into the object graph once they have completed.
+
+=item Hash Keys
+
+Deleting hash keys which point to placeholders (represented as C<undef>) will
+change the hash key for the real value, once that value is completed.
+
+=item Hashes, Arrays
+
+Removing an array element or hash value which is 1) a container (hash or array),
+and 2) was read-only I<will crash your application>. Perl will destroy the
+container when it goes out of scope from your function. However, C<JSON::SL> will
+continue to reference it inside its internal structures, so do not do this.
+
+Adding a hash value/key to the hash is permitted, but the value may become
+clobbered when and if an actual key-value pair is detected from the JSON input
+stream.
+
+I<Prepending> (i.e. C<unshift>ing) to an array is permitted. I<Appending>
+(i.e. C<push>ing) to an array is only safe if you are sure that none of the
+elements of the array are potential I<JSONPointer> query matches. JSONPointer
+matches for array indices will internall pop the current (i.e. last) element
+of the array and return it from L</feed>.
+
+=back
+
+=head2 OPTION GETTERS AND SETTERS
+
+=head3 utf8()
+
+=head3 utf8(boolean)
+
+Get or set the current status of the C<SvUTF8> flag as it is applied to the strings
+returned by C<JSON::SL>. If set to true, then input and output will be assumed to
+be encoded in utf8
+
+=head3 noqstr()
+
+=head3 noqstr(boolean)
+
+Get/Set whether the C<JSONPointer> field is populated in the hash returned by
+L</feed>. Turning this on (i.e. leaving out the C<JSONPointer> field) may gain
+some performance
+
+=head3 nopath()
+
+=head3 nopath(boolean)
+
+Get/Set whether path information (the C<Path> field) is populated in the hash
+returned by L</feed>. Turning this on (i.e. leaving out path information) may
+boost performance, but will also leave you in the dark in regards to where/what
+your object is.
+
+=head3 max_size()
+
+=head3 max_size(limit)
+
+This functions exactly like L<JSON::XS>'s method of the same name.
+To quote:
+
+ Set the maximum length a JSON text may have (in bytes) where decoding is
+ being attempted. The default is C<0>, meaning no limit. When C<decode>
+ is called on a string that is longer then this many bytes, it will not
+ attempt to decode the string but throw an exception.
+
+ ...
+
+ If no argument is given, the limit check will be deactivated (same as when
+ C<0> is specified).
+
+ See SECURITY CONSIDERATIONS in L<JSON::XS>, for more info on why this is useful.
+
+
+
+=head3 unescape_settings()
+
+=head3 unescape_settings($character)
+
+=head3 unescape_settings($character, $boolean)
+
+Inspects and modifies the preferences for unescaping JSON strings. JSON allows
+several forms of escape sequences, either via the C<\uXXXX> form, or via a two-
+character 'common' form for specific characters.
+
+=head4 DEFAULT UNESCAPING BEHAVIOR
+
+For C<\uXXXX> escapes, the single or multi-byte representation of the encoded
+character is placed into the resultant string, thus:
+
+ \u0041 becomes A
+
+For JSON structural tokens, the backslash is swallowed and the character following
+it is left as-is. JSON I<requires> that these characters be escaped.
+
+ \" becomes "
+ \\ becomes \
+
+
+Additionally, JSON allows the C</> character to be escaped (though it is not
+a JSON structural token, and does not require escaping).
+
+ \/ becomes /
+
+For certain allowable control and whitespace characters, the escape is translated
+into its corresponding ASCII value, thus:
+
+ \n becomes chr(0x0A) <LF>
+ \r becomes chr(0x0D) <CR>
+ \t becomes chr(0x09) <TAB>
+ \b becomes chr(0x08) <Backspace>
+ \f becomes chr(0x0C) <Form Feed>
+
+Any other two-character escape sequence is not allowed, and JSON::SL will croak
+upon encountering it.
+
+By default, all that is allowed to be escaped is also automatically unescaped,
+but this behavior is configurable via the C<unescape_settings>
+
+Called without any arguments, C<unescape_settings> returns a reference to a hash.
+Its keys are valid ASCII characters and its values are booleans
+indicating whether C<JSON::SL> should treat them specially if they follow a C<\>.
+
+Thus, to disable special handling for newlines and tabs:
+
+ delete @{$json->unescape_settings}{"\t","\n","\r"};
+
+
+If C<unescape_settings> is called with one or two arguments, the first argument
+is taken as the character, and the second argument (if present) is taken as a
+boolean value which the character should be set to:
+
+Check if forward-slashes are unescaped:
+
+ my $fwslash_is_unescaped = $json->unescape_settings("/");
+
+
+Disable handling for C<\uXXXX> sequences:
+
+ $json->unescape_settings("u", 0);
+
+=head2 UTILITY FUNCTIONS
+
+These functions are not object methods but rather exported functions.
+You may export them on demand or use their fully-qualified name
+
+=head3 decode_json($json)
+
+Decodes a JSON string and returns a Perl object. This really doesn't serve much
+use, and L<JSON::XS> is faster than this. Nevertheless it eliminates the need
+to use two modules if all you want to do is decode JSON.
+
+=head3 unescape_json_string($string)
+
+Unescapes a JSON string, translating C<\uXXXX> and other compliant escapes
+to their actual character/byte representation. Returns the converted string,
+undef if the input was empty. Dies on invalid input.
+
+ my $str = "\\u0041";
+ my $unescaped = unescape_json_string($str);
+ # => "A"
+
+Both L</decode_json> and L</feed> output already-unescaped strings, so there is
+no need to call this function on strings returned by those methods.
+
+=head1 BUGS
+
+This will most likely not work with threads, although one would wonder why
+you would want to use this module across threads.
+
+When inspecting the object tree, you may see some C<undef> values, and it
+is impossible to determine whether those values are JSON C<null>s, or
+placeholder values. It would be possible to implement a class e.g.
+C<JSON::SL::Placeholder>, but doing so would either be unsafe or incur
+additional overhead.
+
+The C<^> caret is somewhat obscure as a wildcard character
+
+Currently wildcard matching is all-or-nothing, meaning that constructs such
+as C<foo^> will not work.
+
+
+=head1 SEE ALSO
+
+L<JSON::XS> - Still faster than this module
+
+If you wish to aid in the development of the JSON parser, do B<not> modify
+the source files in the perl distribution, they are merely copied over from
+here:
+
+L<jsonsl | https://github.com/mnunberg/jsonsl> - C core for JSON::SL
+
+
+=head1 AUTHOR & COPYRIGHT
+
+Copyright (C) 2012 M. Nunberg
+
+This module contains extracts from L<JSON::XS>, nevertheless they are both
+licensed under the same terms as Perl itself.
53 lib/JSON/SL/EscapeTH.pm
@@ -0,0 +1,53 @@
+package JSON::SL::EscapeTH;
+use strict;
+use warnings;
+
+sub TIEHASH {
+ my ($cls,$o) = @_;
+ my $self = bless { pjsn => $o }, $cls;
+ return $self;
+}
+
+sub STORE {
+ my $self = $_[0];
+ $self->{pjsn}->_escape_table_chr(ord($_[1]), $_[2]);
+}
+
+sub FETCH {
+ my $self = $_[0];
+ my $c = $_[1];
+ # always unescape RFC 4627-mandated escaped characters
+ $self->{pjsn}->_escape_table_chr(ord($_[1]));
+}
+
+sub EXISTS {
+ goto &FETCH;
+}
+
+sub DELETE {
+ $_[2] = 0;
+ goto &STORE;
+}
+
+sub FIRSTKEY {
+ my $self = $_[0];
+ $self->{idx} = -1;
+ $self->NEXTKEY;
+}
+
+sub NEXTKEY {
+ my $self = $_[0];
+ return if ++$self->{idx} > 0x7f;
+ chr($self->{idx});
+}
+
+sub SCALAR {
+ '127/127';
+}
+
+sub CLEAR {
+ my $self = $_[0];
+ $self->{pjsn}->_escape_table_chr($_, 0) foreach (0..0x7f);
+}
+
+1;
10 lib/JSON/SL/Tuba.pm
@@ -0,0 +1,10 @@
+package JSON::SL::Tuba;
+use strict;
+use warnings;
+use JSON::SL;
+
+sub _do_callout {
+ my ($self,$cbname,$cbdata) = @_;
+}
+
+1;
203 perl-jsonsl.h
@@ -0,0 +1,203 @@
+#ifndef PERL_JSONSL_H_
+#define PERL_JSONSL_H_
+#define PERL_NO_GET_CONTEXT
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+/**
+ * Default depth limit to use, if none supplied
+ */
+#define PLJSONSL_MAX_DEFAULT 512
+
+/**
+ * Key names for the information returned by
+ * JSONpointer results
+ */
+#define PLJSONSL_INFO_KEY_PATH "Path"
+#define PLJSONSL_INFO_KEY_VALUE "Value"
+#define PLJSONSL_INFO_KEY_QUERY "JSONPointer"
+
+/**
+ * Names of various perl globs
+ */
+#define PLJSONSL_CLASS_NAME "JSON::SL"
+#define PLJSONSL_BOOLEAN_NAME "JSON::SL::Boolean"
+#define PLJSONSL_PLACEHOLDER_NAME "JSON::SL::Placeholder"
+
+#define PLTUBA_CLASS_NAME "JSON::SL::Tuba"
+#define PLTUBA_HELPER_FUNC "JSON::SL::Tuba::_plhelper"
+
+/**
+ * Extended fields for a stack state
+ * sv: the raw SV (never a reference)
+ * u_loc.idx / u_loc.key: the numerical index or the HE key, depending
+ * on parent type.
+ * matchres: the result of the last match
+ * matchjpr: the jsonsl_jpr_t object (assuming a successful match [COMPLETE] )
+ */
+#define JSONSL_STATE_USER_FIELDS \
+ SV *sv; \
+ union { \
+ int idx; \
+ HE *key; \
+ } u_loc; \
+ int matchres; \
+ int uescapes; \
+ jsonsl_jpr_t matchjpr;
+
+/**
+ * We take advantage of the JSONSL_API and make all symbols
+ * non-exportable
+ */
+#define JSONSL_API static
+#include "jsonsl.h"
+#include "jsonsl.c"
+
+/**
+ * For threaded perls, this stores the THX/my_perl context
+ * inside the object's pl_thx field. For non threaded perls,
+ * this is a nop.
+ */
+#ifndef tTHX
+#define tTHX PerlInterpreter*
+#endif
+
+#ifdef PERL_IMPLICIT_CONTEXT
+#define PLJSONSL_dTHX(pjsn) \
+ pTHX = (tTHX)pjsn->pl_thx
+#define PLJSONSL_mkTHX(pjsn) \
+ pjsn->pl_thx = my_perl;
+#else
+#define PLJSONSL_dTHX(pjsn)
+#define PLJSONSL_mkTHX(pjsn)
+#endif /* PERL_IMPLICIT_CONTEXT */
+
+typedef struct {
+ /* Our lexer */
+ jsonsl_t jsn;
+
+ /* Root perl data structure. This is either an HV* or AV* */
+ SV *root;
+
+ /* Backlog buffer, for large strings, 'special' data, \u-escaping,
+ * and other fun stuff
+ */
+
+ SV *buf;
+
+ /* The minimum valid position. Offsets smaller than this do not
+ * point to valid data anymore
+ */
+ size_t pos_min_valid;
+
+ /* Minimum backlog position */
+ size_t keep_pos;
+
+ /**
+ * "current" hash key. This is always a pointer to an HE* of an existing
+ * hash entry, and thus should never be freed/destroyed directly.
+ * This variable should only be non-null during until the next PUSH
+ * callback
+ */
+ HE *curhk;
+
+ /**
+ * For older perls not exposing hv_common, we need a key sv.
+ * make this as efficient as possible.
+ */
+ SV *ksv;
+ char *ksv_origpv;
+
+ /* Stash for booleans */
+ HV *stash_boolean;
+
+ /* Context (THX) for threaded perls */
+ void *pl_thx;
+
+ /**
+ * Variables the user might set or be interested in (via function calls,
+ * of course) are here:
+ */
+ struct {
+ int utf8; /** Set the SvUTF8 flag */
+ int nopath; /** Don't include path context in results */
+ int noqstr; /** Don't include original query string in results */
+ int max_size;
+ } options;
+
+ /**
+ * Private options
+ */
+ struct {
+ /* whether this is the 'global' JSON::SL object used
+ * for decode_json()
+ */
+ int is_global;
+ } priv_global;
+
+ /**
+ * If we allocate a bunch of JPR objects, keep a reference to
+ * them here in order to destroy them along with ourselves.
+ */
+ jsonsl_jpr_t *jprs;
+ size_t njprs;
+
+ /**
+ * This is the 'result stack'
+ */
+ AV *results;
+
+ /**
+ * Escape preferences
+ */
+ int escape_table[0x80];
+} PLJSONSL;
+
+typedef enum {
+#define X(o,c) \
+ PLTUBA_CALLBACK_##o = c,
+ JSONSL_XTYPE
+#undef X
+ PLTUBA_CALLBACK_CHARACTER = 'c',
+ PLTUBA_CALLBACK_ERROR = '!',
+ PLTUBA_CALLBACK_DOCUMENT = 'D'
+} pltuba_callback_type;
+
+/**
+ * This can be considered to be a 'subset' of the
+ * PLJSONSL structure, but with some slight subtleties and
+ * differences.
+ */
+typedef struct {
+ jsonsl_t jsn;
+
+ /* Position at which our last callback was invoked */
+ size_t last_cb_pos;
+
+ /* position at which the last call to feed was made */
+ size_t buf_pos;
+
+ /**
+ * In cases (or actually, usually) when 'character' data is at
+ * some kind of beginning, the first character is the opening
+ * token itself, usually a quote. this variable defines an
+ * offset (either 1 or 0) for which data is to actually be
+ * delivered to the user.
+ */
+ ssize_t chardata_begin_offset;
+
+ /* Buffer containing data to be dispatched */
+ SV *buf;
+
+ /* my_perl, for threaded perls */
+ void *pl_thx;
+
+ /* Options */
+ struct {
+ int utf8;
+ } options;
+} PLTUBA;
+
+#endif /* PERL_JSONSL_H_ */
7,063 ppport.h
7,063 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
10 t/00-load.t
@@ -0,0 +1,10 @@
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'JSON::SL' ) || print "Bail out!
+";
+}
+
+diag( "Testing JSON::SL $JSON::SL::VERSION, Perl $], $^X" );
41 t/01-synopsis.t
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+use JSON::SL;
+use Data::Dumper;
+use Devel::Peek;
+
+my $txt = <<'EOT';
+{
+ "some" : {
+ "partial" : [42]
+ },
+ "other" : {
+ "partial" : "a string"
+ },
+ "more" : {
+ "more" : "stuff"
+EOT
+
+my $json = JSON::SL->new(512);
+my $jpath = "/^/partial";
+$json->set_jsonpointer( [$jpath] );
+my @results = $json->feed($txt);
+
+is($results[0]->{Value}->[0], 42, "Got first value");
+is($results[1]->{Value}, 'a string', "Got second value");
+
+is($results[0]->{Path}, '/some/partial', "First path matches");
+is($results[1]->{Path}, '/other/partial', "Second path matches");
+
+ok($results[0]->{JSONPointer} eq $jpath
+ && $results[1]->{JSONPointer} eq $jpath,
+ "Both results share same JSONPointer ($jpath)");
+
+ok(exists $json->root->{some}, "Matching container still in root");
+ok(scalar keys %{$json->root->{some} } == 0, "but has no entries..");
+
+is($json->root->{more}->{more}, "stuff", "Still have some stuff there..");
+
+done_testing();
35 t/02-readonly.t
@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+use JSON::SL;
+use Devel::Peek;
+use Data::Dumper;
+
+my $sl = JSON::SL->new();
+my $h = {};
+my $v = [];
+
+ok($sl->referrent_is_writeable($h), "Hash is writeable");
+ok($sl->referrent_is_writeable(\$v), "Value (arrayref) is writeable");
+
+$h->{something} = $v;
+#make it read-only
+
+$sl->make_referrent_readonly($h);
+ok(!$sl->referrent_is_writeable($h), "Reference is read-only");
+
+