Browse files

Added some tuba tests.

Initialize hashrefs to &PL_sv_undef rather than &PL_sv_placeholder.
Also fixed numeric handling..q
  • Loading branch information...
1 parent 3454ad8 commit ee3f8a2fee00bee3a179a76585c9a562db3764e3 @mnunberg committed Apr 8, 2012
Showing with 287 additions and 36 deletions.
  1. +13 −0 LOCATION_OF_JSONSL_SOURCE
  2. +2 −0 MANIFEST
  3. +7 −1 SL.xs
  4. +3 −14 eg/tuba.pl
  5. +1 −1 lib/JSON/SL.pm
  6. +17 −2 lib/JSON/SL/Tuba.pm
  7. +3 −0 perl-jsonsl.h
  8. +14 −6 srcout/option_accessors.xs
  9. +12 −12 srcutil/accessors.pl
  10. +21 −0 t/40-tuba_basic.t
  11. +194 −0 t/41-tuba_accum_all.t
View
13 LOCATION_OF_JSONSL_SOURCE
@@ -0,0 +1,13 @@
+Because either me or git are retarded, instead of
+using git submodules, I will simply provide the
+link to the repository containing the source code
+for the jsonsl core code:
+
+https://github.com/mnunberg/jsonsl
+
+nb.
+
+the 'jsonsl' file is a symlink. When you check out
+the jsonsl source code, revive the symlink to point
+to that location..
+
View
2 MANIFEST
@@ -40,6 +40,8 @@ t/08-pc_esc.t
t/03-unescape.t
t/06-utf8.t
t/20-object_drip.t
+t/40-tuba_basic.t
+t/41-tuba_accum_all.t
eg/bench.pl
eg/synopsis.pl
View
8 SL.xs
@@ -943,6 +943,11 @@ pltuba_invoke_callback_THX(pTHX_ PLTUBA *tuba,
}
PUTBACK;
call_sv((SV*)GvCV(meth), G_DISCARD);
+ } else {
+ if (!tuba->options.allow_unhandled) {
+ die("Tuba: Cannot find handler for mode 0x%02x action 0x%02x",
+ effective_action, effective_type);
+ }
}
FREETMPS; LEAVE;
}
@@ -1246,7 +1251,8 @@ pltuba_initialize_THX(pTHX_ const char *pkg)
#define X(kname) \
sv_setpvs(ksv, #kname); \
- tmphe = hv_store_ent(tuba->paramhv, ksv, &PL_sv_placeholder, 0); \
+ tmphe = hv_store_ent(tuba->paramhv, ksv, &PL_sv_undef, 0); \
+ HeVAL(tmphe) = &PL_sv_placeholder; \
assert(tmphe); \
tuba->p_ents.pe_##kname.he = tmphe;
View
17 eg/tuba.pl
@@ -4,7 +4,6 @@ package My::Giant::Tuba;
use warnings;
use blib;
use JSON::SL::Tuba;
-use Log::Fu;
use Getopt::Long;
use Data::Dumper::Concise;
use utf8;
@@ -13,7 +12,7 @@ package My::Giant::Tuba;
'c|chunk=i' => \my $ChunkSize,
'i|iterations=i' => \my $Iterations,
'a|accumulate' => \my $AccumAll,
- 'q|quiet' => \$Log::Fu::SHUSH);
+ 'q|quiet' => \my $Silent);
our @ISA = qw(JSON::SL::Tuba);
my $JSON;
@@ -96,23 +95,13 @@ sub new {
}
open my $devnull, ">", "/dev/null";
-if ($Log::Fu::SHUSH) {
+if ($Silent) {
select $devnull;
}
foreach (1..$Iterations) {
- my $o = My::Giant::Tuba->new();
- #we want complete strings/numbers/booleans
- $o->accum_all(1);
-
- #we will be using a single callback for everything. Don't bother looking up
- #individual callbacks
- $o->cb_unified(1);
-
- #don't deliver the key as a separate event.
- $o->accum_kv(1);
-
+ my $o = My::Giant::Tuba->new();
$o->parse($_) for @Chunks;
}
View
2 lib/JSON/SL.pm
@@ -16,7 +16,7 @@ use base qw(Exporter);
our @EXPORT_OK = qw(decode_json unescape_json_string);
BEGIN {
- $VERSION = '0.0_4';
+ $VERSION = '0.0_5';
require XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);
}
View
19 lib/JSON/SL/Tuba.pm
@@ -48,9 +48,14 @@ our %CloseTokens = (
sub new {
my ($cls,%options) = @_;
my $o = $cls->_initialize();
- if (exists $options{accum_kv} and
+
+ unless (exists $options{accum_kv} and
not delete $options{accum_kv}) {
- $o->accum_kv(0);
+ $o->accum_kv(1);
+ }
+ unless (exists $options{accum_all}and
+ not delete $options{accum_all}) {
+ $o->accum_all(1);
}
while (my ($k,$v) = each %options) {
$o->can($k)->($o,$v);
@@ -85,6 +90,9 @@ sub accum_enabled_for {
sub accum_all {
my ($tuba,$boolean) = @_;
+ if (@_ != 2) {
+ die("Must have boolean argument!");
+ }
my %opts = map {
$_, $boolean
} ('=','~','#','?','"');
@@ -484,6 +492,13 @@ but should be turned on if you don't care about that fact.
Tell Tuba to set the C<SvUTF8> flag on strings.
+=head4 $tuba->allow_unhandled(boolean)
+
+By default, Tuba will croak if it cannot find a handler method for a given event
+(this effectively means the C<on_any> method has not been implemented). This is
+usually what you want. To disable this behavior, set C<allow_unhandled> to a true
+value.
+
=head2 Parsing Data
There is one method:
View
3 perl-jsonsl.h
@@ -6,6 +6,7 @@
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
+#include <limits.h>
/**
* Default depth limit to use, if none supplied
*/
@@ -36,6 +37,7 @@
#warning "You are using a Perl from the stone age. This code might work.."
#endif /* 5.10.0 */
+
/**
* Extended fields for a stack state
* sv: the raw SV (never a reference)
@@ -253,6 +255,7 @@ typedef struct {
int no_cache_mro;
int accum_kv;
int cb_unified;
+ int allow_unhandled;
} options;
#define PLTUBA_METHGV_STRUCT
View
20 srcout/option_accessors.xs
@@ -8,13 +8,15 @@ PROTOTYPES: DISABLED
#define PLTUBA_OPTION_IX_utf8 1
#define PLTUBA_OPTION_IX_no_cache_mro 2
#define PLTUBA_OPTION_IX_cb_unified 3
-
+#define PLTUBA_OPTION_IX_allow_unhandled 4
+
int
PLTUBA__options(PLTUBA* obj, ...)
ALIAS:
utf8 = PLTUBA_OPTION_IX_utf8
no_cache_mro = PLTUBA_OPTION_IX_no_cache_mro
cb_unified = PLTUBA_OPTION_IX_cb_unified
+ allow_unhandled = PLTUBA_OPTION_IX_allow_unhandled
CODE:
RETVAL = 0;
if (ix == 0) {
@@ -23,7 +25,7 @@ PLTUBA__options(PLTUBA* obj, ...)
if (items > 2) {
die("Usage: %s(o, ... boolean)", GvNAME(GvCV(cv)));
}
-
+
switch(ix) {
case PLTUBA_OPTION_IX_utf8:
RETVAL = obj->options.utf8;
@@ -43,12 +45,18 @@ PLTUBA__options(PLTUBA* obj, ...)
obj->options.cb_unified = SvIV(ST(1));
}
break;
+ case PLTUBA_OPTION_IX_allow_unhandled:
+ RETVAL = obj->options.allow_unhandled;
+ if (items == 2) {
+ obj->options.allow_unhandled = SvIV(ST(1));
+ }
+ break;
default:
die("Unrecognized IX!?");
break;
}
OUTPUT: RETVAL
-
+
MODULE = JSON::SL PACKAGE = JSON::SL PREFIX = PLJSONSL_
@@ -59,7 +67,7 @@ PROTOTYPES: DISABLED
#define PLJSONSL_OPTION_IX_noqstr 3
#define PLJSONSL_OPTION_IX_max_size 4
#define PLJSONSL_OPTION_IX_object_drip 5
-
+
int
PLJSONSL__options(PLJSONSL* obj, ...)
ALIAS:
@@ -76,7 +84,7 @@ PLJSONSL__options(PLJSONSL* obj, ...)
if (items > 2) {
die("Usage: %s(o, ... boolean)", GvNAME(GvCV(cv)));
}
-
+
switch(ix) {
case PLJSONSL_OPTION_IX_utf8:
RETVAL = obj->options.utf8;
@@ -113,4 +121,4 @@ PLJSONSL__options(PLJSONSL* obj, ...)
break;
}
OUTPUT: RETVAL
-
+
View
24 srcutil/accessors.pl
@@ -5,7 +5,7 @@
# both these structures have typemaps and a common 'options' field:
my @options = (
- ["PLTUBA", "JSON::SL::Tuba", [qw(utf8 no_cache_mro cb_unified)]],
+ ["PLTUBA", "JSON::SL::Tuba", [qw(utf8 no_cache_mro cb_unified allow_unhandled)]],
["PLJSONSL", "JSON::SL", [qw(utf8 nopath noqstr max_size object_drip)]]
);
@@ -23,22 +23,22 @@
PROTOTYPES: DISABLED
EOC
-
+
my $ix_counter = 1;
my @defines;
-
+
foreach my $optname (@$opts) {
push @defines, ["$ctype\_OPTION_IX_$optname", $ix_counter, $optname];
$ix_counter++;
}
-
+
foreach (@defines) {
my ($macro,$val) = @$_;
print "#define $macro $val\n";
}
-
+
print <<"EOC";
-
+
int
$ctype\__options($ctype* obj, ...)
ALIAS:
@@ -50,7 +50,7 @@
%-15s = %s
EOC
}
-
+
print <<"EOC";
CODE:
RETVAL = 0;
@@ -60,10 +60,10 @@
if (items > 2) {
die("Usage: %s(o, ... boolean)", GvNAME(GvCV(cv)));
}
-
+
switch(ix) {
EOC
-
+
foreach (@defines) {
my ($macro,$optname) = @{$_}[0,2];
print <<"EOC";
@@ -75,14 +75,14 @@
break;
EOC
}
-
+
print <<"EOC";
default:
die("Unrecognized IX!?");
break;
}
OUTPUT: RETVAL
-
+
EOC
-}
+}
View
21 t/40-tuba_basic.t
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More;
+use_ok("JSON::SL::Tuba");
+
+my $tuba = JSON::SL::Tuba->new();
+isa_ok($tuba, "JSON::SL::Tuba");
+
+#check defaults
+ok($tuba->accum_kv, "kv accum enabled by default");
+foreach my $sym ('=', '~', '?', '#', '"') {
+ ok($tuba->accum_enabled_for($sym),
+ "accum enabled for '$sym' by default");
+}
+
+ok(!$tuba->cb_unified, "cb_unified disabled by default");
+$tuba->allow_unhandled(1);
+$tuba->parse('["Hello World"]');
+ok(1, "didn't die (yay!)");
+done_testing();
View
194 t/41-tuba_accum_all.t
@@ -0,0 +1,194 @@
+#!/usr/bin/perl
+package MyTuba;
+use strict;
+use warnings;
+use Data::Dumper;
+
+use JSON::SL::Tuba;
+use Test::More;
+our @ISA = qw(JSON::SL::Tuba);
+
+my $ExpResults =
+#Compile a list of what we actually expect,
+#in terms of events..
+[
+ [
+ {
+ Mode => "+",
+ Type => "D"
+ }
+ ],
+ [
+ {
+ Mode => "+",
+ Type => "{"
+ }
+ ],
+ [
+ {
+ Key => "a",
+ Mode => ">",
+ Type => '"',
+ },
+ "b"
+ ],
+ [
+ {
+ Key => "c",
+ Mode => "+",
+ Type => "{"
+ }
+ ],
+ [
+ {
+ Key => "d",
+ Mode => ">",
+ Type => '"'
+ },
+ "e"
+ ],
+ [
+ {
+ Mode => "-",
+ Type => "{"
+ }
+ ],
+ [
+ {
+ Key => "f",
+ Mode => "+",
+ Type => "["
+ }
+ ],
+ [
+ {
+ Index => 0,
+ Mode => ">",
+ Type => "\""
+ },
+ "g"
+ ],
+ [
+ {
+ Index => 1,
+ Mode => ">",
+ Type => '"',
+ },
+ "h"
+ ],
+ [
+ {
+ Index => 2,
+ Mode => ">",
+ Type => '"'
+ },
+ "i"
+ ],
+ [
+ {
+ Index => 3,
+ Mode => ">",
+ Type => '"'
+ },
+ "j"
+ ],
+ [
+ {
+ Mode => "-",
+ Type => "["
+ }
+ ],
+ [
+ {
+ Key => "a number",
+ Mode => ">",
+ Type => "="
+ },
+ "0.4444444444"
+ ],
+ [
+ {
+ Key => "a (false) boolean",
+ Mode => ">",
+ Type => "?"
+ },
+ bless( do{\(my $o = 0)}, 'JSON::SL::Boolean' )
+ ],
+ [
+ {
+ Key => "another (true) boolean",
+ Mode => ">",
+ Type => "?"
+ },
+ bless( do{\(my $o = 1)}, 'JSON::SL::Boolean' )
+ ],
+ [
+ {
+ Key => "a null value",
+ Mode => ">",
+ Type => "~"
+ }
+ ],
+ [
+ {
+ Key => "exponential",
+ Mode => ">",
+ Type => "="
+ },
+ "13413.4"
+ ],
+ [
+ {
+ Key => "an\tescaped key",
+ Mode => ">",
+ Type => '"'
+ },
+ "a u-escaped value"
+ ],
+ [
+ {
+ Mode => "-",
+ Type => "{"
+ }
+ ],
+ [
+ {
+ Mode => "-",
+ Type => "D"
+ }
+ ]
+];
+
+#this tries to replicate the tests in eg/tuba.pl
+my $JSON ||= <<'EOJ';
+{
+ "a" : "b",
+ "c" : { "d" : "e" },
+ "f" : [ "g", "h", "i", "j" ],
+ "a number" : 0.4444444444,
+ "a (false) boolean": false,
+ "another (true) boolean" : true,
+ "a null value" : null,
+ "exponential" : 1.3413400E4,
+ "an\tescaped key" : "a u-\u0065\u0073caped value"
+}
+EOJ
+
+my @GotResults;
+
+sub on_any {
+ my ($tuba,$info,$data) = @_;
+
+ my $arry = [ { %$info } ];
+ if (@_ > 2) {
+ push @$arry, $data;
+ }
+ push @GotResults, $arry;
+}
+
+my $tuba = __PACKAGE__->new();
+$tuba->accum_all(1);
+$tuba->accum_kv(1);
+$tuba->parse($JSON);
+is_deeply(\@GotResults, $ExpResults, "Got expected results..");
+done_testing();

0 comments on commit ee3f8a2

Please sign in to comment.