CGI-Struct-XS-1.04/0000755000175000017500000000000012205755722012023 5ustar nufnufCGI-Struct-XS-1.04/Changes0000644000175000001440000000037312205755535013670 0ustar nufusersRevision history for CGI-Struct-XS 1.04 2013-07-24 support for solaris and win 1.03 2013-07-21 XSLoader v0.10 support thread safety fixes 1.02 2013-07-19 POD fixed 1.01 2013-07-18 First version CGI-Struct-XS-1.04/README.md0000644000175000001440000000010612200017656013634 0ustar nufuserscgi-struct-xs ============= cgi param names parser, implemented in c CGI-Struct-XS-1.04/META.yml0000664000175000017500000000111112205755722013270 0ustar nufnuf--- abstract: 'Build structures from CGI data. Fast.' author: - 'Dmitry Smal ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CGI-Struct-XS no_index: directory: - t - inc requires: Storable: 0 Test::Deep: 0 Test::Deep::NoTest: 0 Test::LeakTrace: 0 Test::More: 0 XSLoader: 0 version: 1.04 CGI-Struct-XS-1.04/META.json0000664000175000017500000000203312205755722013444 0ustar nufnuf{ "abstract" : "Build structures from CGI data. Fast.", "author" : [ "Dmitry Smal " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140", "license" : [ "bsd" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CGI-Struct-XS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Storable" : "0", "Test::Deep" : "0", "Test::Deep::NoTest" : "0", "Test::LeakTrace" : "0", "Test::More" : "0", "XSLoader" : "0" } } }, "release_status" : "stable", "version" : "1.04" } CGI-Struct-XS-1.04/t/0000755000175000017500000000000012205755721012265 5ustar nufnufCGI-Struct-XS-1.04/t/05-edges.t0000644000175000017500000000137412203752632013764 0ustar nufnuf#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 10; use Test::Deep; use CGI::Struct::XS; my @errs; my $hval; @errs = (); $hval = build_cgi_struct { "x\0" => 2 }, \@errs; cmp_deeply($hval, { "x\0" => 2 }); is(@errs, 0); @errs = (); $hval = build_cgi_struct { "\0" => 2 }, \@errs; cmp_deeply($hval, { "\0" => 2 }); is(@errs, 0); @errs = (); $hval = build_cgi_struct { "a" => "" }, \@errs, { nullsplit => 1 }; cmp_deeply($hval, { "a" => "" }); is(@errs, 0); @errs = (); $hval = build_cgi_struct { "a" => "\0" }, \@errs, { nullsplit => 1 }; cmp_deeply($hval, { "a" => ["", ""] }); is(@errs, 0); @errs = (); $hval = build_cgi_struct { "a" => "\0\0" }, \@errs, { nullsplit => 1 }; cmp_deeply($hval, { "a" => ["", "", ""] }); is(@errs, 0); CGI-Struct-XS-1.04/t/01-array.t0000644000175000001440000000213012204110723014331 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 18; use CGI::Struct::XS; # Test that a simple array gets built right my %inp = ( 'a[0]' => 'arr0', 'a[1]' => 'arr1', 'a[2]' => 'arr2', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is($hval->{a}[$_], $inp{"a[$_]"}, "a[$_] copied right") for 0..2; # Test NULL-splitting %inp = ( 'b' => "ab0\0ab1\0ab2", 'c.d' => "cd0\0cd1\0cd2", ); $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is(ref $hval->{b}, 'ARRAY', "b properly split into array"); is(ref $hval->{c}{d}, 'ARRAY', "c{d} properly split into array"); is($hval->{b}[$_], "ab$_", "b[$_] has expected value") for 0..2; is($hval->{c}{d}[$_], "cd$_", "c{d}[$_] has expected value") for 0..2; $hval = build_cgi_struct \%inp, \@errs, {nullsplit => 0}; is(@errs, 0, "No errors"); is(ref $hval->{b}, '', "b properly not split into array"); is($hval->{b}, $inp{b}, "b content cleanly copied"); is(ref $hval->{c}{d}, '', "c{d} properly not split into array"); is($hval->{c}{d}, $inp{'c.d'}, "c{d} content cleanly copied"); CGI-Struct-XS-1.04/t/05-leak.t0000644000175000017500000000162712204105634013605 0ustar nufnuf#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 4; use Test::LeakTrace; use CGI::Struct::XS; my $inp = { 'a' => 1, 'b.c' => 2, 'd[0]' => 3, 'd[4]' => 4, 'e{a}.x' => 5, 'e{a}.y' => 6, 'f{a}[0]' => 7, 'f{a}[1]' => 8, 'g[]' => 1, 'k[]' => ['a','b'], 'm' => "\0", 'n' => "\0\0", 'o' => { a => { b => 1 } }, }; no_leaks_ok { my @errs; my $hval = build_cgi_struct $inp, \@errs, { nullsplit => 0, nodot => 0, dclone => 0 }; }; no_leaks_ok { my @errs; my $hval = build_cgi_struct $inp, \@errs, { nullsplit => 1, nodot => 0, dclone => 0 }; }; no_leaks_ok { my @errs; my $hval = build_cgi_struct $inp, \@errs, { nullsplit => 0, nodot => 1, dclone => 0 }; }; no_leaks_ok { my @errs; my $hval = build_cgi_struct $inp, \@errs, { nullsplit => 0, nodot => 0, dclone => 1 }; }; CGI-Struct-XS-1.04/t/04-autoarr.t0000644000175000001440000000124712200645237014714 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 4; use CGI::Struct::XS; # Test autoarrays my %inp = ( # Array in the base 'a[]' => [qw(foo bar baz)], # One a couple levels down 'h{foo}[1]{bar}[]' => [qw(da1 da2)], # One with only a single element 'a2[]' => 'a2val', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); # These two just copy straight is_deeply($hval->{a}, $inp{'a[]'}, 'a[] correct'); is_deeply($hval->{h}{foo}[1]{bar}, $inp{'h{foo}[1]{bar}[]'}, 'h{foo}[1]{bar}[] correct'); # Make sure this becomes a (1-element) array, not a scalar is_deeply($hval->{a2}, ['a2val'], 'a2[] correct'); CGI-Struct-XS-1.04/t/05-bad.t0000644000175000001440000000437312201730161013761 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 14; use CGI::Struct::XS; # Test various bad inputs my %inp = ( # Mismatched delims 'h{foo]' => 'hashfoo', 'a[0}' => 'arr0', # Missing delim 'h{bar' => 'hbar', # Multiple delims in a row 'h{{{}' => 'wtf', # Non-integer array key 'a[bar]' => 'arrbar', 'a[0bar]' => 'arr0bar', # Bad starting char '{xyz' => 'badstart', # No key 'h{}' => 'nokey', 'h.' => 'dot nokey', 'h..' => 'dot dot nokey', 'h{foo}.{bar}' => 'nested dot nokey', # Create a mismatch 'm{xyz}' => 'mhash', 'm[1]' => 'marr', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; # Should have a warning about the mismatches ok(grep(/Not balanced delimiter for h\{foo\]/, @errs), "Got error for h{foo]"); ok(grep(/Not balanced delimiter for a\[0\}/, @errs), "Got error for a[0}"); # And the missing ok(grep(/Not balanced delimiter for h\{bar/, @errs), "Got error for h{bar"); # Multiple? ok(grep(/Not balanced delimiter for h\{\{\{}/, @errs), "Got error for h{{{}"); # Plus the non-integer keys ok(grep(/Array index should be a number for a\[bar\]/, @errs), "Got error for a[bar]"); ok(grep(/Array index should be a number for a\[0bar\]/, @errs), "Got error for a[0bar]"); # Bad starting char ok(grep(/Unexpected initial char '\{' for \{xyz/, @errs), "Got error for {xyz"); # No key ok(grep(/Zero-length key name for h\{}/, @errs), "Got error for h{}"); ok(grep(/Zero-length key name for h\./, @errs), "Got error for h."); ok(grep(/Zero-length key name for h\.\./, @errs), "Got error for h.."); ok(grep(/Zero-length key name for h\{foo}\.\{bar}/, @errs), "Got error for h{foo}.{bar}"); # This mismatch could come in either order my $ok = scalar(grep /Type mismatch: m already used as ArrayRef for m\{xyz\}/, @errs) || scalar(grep /Type mismatch: m already used as HashRef for m\[1\]/, @errs); ok($ok, "Got error for m{xyz}"); # Every line but one (the key that creates the mismatched type for that # test) should have an entry in the @errs. is(@errs, keys(%inp) - 1, "An error for every input"); # We get 3 entries in the output hash; 1 for the mismatched type, and 1 # each for 'h' and 'a' that get far enough to be created. is(keys %$hval, 3, "Only expected litter in the output"); CGI-Struct-XS-1.04/t/01-directcopy.t0000644000175000001440000000113412200020607015360 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 5; use CGI::Struct::XS; # Test that simple stuff gets properly and directly copied my %inp = ( 'foo' => 'bar', 'fooarr' => [qw(foo bar baz)], 'trail}' => 'trailing brace', 'trail]' => 'trailing bracket', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is($hval->{foo}, $inp{foo}, "foo copied right"); is(@{$hval->{fooarr}}, @{$inp{fooarr}}, "fooarr copied right"); is($hval->{'trail}'}, $inp{'trail}'}, "trail} copied right"); is($hval->{'trail]'}, $inp{'trail]'}, "trail] copied right"); CGI-Struct-XS-1.04/t/00-pod.t0000644000175000001440000000035012200020607013773 0ustar nufusers#!perl -T use strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); CGI-Struct-XS-1.04/t/03-multihash.t0000644000175000001440000000075312200020607015221 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 5; use CGI::Struct::XS; # Test that multi-level hashes gets built right my %inp = ( 'h{foo}{bill}' => 'hfoo_bill', 'h{foo}{ted}' => 'hfoo_ted', 'h{bar}{bill}' => 'hbar_bill', 'h{bar}{ted}' => 'hbar_ted', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); for my $k (qw/foo bar/) { is($hval->{h}{$k}{$_}, $inp{"h{$k}{$_}"}, "h{$k}{$_} copied right") for qw/bill ted/; } CGI-Struct-XS-1.04/t/01-hash.t0000644000175000001440000000060212200020607014135 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 4; use CGI::Struct::XS; # Test that a simple hash gets built right my %inp = ( 'h{foo}' => 'hashfoo', 'h{bar}' => 'hashbar', 'h{baz}' => 'hashbaz', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is($hval->{h}{$_}, $inp{"h{$_}"}, "h{$_} copied right") for qw/foo bar baz/; CGI-Struct-XS-1.04/t/05-copies.t0000644000175000001440000000213412200020607014502 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 4; use Test::Deep::NoTest; use Storable qw(dclone); use CGI::Struct::XS; # Test that all inputs are deep-copied, so the original struct never gets # touched. my %_inp = ( 'x' => 'y', 'ar' => [ 'ab', 'cd' ], 'hr' => { 'qw' => 'er', 'ty' => { 'ui' => 'op' } }, 'tl.lt' => [ 'zx', 'cv' ], ); my %inp = %{dclone(\%_inp)}; my @errs; my $hval; # Handy func to do our frobbing sub adjhval { push @{$hval->{ar}}, 'ef'; $hval->{hr}{as} = 'df'; push @{$hval->{tl}{lt}}, 'bn'; return; } # OK, start translating $hval = build_cgi_struct \%inp, \@errs; # Should have no problems is(@errs, 0, "No errors"); # Overwrite some stuff in the returned struct adjhval(); # Make sure we didn't change the original is_deeply(\%inp, \%_inp, 'The same'); # Start over, but this time _don't_ deep-clone $hval = build_cgi_struct \%inp, \@errs, {dclone => 0}; # Should have no problems is(@errs, 0, "No errors"); # Try overwriting now adjhval(); # Original _should_ have changed ok(!eq_deeply(\%inp, \%_inp), 'Changed with dclone=0'); CGI-Struct-XS-1.04/t/02-hashofarray.t0000644000175000001440000000106512200020607015526 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 9; use CGI::Struct::XS; # Test hashes of arrays my %inp = ( 'h{friends}[0]' => 'james', 'h{friends}[1]' => 'jill', 'h{friends}[2]' => 'joe', 'h{friends}[3]' => 'judy', 'h{enemies}[0]' => 'bianca', 'h{enemies}[1]' => 'bill', 'h{enemies}[2]' => 'bob', 'h{enemies}[3]' => 'brenda', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); for my $k (qw/friends enemies/) { is($hval->{h}{$k}[$_], $inp{"h{$k}[$_]"}, "h{$k}[$_] copied right") for 0..3; } CGI-Struct-XS-1.04/t/00-pod-coverage.t0000644000175000001440000000104712200020607015570 0ustar nufusersuse strict; use warnings; use Test::More; # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); CGI-Struct-XS-1.04/t/00-load.t0000644000175000001440000000026412200020607014134 0ustar nufusers#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'CGI::Struct::XS' ) || print "Bail out! "; } diag( "Testing CGI::Struct::XS $CGI::Struct::XS::VERSION, Perl $], $^X" ); CGI-Struct-XS-1.04/t/04-mixed.t0000644000175000001440000000401312200020607014323 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 18; use CGI::Struct::XS; # Test mixed multi-level bits my %inp = ( # A scalar 'h{a}[0]' => 'h_a1_0', # A hash 'h{a}[1]{foo}' => 'h_a1_1_foo', 'h{a}[1]{bar}' => 'h_a1_1_bar', # An array holding a scalar... 'h{a}[2][0]' => 'h_a2_0', # ... and a hash ... 'h{a}[2][1]{foo}' => 'h_a2_1_foo', 'h{a}[2][1]{bar}' => 'h_a2_1_bar', # ... and an array 'h{a}[2][2][0]' => 'h_a2_2_0', 'h{a}[2][2][1]' => 'h_a2_2_1', # Now a top level array, holding... # a hash, containing... # one nice simple array 'a[0]{h1}[0]' => 'a0_h1_0', 'a[0]{h1}[1]' => 'a0_h1_1', # another, with one of the arrays being sparse 'a[0]{h2}[5]' => 'a0_h2_5', 'a[0]{h2}[9]' => 'a0_h3_9', # Another level of hash of scalars 'a[0]{h3}{foo}' => 'a0_h3_foo', 'a[0]{h3}{bar}' => 'a0_h3_bar', # And sneak in another array under that 'a[0]{h3}{baz}[0]' => 'a0_h3_baz_0', 'a[0]{h3}{baz}[1]' => 'a0_h3_baz_1', # And just make a big ugly mess 'a[1]{foo}[7]{bar}{baz}[3]' => 'amess', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is($hval->{h}{a}[0], $inp{"h{a}[0]"}, "h{a}[0] copied right"); is($hval->{h}{a}[1]{$_}, $inp{"h{a}[1]{$_}"}, "h{a}[1]{$_} copied right") for qw/foo bar/; is($hval->{h}{a}[2][0], $inp{"h{a}[2][0]"}, "h{a}[2][0] copied right"); is($hval->{h}{a}[2][1]{$_}, $inp{"h{a}[2][1]{$_}"}, "h{a}[2][1]{$_} copied right") for qw/foo bar/; is($hval->{h}{a}[2][2][$_], $inp{"h{a}[2][2][$_]"}, "h{a}[2][2][$_] copied right") for 0..1; is($hval->{a}[0]{h1}[$_], $inp{"a[0]{h1}[$_]"}, "a[0]{h1}[$_] copied right") for 0..1; is($hval->{a}[0]{h2}[$_], $inp{"a[0]{h2}[$_]"}, "a[0]{h2}[$_] copied right") for qw/5 9/; is($hval->{a}[0]{h3}{$_}, $inp{"a[0]{h3}{$_}"}, "a[0]{h3}{$_} copied right") for qw/foo bar/; is($hval->{a}[0]{h3}{baz}[$_], $inp{"a[0]{h3}{baz}[$_]"}, "a[0]{h3}{baz}[$_] copied right") for 0..1; is($hval->{a}[1]{foo}[7]{bar}{baz}[3], $inp{'a[1]{foo}[7]{bar}{baz}[3]'}, 'a[1]{foo}[7]{bar}{baz}[3] copied right'); CGI-Struct-XS-1.04/t/03-multiarray.t0000644000175000001440000000073312200605515015421 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 7; use CGI::Struct::XS; # Test multi-level arrays my %inp = ( 'a[0][0]' => 'arr0_0', 'a[0][1]' => 'arr0_1', 'a[0][2]' => 'arr0_2', 'a[1][0]' => 'arr1_0', 'a[1][1]' => 'arr1_1', 'a[1][2]' => 'arr1_2', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); for my $l1 (qw/0 1/) { is($hval->{a}[$l1][$_], $inp{"a[$l1][$_]"}, "a[$l1][$_] copied right") for 0..2; } CGI-Struct-XS-1.04/t/02-arrayofhash.t0000644000175000001440000000103312200020607015521 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 6; use CGI::Struct::XS; # Test arrays of hashes my %inp = ( 'a[0]{foo}' => 'arr0_foo', 'a[0]{bar}' => 'arr0_bar', 'a[0]{baz}' => 'arr0_baz', 'a[1]{fred}' => 'arr1_fred', 'a[1]{wilma}' => 'arr1_wilma', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); is($hval->{a}[0]{$_}, $inp{"a[0]{$_}"}, "a[0]{$_} copied right") for qw/foo bar baz/; is($hval->{a}[1]{$_}, $inp{"a[1]{$_}"}, "a[1]{$_} copied right") for qw/fred wilma/; CGI-Struct-XS-1.04/t/01-odd.t0000644000175000001440000000107312200613334013770 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 10; use CGI::Struct::XS; # Make sure odd characters work my %inp = ( "h{xy'z}" => 'singlequote', 'h{xy"z}' => 'doublequote', 'h{xy/z}' => 'slash', 'h{xy\\z}' => 'backslash', "h{x\x{ff}z}" => '8-bit char', 'h{xy$z}' => 'dollar', 'h{xy@z}' => 'at', 'h{xy%z}' => 'percent', 'h{xy#z}' => 'hash', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); for my $k (keys %inp) { (my $ok = $k) =~ s/h\{(.*)}/$1/; is($hval->{h}{$ok}, $inp{$k}, "$k copied right"); } CGI-Struct-XS-1.04/t/04-dotted.t0000644000175000001440000000405412201543234014514 0ustar nufusers#!/usr/bin/env perl5 use strict; use warnings; use Test::More tests => 20; use CGI::Struct::XS; # Test dotted forms my %inp = ( # Single-level 'h.foo' => 'hashfoo', 'h.bar' => 'hashbar', # In an array 'a[0].foo' => 'a0_foo', 'a[0].bar' => 'a0_bar', # or a hash 'h2{x}.foo' => 'h2_x_foo', 'h2{x}.bar' => 'h2_x_bar', # or a hash of arrays 'h2{y}[1].foo' => 'h2_y_1_foo', 'h2{y}[1].bar' => 'h2_y_1_bar', # or a hash of arrays of hashes. Sheesh. 'h2{y}[2]{z}.foo' => 'h2_y_2_z_foo', 'h2{y}[2]{z}.bar' => 'h2_y_2_z_bar', # And in the middle 'h2{z}.foo{a}' => 'h2_z_foo_a', 'h2{z}.bar{a}' => 'h2_z_bar_a', 'h2{zz}.foo[1]' => 'h2_zz_foo_1', 'h2{zz}.bar[1]' => 'h2_zz_bar_1', ); my @errs; my $hval = build_cgi_struct \%inp, \@errs; is(@errs, 0, "No errors"); for my $k (qw/foo bar/) { is($hval->{h}{$k}, $inp{"h.$k"}, "h.$k copied right"); is($hval->{a}[0]{$k}, $inp{"a[0].$k"}, "a[0].$k copied right"); is($hval->{h2}{x}{$k}, $inp{"h2{x}.$k"}, "h2{x}.$k copied right"); is($hval->{h2}{y}[1]{$k}, $inp{"h2{y}[1].$k"}, "h2{y}[1].$k copied right"); is($hval->{h2}{y}[2]{z}{$k}, $inp{"h2{y}[2]{z}.$k"}, "h2{y}[2]{z}.$k copied right"); # Backslashes after $k to keep perl from looking for %k or @k, # respectively. Using ${k} instead works on 5.8+, but not on 5.6. is($hval->{h2}{z}{$k}{a}, $inp{"h2{z}.$k\{a}"}, "h2{z}.$k\{a} copied right"); is($hval->{h2}{zz}{$k}[1], $inp{"h2{zz}.$k\[1]"}, "h2{z}.$k\[1] copied right"); } # Test of turning off dotting %inp = ( 'h.v' => 'dotted hash', 'h{x.y}' => 'dotted name', ); @errs = (); $hval = build_cgi_struct \%inp, \@errs, {nodot => 1}; is(@errs, 0, "No errors"); # Make sure it didn't translate is($hval->{'h.v'}, $inp{'h.v'}, 'h.v untranslated with nodot'); is($hval->{h}{v}, undef, "h{v} didn't sneak in"); # Make sure the name comes through ok(grep(/^x\.y$/, keys %{$hval->{h}}), 'x.y name translated'); # Double check that it gets an error without nodot $hval = build_cgi_struct \%inp, \@errs; ok(grep(/Not balanced delimiter for h\{x.y}/, @errs), 'without nodot properly failed'); CGI-Struct-XS-1.04/MANIFEST0000644000175000017500000000104512205755722013154 0ustar nufnufbin/benchmark.pl Changes lib/CGI/Struct/XS.pm LICENSE Makefile.PL MANIFEST This list of files README README.md t/00-load.t t/00-pod-coverage.t t/00-pod.t t/01-array.t t/01-directcopy.t t/01-hash.t t/01-odd.t t/02-arrayofhash.t t/02-hashofarray.t t/03-multiarray.t t/03-multihash.t t/04-autoarr.t t/04-dotted.t t/04-mixed.t t/05-bad.t t/05-copies.t t/05-edges.t t/05-leak.t XS.xs META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) CGI-Struct-XS-1.04/XS.xs0000644000175000001440000003041612205755310013273 0ustar nufusers#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include #define CONF_GET(conf, key, default) \ ({ \ SV** val = hv_fetch(conf, key, strlen(key), 0); \ val ? SvUV(*val) : (default); \ }) #ifndef newSVpvn_utf8 #define newSVpvn_utf8(ptr, len, utf8) \ ({ \ SV* copy = newSVpvn((ptr), (len)); \ if (utf8) { SvUTF8_on(copy); } \ copy; \ }) #endif #define BUF_LEN 1024 #define STATE_MASK 0x00FF #define ACTION_MASK 0xFF00 #define DBG(fmt, ...) if (opts->debug > 0) { fprintf(stderr, fmt, ##__VA_ARGS__); } #define DUMP(s) do_sv_dump(0, Perl_debug_log, (s), 0, 1, 0, 0); typedef struct opts { U32 nodot; U32 nullsplit; U32 dclone; U32 debug; } Opts; typedef enum input { I_DT = 0x00, // . I_LS = 0x01, // [ I_RS = 0x02, // ] I_LC = 0x03, // { I_RC = 0x04, // } I_DI = 0x05, // 0-9 digit I_CH = 0x06, // any other char I_EN = 0x07 // fake end-of-line char } Input; typedef enum action { A_EC = 0x0200, // eat char A_ED = 0x0800, // eat digit A_CH = 0x1000, // create hash (vivify) A_CA = 0x2000, // create array (vivify) A_CV = 0x4000, // put scalar A_AA = 0x8000 // put scalar-or-array (auto-arrays) } Action; static Input classes[] = { I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_DT, I_CH, I_DI, I_DI, I_DI, I_DI, I_DI, I_DI, I_DI, I_DI, I_DI, I_DI, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_LS, I_CH, I_RS, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_LC, I_CH, I_RC, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH, I_CH }; typedef enum state { S_FN = 0x00, // first char in normal key S_RN = 0x01, // reading normal key S_FK = 0x02, // first char of key inside {} S_RK = 0x03, // reading key inside {} S_FI = 0x04, // first digit of index inside [], checking auto-array S_RI = 0x05, // reading index inside [] S_RC = 0x06, // reading controll . [ or { S_EN = 0x07, // end state S_E1 = 0x08, // error: delimeter not balanced S_E2 = 0x09, // error: index should be a number S_E3 = 0x0a, // error: zero-length key name S_E4 = 0x0b, // error: unexpected controll char S_E5 = 0x0c, // error: type mismatch - array found S_E6 = 0x0d, // error: type mismatch - hash found } State; static U32 machine[][8] = { /* I_DT, I_LS, I_RS, I_LC, I_RC, I_DI, I_CH, I_EN /*S_FN*/ { S_E3, S_E3, S_E3, S_E3, S_E3, S_RN|A_EC, S_RN|A_EC, S_E3 }, /*S_RN*/ { S_FN|A_CH, S_FI|A_CA, S_RN|A_EC, S_FK|A_CH, S_RN|A_EC, S_RN|A_EC, S_RN|A_EC, S_EN|A_CV }, /*S_FK*/ { S_E1, S_E1, S_E1, S_E1, S_E3, S_RK|A_EC, S_RK|A_EC, S_E1 }, /*S_RK*/ { S_E1, S_E1, S_E1, S_E1, S_RC, S_RK|A_EC, S_RK|A_EC, S_E1 }, /*S_FI*/ { S_E2, S_E1, S_EN|A_AA, S_E1, S_E1, S_RI|A_ED, S_E2, S_E1 }, /*S_RI*/ { S_E2, S_E1, S_RC, S_E1, S_E1, S_RI|A_ED, S_E2, S_E1 }, /*S_RC*/ { S_FN|A_CH, S_FI|A_CA, S_E4, S_FK|A_CH, S_E4, S_E4, S_E4, S_EN|A_CV } }; static SV* _dclone(SV* sv) { I32 count; SV* res; dSP; if (!SvROK(sv)) { return sv_mortalcopy(sv); } PUSHMARK(SP); XPUSHs(sv); PUTBACK; count = call_pv("Storable::dclone", G_SCALAR); if (count != 1) { croak("Storable::dclone call failed\n"); } SPAGAIN; res = POPs; PUTBACK; return res; } static SV* _split(SV* val, Opts* opts) { char* beg = SvPVX(val); char* end = SvEND(val); char* zer = (char*) memchr(beg, '\0', SvCUR(val)); if (zer && zer < end) { AV* arr = newAV(); do { av_push(arr, newSVpvn_utf8(beg, zer - beg, SvUTF8(val))); beg = zer + 1; zer = memchr(beg, '\0', end - beg); } while (zer && zer < end); if (beg <= end) { av_push(arr, newSVpvn_utf8(beg, end - beg, SvUTF8(val))); } val = newRV_noinc((SV*)arr); sv_2mortal(val); } return val; } static void _copy_array(AV* tgt, AV* src) { U32 i = 0; U32 l = av_len(src); // last index av_fill(tgt, l); for (i = 0; i <= l; i++) { // TODO: optimize copying SV** el = av_fetch(src, i, 0); if (el) { SvREFCNT_inc(*el); av_store(tgt, i, *el); } } } static void _store(void* ptr, const char* part_key, U32 part_klen, U32 part_idx, SV* val, Opts* opts) { if (SvTYPE((SV*)ptr) == SVt_PVHV) { DBG("hv_store ptr %p part_key '%s' part_klen %u val %p (type %u)\n", ptr, part_key, part_klen, val, SvTYPE(val)); hv_store((HV*)ptr, part_key, part_klen, val, 0); } else { DBG("av_store ptr %p part_idx %u val %p (type %u)\n", ptr, part_idx, val, SvTYPE(val)); av_store((AV*)ptr, part_idx, val); } } static SV* _next(void* ptr, const char* part_key, U32 part_klen, U32 part_idx, svtype type, Opts* opts) { SV** ref_ptr; SV* next; if (SvTYPE((SV*)ptr) == SVt_PVHV) { ref_ptr = hv_fetch((HV*)ptr, part_key, part_klen, 0); } else { ref_ptr = av_fetch((AV*)ptr, part_idx, 0); } if (!ref_ptr) { next = type == SVt_PVHV ? (SV*)newHV() : (SV*)newAV(); _store(ptr, part_key, part_klen, part_idx, newRV_noinc((SV*)next), opts); } else { if (SvROK(*ref_ptr) && SvTYPE(SvRV(*ref_ptr)) == type) { next = SvRV(*ref_ptr); } else { return NULL; } } return next; } static void _handle_pair(const unsigned char* key, U32 klen, SV* val, AV* err, Opts* opts, HV* ov) { U32 pos = 0; U32 mv = 0; U32 ac = 0; Input inp = I_CH; State st = S_FN; U32 part_idx = 0; const unsigned char* part_key = key; U32 part_klen = 0; void* ptr = ov; DBG("key '%s' klen %u\n", key, klen); for (pos = 0; pos <= klen && st < S_EN; pos++) { DBG("chr %c %u\n", key[pos], key[pos]); DBG("class %u\n", classes[key[pos]]); inp = pos == klen ? I_EN : classes[key[pos]]; if (inp == I_DT && opts->nodot) { inp = I_CH; } mv = machine[st][inp]; DBG("st %u pos %u chr '%c(%u)' inp %u -> st %u\n", st, pos, key[pos], (int)key[pos], inp, mv & STATE_MASK); st = mv & STATE_MASK; ac = mv & ACTION_MASK; switch (ac) { case A_EC: part_klen++; break; case A_ED: part_idx = part_idx * 10 + key[pos] - '0'; break; case A_CH: ptr = _next(ptr, part_key, part_klen, part_idx, SVt_PVHV, opts); if (!ptr) { st = S_E5; } part_key = key + pos + 1; part_klen = 0; part_idx = 0; break; case A_CA: ptr = _next(ptr, part_key, part_klen, part_idx, SVt_PVAV, opts); if (!ptr) { st = S_E6; } part_key = key + pos + 1; part_klen = 0; part_idx = 0; break; case A_CV: if (opts->nullsplit && SvPOK(val)) { val = _split(val, opts); } SvREFCNT_inc(val); _store(ptr, part_key, part_klen, part_idx, val, opts); break; case A_AA: if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVAV) { _copy_array((AV*) ptr, (AV*) SvRV(val)); } else { SvREFCNT_inc(val); _store(ptr, part_key, part_klen, part_idx, val, opts); } break; } } DBG("final state %u\n\n", st); // normal return if (st == S_EN) { return; } // error handling if needed if (err) { char msg[BUF_LEN]; char* key_prefix = NULL; # define ERR(fmt, ...) snprintf(msg, sizeof(msg), fmt, ##__VA_ARGS__); switch (st) { case S_EN: break; case S_E1: ERR("Not balanced delimiter for %s", key); break; case S_E2: ERR("Array index should be a number for %s", key); break; case S_E3: if (pos == 1) { ERR("Unexpected initial char '%c' for %s", key[0], key); } else { ERR("Zero-length key name for %s", key); } break; case S_E4: ERR("Delimeter expected at %s for %s", key + pos, key); break; case S_E5: case S_E6: key_prefix = (char*) malloc(pos); strncpy(key_prefix, key, pos - 1); key_prefix[pos-1] = '\0'; ERR("Type mismatch: %s already used as %s for %s", key_prefix, (st == S_E5 ? "ArrayRef" : "HashRef"), key); free(key_prefix); break; default: ERR("Internal: unexpected final state %u for %s", st, key); break; } # undef ERR av_push(err, newSVpv((msg), 0)); } return; } MODULE = CGI::Struct::XS PACKAGE = CGI::Struct::XS PROTOTYPES: DISABLE HV* build_cgi_struct(HV* iv, ...) PREINIT: AV* err = NULL; HV* conf = NULL; Opts opts = { .nodot = 0, .nullsplit = 1, .dclone = 1, .debug = 0 }; HE* pair = NULL; char* key = NULL; U32 klen = 0; SV* val = NULL; CODE: /* prepare args */ if (items > 1) { SV* const xsub_tmp_sv = ST(1); SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV) { err = (AV*) SvRV(xsub_tmp_sv); } } if (items > 2) { SV* const xsub_tmp_sv = ST(2); SvGETMAGIC(xsub_tmp_sv); if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV) { conf = (HV*) SvRV(xsub_tmp_sv); opts.nodot = CONF_GET(conf, "nodot", opts.nodot); opts.nullsplit = CONF_GET(conf, "nullsplit", opts.nullsplit); opts.dclone = CONF_GET(conf, "dclone", opts.dclone); opts.debug = CONF_GET(conf, "debug", opts.debug); } } /* prepare output */ RETVAL = newHV(); sv_2mortal((SV*)RETVAL); /* main loop */ hv_iterinit(iv); while (pair = hv_iternext(iv)) { key = hv_iterkey(pair, &klen); val = hv_iterval(iv, pair); if (opts.dclone) { val = _dclone(val); } _handle_pair(key, klen, val, err, &opts, RETVAL); } OUTPUT: RETVAL CGI-Struct-XS-1.04/lib/0000755000175000017500000000000012205755721012570 5ustar nufnufCGI-Struct-XS-1.04/lib/CGI/0000755000175000017500000000000012205755721013172 5ustar nufnufCGI-Struct-XS-1.04/lib/CGI/Struct/0000755000175000017500000000000012205755721014456 5ustar nufnufCGI-Struct-XS-1.04/lib/CGI/Struct/XS.pm0000644000175000001440000000366112205755613015721 0ustar nufusersuse warnings; use strict; package CGI::Struct::XS; use XSLoader; use Exporter qw(import); use Storable qw(dclone); our $VERSION = 1.04; our @EXPORT = qw(build_cgi_struct); XSLoader::load(__PACKAGE__, $VERSION); 1; __END__ =head1 NAME CGI::Struct::XS - Build structures from CGI data. Fast. =head1 DESCRIPTION This module is XS implementation of L. It's fully compatible with L, except for error messages. C is 3-15 (5-25 with dclone disabled) times faster than original module. =head1 SYNOPSIS use CGI; use CGI::Struct::XS; my $cgi = CGI->new; my %params = $cgi->Vars; my $struct = build_cgi_struct \%params; ... Or use Plack::Request; use CGI::Struct::XS; my $app_or_middleware = sub { my $env = shift; # PSGI env my $req = Plack::Request->new($env); my $errs = []; my $struct = build_cgi_struct $req->parameters, $errs, { dclone => 0 }; ... } =head1 FUNCTIONS =head2 build_cgi_struct $struct = build_cgi_struct \%params; $struct = build_cgi_struct \%params, \@errs; $struct = build_cgi_struct \%params, \@errs, \%conf; The only exported function is C. It has three arguments: =over =item C<\%params> HashRef with input values. Typicaly this is CGI or Plack params hashref =item C<\@errs> ArrayRef to store error messages. If it's not defined all parsing errors will be sielently discarded. =item C<\%conf> HashRef with parsing optiosn =back Following options are supported: =over =item C Treat dot as ordinary character, not hash delimeter =item C Split input values by C<\\0> characeter, usefull for old CGI libraries =item C Store deep clone of value, instead of original value. This opion increase memory consumsion and slows parsing. It's recomended to disable dclone, because in most cases CGI params are used as read-only variables. =back =head1 SEE ALSO L CGI-Struct-XS-1.04/LICENSE0000644000175000001440000000245312200020607013357 0ustar nufusers/* * Copyright (c) 2013 * Dmitry Smal * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * */ CGI-Struct-XS-1.04/README0000644000175000001440000000022112202254437013235 0ustar nufusersCGI::Struct::XS is perl xs module for parsing complex params names of http forms. It's fully compatible with CGI::Struct, but 3-15 times faster. CGI-Struct-XS-1.04/bin/0000755000175000017500000000000012205755721012572 5ustar nufnufCGI-Struct-XS-1.04/bin/benchmark.pl0000644000175000017500000000362012204113725015051 0ustar nufnufuse warnings; use strict; use Benchmark; use CGI::Struct (); use CGI::Struct::XS (); # simple params, typical for user interface my %poor_inp = ( 'action' => 'list', 'order' => 'name', 'page' => 5, 'limit' => 10, ); # complex params, typical for admin interface my %rich_inp = ( 'action' => 'update', 'p.sys.name' => 'dsfdsfdsf', 'p.sys.slug' => 'sfsdfs', 'p.sys.client_id' => 'sdfdsgfdsg', 'p.urls[]' => ['a', 'b', 'c'], 'p.zeroes' => "a\0b\0c", 'p.media[0].id' => 1, 'p.media[0].name' => 'asdasd', 'p.media[0].type' => 'img', 'p.media[1].id' => 1, 'p.media[1].name' => 'asdasd', 'p.media[1].type' => 'img', 'p.media[2].id' => 1, 'p.media[2].name' => 'asdasd', 'p.media[2].type' => 'img', ); print "Rich input, dclone => 0\n"; timethese(100000, { pp => sub { my @errs; CGI::Struct::build_cgi_struct(\%rich_inp, \@errs, { dclone => 0, nullsplit => 1 }); }, xs => sub { my @errs; CGI::Struct::XS::build_cgi_struct(\%rich_inp, \@errs, { dclone => 0, nullsplit => 1 }); }, }); print "Rich input, dclone => 1\n"; timethese(100000, { pp => sub { my @errs; CGI::Struct::build_cgi_struct(\%rich_inp, \@errs, { dclone => 1, nullsplit => 1 }); }, xs => sub { my @errs; CGI::Struct::XS::build_cgi_struct(\%rich_inp, \@errs, { dclone => 1, nullsplit => 1 }); }, }); print "Poor input, dclone => 0\n"; timethese(400000, { pp => sub { my @errs; CGI::Struct::build_cgi_struct(\%poor_inp, \@errs, { dclone => 0, nullsplit => 0 }); }, xs => sub { my @errs; CGI::Struct::XS::build_cgi_struct(\%poor_inp, \@errs, { dclone => 0, nullsplit => 0 }); }, }); print "Poor input, dclone => 1\n"; timethese(400000, { pp => sub { my @errs; CGI::Struct::build_cgi_struct(\%poor_inp, \@errs, { dclone => 1, nullsplit => 0 }); }, xs => sub { my @errs; CGI::Struct::XS::build_cgi_struct(\%poor_inp, \@errs, { dclone => 1, nullsplit => 0 }); }, }); CGI-Struct-XS-1.04/Makefile.PL0000644000175000001440000000137512205475416014347 0ustar nufusersuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'CGI::Struct::XS', AUTHOR => q{Dmitry Smal }, VERSION_FROM => 'lib/CGI/Struct/XS.pm', ABSTRACT_FROM => 'lib/CGI/Struct/XS.pm', ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE'=> 'bsd') : ()), PL_FILES => {}, PREREQ_PM => { 'Storable' => 0, 'XSLoader' => 0, 'Test::More' => 0, 'Test::Deep' => 0, 'Test::Deep::NoTest' => 0, 'Test::LeakTrace' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'CGI-Struct-XS-*' }, );