diff options
Diffstat (limited to 'qooxdoo/source/perl/JSON')
-rwxr-xr-x | qooxdoo/source/perl/JSON/Converter.pm | 473 | ||||
-rwxr-xr-x | qooxdoo/source/perl/JSON/PP.pm | 1355 | ||||
-rwxr-xr-x | qooxdoo/source/perl/JSON/PP5005.pm | 82 | ||||
-rwxr-xr-x | qooxdoo/source/perl/JSON/PP56.pm | 184 | ||||
-rwxr-xr-x | qooxdoo/source/perl/JSON/Parser.pm | 419 |
5 files changed, 2513 insertions, 0 deletions
diff --git a/qooxdoo/source/perl/JSON/Converter.pm b/qooxdoo/source/perl/JSON/Converter.pm new file mode 100755 index 0000000..1bcc398 --- /dev/null +++ b/qooxdoo/source/perl/JSON/Converter.pm @@ -0,0 +1,473 @@ +package JSON::Converter; +############################################################################## + +use Carp; + +use vars qw($VERSION $USE_UTF8); +use strict; +use JSON (); +use B (); + + +$VERSION = '1.13'; + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::Converter::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::Converter::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } + + if ($] < 5.006) { + eval q{ + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + }; + } + + $USE_UTF8 = JSON->USE_UTF8; + +} + + +############################################################################## + +sub new { + my $class = shift; + bless {indent => 2, pretty => 0, delimiter => 2, @_}, $class; +} + + +sub objToJson { + my $self = shift; + my $obj = shift; + my $opt = shift; + + local(@{$self}{qw/autoconv execcoderef skipinvalid/}); + local(@{$self}{qw/pretty indent delimiter keysort convblessed utf8 singlequote/}); + + $self->_initConvert($opt); + + if($self->{convblessed}){ + $obj = _blessedToNormalObject($obj); + } + + #(not hash for speed) + local @JSON::Converter::obj_addr; # check circular references + # for speed + local $JSON::Converter::pretty = $self->{pretty}; + local $JSON::Converter::keysort = !$self->{keysort} ? undef + : ref($self->{keysort}) eq 'CODE' ? $self->{keysort} + : $self->{keysort} =~ /\D+/ ? $self->{keysort} + : sub { $a cmp $b }; + local $JSON::Converter::autoconv = $self->{autoconv}; + local $JSON::Converter::execcoderef = $self->{execcoderef}; + local $JSON::Converter::selfconvert = $self->{selfconvert}; + local $JSON::Converter::utf8 = $self->{utf8}; + + local *_stringfy = *_stringfy_single_quote if($self->{singlequote}); + + return $self->_toJson($obj); +} + + +*hashToJson = \&objToJson; +*arrayToJson = \&objToJson; +*valueToJson = \&_valueToJson; + + +sub _toJson { + my ($self, $obj) = @_; + + if(ref($obj) eq 'HASH'){ + return $self->_hashToJson($obj); + } + elsif(ref($obj) eq 'ARRAY'){ + return $self->_arrayToJson($obj); + } + elsif( $JSON::Converter::selfconvert + and blessed($obj) and $obj->can('toJson') ){ + return $self->_selfToJson($obj); + } + else{ + return; + } +} + + +sub _hashToJson { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + if (my $class = tied %$obj) { # by ddascalescu+perl [at] gmail.com + $class =~ s/=.*//; + tie %res, $class; + } + + my ($pre,$post) = $self->_upIndent() if($JSON::Converter::pretty); + + if (grep { $_ == $obj } @JSON::Converter::obj_addr) { + die "circle ref!"; + } + + push @JSON::Converter::obj_addr,$obj; + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->_toJson($v) || $self->_valueToJson($v); + } + + pop @JSON::Converter::obj_addr; + + if ($JSON::Converter::pretty) { + $self->_downIndent(); + my $del = $self->{_delstr}; + return "{$pre" + . join(",$pre", map { _stringfy($_) . $del .$res{$_} } + (defined $JSON::Converter::keysort ? ( sort $JSON::Converter::keysort (keys %res)) : (keys %res) ) + ). "$post}"; + } + else{ + return '{'. join(',',map { _stringfy($_) .':' .$res{$_} } + (defined $JSON::Converter::keysort ? + ( sort $JSON::Converter::keysort (keys %res)) : (keys %res) ) + ) .'}'; + } + +} + + +sub _arrayToJson { + my ($self, $obj) = @_; + my @res; + + if (my $class = tied @$obj) { + $class =~ s/=.*//; + tie @res, $class; + } + + my ($pre,$post) = $self->_upIndent() if($JSON::Converter::pretty); + + if(grep { $_ == $obj } @JSON::Converter::obj_addr){ + die "circle ref!"; + } + + push @JSON::Converter::obj_addr,$obj; + + for my $v (@$obj){ + push @res, $self->_toJson($v) || $self->_valueToJson($v); + } + + pop @JSON::Converter::obj_addr; + + if ($JSON::Converter::pretty) { + $self->_downIndent(); + return "[$pre" . join(",$pre" ,@res) . "$post]"; + } + else { + return '[' . join(',' ,@res) . ']'; + } +} + + +sub _selfToJson { + my ($self, $obj) = @_; + if(grep { $_ == $obj } @JSON::Converter::obj_addr){ + die "circle ref!"; + } + push @JSON::Converter::obj_addr, $obj; + return $obj->toJson($self); +} + + +sub _valueToJson { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + if(!ref($value)){ + if($JSON::Converter::autoconv){ + return $value if($value =~ /^-?(?:0|[1-9][\d]*)(?:\.\d*)?(?:[eE][-+]?\d+)?$/); + return $value if($value =~ /^0[xX](?:[0-9a-fA-F])+$/); + return 'true' if($value =~ /^[Tt][Rr][Uu][Ee]$/); + return 'false' if($value =~ /^[Ff][Aa][Ll][Ss][Ee]$/); + } + + my $b_obj = B::svref_2object(\$value); # for round trip problem + # SvTYPE is IV or NV? + return $value # as is + if ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVf_NOK); + + return _stringfy($value); + } + elsif($JSON::Converter::execcoderef and ref($value) eq 'CODE'){ + my $ret = $value->(); + return 'null' if(!defined $ret); + return $self->_toJson($ret) || _stringfy($ret); + } + elsif( blessed($value) and $value->isa('JSON::NotString') ){ + return defined $value->{value} ? $value->{value} : 'null'; + } + else { + die "Invalid value" unless($self->{skipinvalid}); + return 'null'; + } + +} + + +my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', +# "/" => '\\/', # TODO +); + + +sub _stringfy { + my ($arg) = @_; + $arg =~ s/([\\"\n\r\t\f\b])/$esc{$1}/eg; + + unless (JSON->USE_UTF8) { + $arg =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; + return '"' . $arg . '"'; + } + + # suggestion from rt#25727 + $arg = join('', + map { + chr($_) =~ /[\x00-\x07\x0b\x0e-\x1f]/ ? + sprintf('\u%04x', $_) : + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%04x', $_) + } unpack('U*', $arg) + ); + + $JSON::Converter::utf8 and utf8::decode($arg); + + return '"' . $arg . '"'; +} + + +sub _stringfy_single_quote { + my $arg = shift; + $arg =~ s/([\\\n'\r\t\f\b])/$esc{$1}/eg; + + unless (JSON->USE_UTF8) { + $arg =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; + return "'" . $arg ."'"; + } + + $arg = join('', + map { + chr($_) =~ /[\x00-\x07\x0b\x0e-\x1f]/ ? + sprintf('\u%04x', $_) : + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%04x', $_) + } unpack('U*', $arg) + ); + + $JSON::Converter::utf8 and utf8::decode($arg); + + return "'" . $arg ."'"; +}; + + +############################################################################## + +sub _initConvert { + my $self = shift; + my %opt = %{ $_[0] } if(@_ > 0 and ref($_[0]) eq 'HASH'); + + $self->{autoconv} = $JSON::AUTOCONVERT if(!defined $self->{autoconv}); + $self->{execcoderef} = $JSON::ExecCoderef if(!defined $self->{execcoderef}); + $self->{skipinvalid} = $JSON::SkipInvalid if(!defined $self->{skipinvalid}); + + $self->{pretty} = $JSON::Pretty if(!defined $self->{pretty}); + $self->{indent} = $JSON::Indent if(!defined $self->{indent}); + $self->{delimiter} = $JSON::Delimiter if(!defined $self->{delimiter}); + $self->{keysort} = $JSON::KeySort if(!defined $self->{keysort}); + $self->{convblessed} = $JSON::ConvBlessed if(!defined $self->{convblessed}); + $self->{selfconvert} = $JSON::SelfConvert if(!defined $self->{selfconvert}); + $self->{utf8} = $JSON::UTF8 if(!defined $self->{utf8}); + $self->{singlequote} = $JSON::SingleQuote if(!defined $self->{singlequote}); + + for my $name (qw/autoconv execcoderef skipinvalid pretty + indent delimiter keysort convblessed selfconvert utf8 singlequote/){ + $self->{$name} = $opt{$name} if(defined $opt{$name}); + } + + if($self->{utf8} and !$USE_UTF8){ + $self->{utf8} = 0; warn "JSON::Converter couldn't use utf8."; + } + + $self->{indent_count} = 0; + + $self->{_delstr} = + $self->{delimiter} ? ($self->{delimiter} == 1 ? ': ' : ' : ') : ':'; + + $self; +} + + +sub _upIndent { + my $self = shift; + my $space = ' ' x $self->{indent}; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $self->{indent_count}; + + $self->{indent_count}++; + + $pre = "\n" . $space x $self->{indent_count}; + + return ($pre,$post); +} + + +sub _downIndent { $_[0]->{indent_count}--; } + + +# +# converting the blessed object to the normal object +# + +sub _blessedToNormalObject { require overload; + my ($obj) = @_; + + local @JSON::Converter::_blessedToNormal::obj_addr; + + return _blessedToNormal($obj); +} + + +sub _getObjType { + return '' if(!ref($_[0])); + ref($_[0]) eq 'HASH' ? 'HASH' : + ref($_[0]) eq 'ARRAY' ? 'ARRAY' : + $_[0]->isa('JSON::NotString') ? '' : + (overload::StrVal($_[0]) =~ /=(\w+)/)[0]; +} + + +sub _blessedToNormal { + my $type = _getObjType($_[0]); + return $type eq 'HASH' ? _blessedToNormalHash($_[0]) : + $type eq 'ARRAY' ? _blessedToNormalArray($_[0]) : + $type eq 'SCALAR' ? _blessedToNormalScalar($_[0]) : $_[0]; +} + + +sub _blessedToNormalHash { + my ($obj) = @_; + my %res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + for my $k (keys %$obj){ + $res{$k} = _blessedToNormal($obj->{$k}); + } + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return \%res; +} + + +sub _blessedToNormalArray { + my ($obj) = @_; + my @res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + for my $v (@$obj){ + push @res, _blessedToNormal($v); + } + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return \@res; +} + + +sub _blessedToNormalScalar { + my ($obj) = @_; + my $res; + + die "circle ref!" if(grep { overload::AddrRef($_) eq overload::AddrRef($obj) } + @JSON::Converter::_blessedToNormal::obj_addr); + + push @JSON::Converter::_blessedToNormal::obj_addr, $obj; + + $res = _blessedToNormal($$obj); + + pop @JSON::Converter::_blessedToNormal::obj_addr; + + return $res; # JSON can't really do scalar refs so it can't be \$res +} + +############################################################################## +1; +__END__ + + +=head1 METHODs + +=over + +=item objToJson + +convert a passed perl data structure into JSON object. +can't parse bleesed object by default. + +=item hashToJson + +convert a passed hash into JSON object. + +=item arrayToJson + +convert a passed array into JSON array. + +=item valueToJson + +convert a passed data into a string of JSON. + +=back + +=head1 COPYRIGHT + +makamaka [at] donzoko.net + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<JSON>, +L<http://www.crockford.com/JSON/index.html> + +=cut diff --git a/qooxdoo/source/perl/JSON/PP.pm b/qooxdoo/source/perl/JSON/PP.pm new file mode 100755 index 0000000..dc2d39a --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP.pm @@ -0,0 +1,1355 @@ +package JSON::PP; + +# JSON-2.0 + +use 5.005; +use strict; +use base qw(Exporter); +use overload; + +use Carp (); +use B (); +#use Devel::Peek; + +$JSON::PP::VERSION = '0.96'; + +@JSON::PP::EXPORT = qw(from_json to_json jsonToObj objToJson); + +*jsonToObj = *from_json; +*objToJson = *to_json; + + + +BEGIN { + my @properties = qw( + utf8 allow_nonref indent space_before space_after canonical max_depth shrink + allow_tied self_encode singlequote allow_bigint disable_UTF8 strict + allow_barekey escape_slash literal_value + ); + + # Perl version check, ascii() is enable? + # Helper module may set @JSON::PP::_properties. + if ($] >= 5.008) { + require Encode; + push @properties, 'ascii', 'latin1'; + + *utf8::is_utf8 = *Encode::is_utf8 if ($] == 5.008); + + *JSON_encode_ascii = *_encode_ascii; + *JSON_encode_latin1 = *_encode_latin1; + *JSON_decode_unicode = *_decode_unicode; + } + else { + my $helper = $] >= 5.006 ? 'JSON::PP56' : 'JSON::PP5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + push @properties, @JSON::PP::_properties; + } + + for my $name (@properties) { + eval qq| + sub $name { + \$_[0]->{$name} = defined \$_[1] ? \$_[1] : 1; + \$_[0]; + } + |; + } + +} + + + +# Functions + +my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 allow_tied self_encode escape_slash/; +my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref disable_UTF8 strict singlequote allow_bigint + allow_barekey literal_value/; + + +sub to_json { # encode + my ($obj, $opt) = @_; + + if ($opt) { + my $json = JSON::PP->new->utf8; + + for my $method (keys %$opt) { + Carp::croak("non acceptble option") + unless (exists $encode_allow_method{$method}); + $json->$method($opt->{$method}); + } + + return $json->encode($obj); + } + else { + return __PACKAGE__->new->utf8->encode($obj); + } + +} + + +sub from_json { # decode + my ($obj, $opt) = @_; + + if ($opt) { + my $json = JSON::PP->new->utf8; + + for my $method (keys %$opt) { + Carp::croak("non acceptble option") + unless (exists $decode_allow_method{$method}); + $json->$method($opt->{$method}); + } + + return $json->decode($obj); + } + else { + __PACKAGE__->new->utf8->decode(shift); + } +} + + +# Methods + +sub new { + my $class = shift; + my $self = { + max_depth => 32, + unmap => 1, + indent => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + }; + + bless $self, $class; +} + + +sub encode { + return $_[0]->encode_json($_[1]); +} + + +sub decode { + return $_[0]->decode_json($_[1], 0x00000000); +} + + +sub decode_prefix { + return $_[0]->decode_json($_[1], 0x00000001); +} + + +# accessor + +sub property { + my ($self, $name, $value) = @_; + + if (@_ == 1) { + Carp::croak('property() requires 1 or 2 arguments.'); + } + elsif (@_ == 2) { + $self->{$name}; + } + else { + $self->$name($value); + } +} + + +# pretty printing + +sub pretty { + my ($self, $v) = @_; + $self->{pretty} = defined $v ? $v : 1; + + if ($v) { # JSON::XS compati + $self->indent(3); + $self->space_before(1); + $self->space_after(1); + } + else { + $self->indent(0); + $self->space_before(0); + $self->space_after(0); + } + + $self; +} + +############################### + +sub JSON::true () { JSON::Literal::true->new; } + +sub JSON::false () { JSON::Literal::false->new; } + +sub JSON::null () { JSON::Literal::null->new; } + +############################### + +### +### Perl => JSON +### + +{ # Convert + + my $depth; + my $max_depth; + my $keysort; + my $indent; + my $indent_count; + my $ascii; + my $utf8; + my $self_encode; + my $disable_UTF8; + my $escape_slash; + + my $latin1; + + + sub encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + ($indent, $ascii, $utf8, $self_encode, $max_depth, $disable_UTF8, $escape_slash, $latin1) + = @{$self}{qw/indent ascii utf8 self_encode max_depth disable_UTF8 escape_slash latin1/}; + + $keysort = !$self->{canonical} ? undef + : ref($self->{canonical}) eq 'CODE' ? $self->{canonical} + : $self->{canonical} =~ /\D+/ ? $self->{canonical} + : sub { $a cmp $b }; + + my $str = $self->toJson($obj); + + if (!defined $str and $self->{allow_nonref}){ + $str = $self->valueToJson($obj); + } + + encode_error("non ref") unless(defined $str); + + return $str; + } + + + sub toJson { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hashToJson($obj); + } + elsif($type eq 'ARRAY'){ + return $self->arrayToJson($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + if ($self->{self_encode} and $obj->can('toJson')) { + return $self->selfToJson($obj); + } + elsif (!$obj->isa('JSON::Literal')) { # handling in valueToJson + ($type) = B::svref_2object($obj) =~ /(.+)=/; + return $type eq 'B::AV' ? $self->arrayToJson($obj) + : $type eq 'B::HV' ? $self->hashToJson($obj) + : undef; + } + } + else { + return $self->valueToJson($obj); + } + } + else{ + return; + } + } + + + sub hashToJson { + my ($self, $obj) = @_; + my ($k,$v); + my %res; + + encode_error("data structure too deep (hit recursion limit)") + if (++$depth > $max_depth); + + $self->_tie_object($obj, \%res) if ($self->{allow_tied}); + + my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); + my $del = ($self->{space_before} ? ' ' : '') . ':' . ($self->{space_after} ? ' ' : ''); + + for my $k (keys %$obj) { + my $v = $obj->{$k}; + $res{$k} = $self->toJson($v) || $self->valueToJson($v); + } + + $self->_downIndent() if ($indent); + + return '{' . $pre + . join(",$pre", map { utf8::decode($_) if ($] < 5.008); + _stringfy($self, $_) + . $del . $res{$_} } _sort($self, \%res)) + . $post + . '}'; + } + + + sub arrayToJson { + my ($self, $obj) = @_; + my @res; + + encode_error("data structure too deep (hit recursion limit)") + if (++$depth > $max_depth); + + $self->_tie_object($obj, \@res) if ($self->{allow_tied}); + + my ($pre, $post) = $indent ? $self->_upIndent() : ('', ''); + + for my $v (@$obj){ + push @res, $self->toJson($v) || $self->valueToJson($v); + } + + $self->_downIndent() if ($indent); + + return '[' . $pre . join(",$pre" ,@res) . $post . ']'; + } + + + sub valueToJson { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + # SvTYPE is IV or NV? + return $value # as is + if ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVf_NOK); + + my $type = ref($value); + + if(!$type){ + return _stringfy($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::Literal') ){ + return $value->{str}; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->valueToJson("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' : encode_error("cannot encode reference."); + } + + if ($type eq 'CODE') { + encode_error("JSON can only reference."); + } + else { + encode_error("cannot encode reference."); + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub _stringfy { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_encode_latin1($arg); + } + + if ($utf8 or $disable_UTF8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub selfToJson { + my ($self, $obj) = @_; + return $obj->toJson($self); + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + my ($self, $res) = @_; + defined $keysort ? (sort $keysort (keys %$res)) : keys %$res; + } + + + sub _tie_object { + my ($self, $obj, $res) = @_; + my $class; + # by ddascalescu+perl [at] gmail.com + if (ref($obj) eq 'ARRAY' and $class = tied @$obj) { + $class =~ s/=.*//; + tie @$res, $class; + } + elsif (ref($obj) eq 'HASH' and $class = tied %$obj) { + $class =~ s/=.*//; + tie %$res, $class; + } + } + + + sub _upIndent { + my $self = shift; + my $space = ' ' x $indent; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _downIndent { $_[0]->{indent_count}--; } + +} # Convert + + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack('U*', $_[0]) + ); +} + + + +# +# JSON => Perl +# + +# from Adam Sussman +use Config; +my $max_intsize = length(((1 << (8 * $Config{intsize} - 2))-1)*2 + 1) - 1; +#my $max_intsize = length(2 ** ($Config{intsize} * 8)) - 1; + + +{ # PARSE + + my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + + my $is_utf8; + my $depth; + my $encoding; + + my $literal_value; # unmmaping + my $utf8; # + my $max_depth; # max nest nubmer of objects and arrays + my $allow_bigint; # using Math::BigInt + my $disable_UTF8; # don't flag UTF8 on + my $singlequote; # loosely quoting + my $strict; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + + sub decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if (!defined $text or ref $text) { + decode_error("malformed text data."); + } + + $is_utf8 = 1 if (utf8::is_utf8($text)); + + $len = length $text; + + ($utf8, $literal_value, $max_depth, $allow_bigint, $disable_UTF8, $strict, $singlequote, $allow_barekey) + = @{$self}{qw/utf8 literal_value max_depth allow_bigint disable_UTF8 strict singlequote allow_barekey/}; + + unless ($self->{allow_nonref}) { + white(); + unless (defined $ch and ($ch eq '{' or $ch eq '[')) { + decode_error('JSON text must be an object or array' + . ' (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + } + + # Currently no effective + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + my $result = value(); + + if ($len > $at) { + my $consumed = $at - 1; + white(); + if ($ch) { + decode_error("garbage after JSON object") unless ($opt & 0x00000001); + return ($result, $consumed); + } + } + + $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch eq '-'); + return $ch =~ /\d/ ? number() : word(); + } + + + sub string { + my ($i,$s,$t,$u); + my @utf16; + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch if ($singlequote); + + OUTER: while( defined(next_chr()) ){ + + if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){ + next_chr(); + + if (@utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + if($disable_UTF8) { + utf8::encode($s) if (utf8::is_utf8($s)); + } + else { + utf8::decode($s); + } + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + $s .= JSON_decode_unicode($u, \@utf16) || next; + + } + else{ + $s .= $ch; + } + } + else{ + if ($utf8 and $is_utf8) { + if( hex(unpack('H*', $ch)) > 255 ) { + decode_error("malformed UTF-8 character in JSON string"); + } + } + elsif ($strict) { + if ($ch =~ /[\x00-\x1f\x22\x2f\x5c]/) { + decode_error('invalid character'); + } + } + + $s .= $ch; + } + } + } + + decode_error("Bad string (unexpected end)"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if($ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif($ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + decode_error("Syntax decode_error (whitespace)"); + } + } + else{ + last; + } + } + } + + + sub object { + my $o = {}; + my $k; + + if($ch eq '{'){ + decode_error('json structure too deep (hit recursion limit)', ) + if (++$depth > $max_depth); + next_chr(); + white(); + if(defined $ch and $ch eq '}'){ + next_chr(); + return $o; + } + while(defined $ch){ + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + decode_error("Bad object ; ':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + next_chr(); + return $o; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + + decode_error("Bad object ; ,or } expected while parsing object/hash"); + } + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $literal_value ? JSON::true : 1; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return $literal_value ? JSON::null : undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $literal_value ? JSON::false : 0; + } + } + + $at--; # for decode_error report + + decode_error("Syntax decode_error (word) 'null' expected") if ($word =~ /^n/); + decode_error("Syntax decode_error (word) 'true' expected") if ($word =~ /^t/); + decode_error("Syntax decode_error (word) 'false' expected") if ($word =~ /^f/); + decode_error("Syntax decode_error (word)" . + " malformed json string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-' or $ch =~ /\d/)){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v) if ($v !~ /[.eE]/ and length $v > $max_intsize); + } + + return 0+$v; + } + + + sub array { + my $a = []; + + if ($ch eq '[') { + decode_error('json structure too deep (hit recursion limit)', 1) + if (++$depth > $max_depth); + next_chr(); + white(); + if(defined $ch and $ch eq ']'){ + next_chr(); + return $a; + } + + while(defined($ch)){ + push @$a, value(); + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + next_chr(); + return $a; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + + unless (length $str) { $str = '(end of string)'; } + + if ($no_rep) { + Carp::croak "$error"; + } + else { + Carp::croak "$error, at character offset $at ($str)"; + } + } + +} # PARSE + + +sub _decode_unicode { + my $u = $_[0]; + my $utf16 = $_[1]; + + # U+10000 - U+10FFFF + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + push @$utf16, $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (scalar(@$utf16)) { + decode_error("missing high surrogate character in surrogate pair"); + } + my $str = pack('H4H4', @$utf16, $u); + @$utf16 = (); + return Encode::decode('UTF-16BE', $str); # UTF-8 flag on + } + else { + if (scalar(@$utf16)) { + decode_error("surrogate pair expected"); + } + + return chr(hex($u)); + } + + return; +} + + +############################### +# Utilities +# + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + } +} + + +############################### + +package JSON::Literal; +use overload ( + '""' => sub { $_[0]->{str} }, + 'bool' => sub { $_[0]->{value} }, + 'eq' => sub { $_[0]->{str} eq $_[1] }, + 'ne' => sub { $_[0]->{str} ne $_[1] }, +); + + +package JSON::Literal::true; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { 1 == $_[1] }, + '!=' => sub { 1 != $_[1] }, +); + +sub new { bless { str => 'true', value => 1 }; } + + +package JSON::Literal::false; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { 0 == $_[1] }, + '!=' => sub { 0 != $_[1] }, +); + +sub new { bless { str => 'false', value => 0 }; } + +package JSON::Literal::null; +use base qw(JSON::Literal); + +use overload ( + '==' => sub { -1 == $_[1] }, + '!=' => sub { -1 != $_[1] }, +); + +sub new { bless { str => 'null', value => undef }; } + +############################### + + +1; +__END__ +=pod + +=head1 NAME + +JSON::PP - An experimental JSON::XS compatible Pure Perl module. + +=head1 SYNOPSIS + + use JSON::PP; + + $obj = from_json($json_text); + $json_text = to_json($obj); + + # or + + $obj = jsonToObj($json_text); + $json_text = objToJson($obj); + + $json = new JSON; + $json_text = $json->ascii->pretty($obj); + + # you can set options to functions. + + $json_text = to_json($obj, {ascii => 1, intend => 2}); + $obj = from_json($json_text, {utf8 => 0}); + + +=head1 DESCRIPTION + +This module is L<JSON::XS> compatible Pure Perl module. +( Perl better than 5.008 is recommended) + +Module variables ($JSON::*) were abolished. + +JSON::PP will be renamed JSON (JSON-2.0). + +Many things including error handling are learned from L<JSON::XS>. +For t/02_error.t compatible, error messages was copied partially from JSON::XS. + + +=head2 FEATURES + +=over + +=item * perhaps correct unicode handling + +This module knows how to handle Unicode (perhaps), +but not yet documents how and when it does so. + +In Perl5.6x, Unicode handling requires L<Unicode::String> module. + +Perl 5.005_xx, Unicode handling is disable currenlty. + + +=item * round-trip integrity + +This module solved the problem pointed out by JSON::XS +using L<B> module. + +=item * strict checking of JSON correctness + +I want to bring close to XS. +How do you want to carry out? + +you can set C<strict> decoding method. + +=item * slow + +Compared to other JSON modules, this module does not compare +favourably in terms of speed. Very slowly! + +=item * simple to use + +This module became very simple. +Since its interface were anyway made the same as JSON::XS. + + +=item * reasonably versatile output formats + +See to L<JSON::XS>. + +=back + +=head1 FUNCTIONS + +=over + +=item to_json + +See to JSON::XS. +C<objToJson> is an alias. + +=item from_json + +See to JSON::XS. +C<jsonToObj> is an alias. + + +=item JSON::true + +Returns JSON true value which is blessed object. +It C<isa> JSON::Literal object. + +=item JSON::false + +Returns JSON false value which is blessed object. +It C<isa> JSON::Literal object. + + +=item JSON::null + +Returns JSON null value which is blessed object. +It C<isa> JSON::Literal object. + + +=back + + +=head1 METHODS + +=over + +=item new + +Returns JSON::PP object. + +=item ascii + +See to JSON::XS. + +In Perl 5.6, this method requires L<Unicode::String>. +If you don't have Unicode::String, +the method is always set to false and warns. + +In Perl 5.005, this option is currently disable. + + +=item latin1 + +See to JSON::XS. + +In Perl 5.6, this method requires L<Unicode::String>. +If you don't have Unicode::String, +the method is always set to false and warns. + +In Perl 5.005, this option is currently disable. + + +=item utf8 + +See to JSON::XS. + +Currently this module always handles UTF-16 as UTF-16BE. + +=item pretty + +See to JSON::XS. + +=item indent + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. + + $json->indent(4); + +is not the same as this: + + $json->indent(); + + +=item space_before + +See to JSON::XS. + +=item space_after + +See JSON::XS. + +=item canonical + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. +This method can take a subref for sorting (see to L<JSON>). + + +=item allow_nonref + +See to JSON::XS. + +=item shrink + +Not yet implemented. + +=item max_depth + +See to JSON::XS. +Strictly, this module does not carry out equivalent to XS. +By default, not 512 (JSON::XS) but 32. + +=item encode + +See to JSON::XS. + +=item decode + +See to JSON::XS. +In Perl 5.6, if you don't have Unicode::String, +the method can't handle UTF-16(BE) char and returns as is. + + +=item property + +Accessor. + + $json->property(utf8 => 1); # $json->utf8(1); + + $value = $json->property('utf8'); # returns 1. + + +=item self_encode + +See L<JSON/BLESSED OBJECT>'s I<self convert> function. + + +=item disable_UTF8 + +If this option is set, UTF8 flag in strings generated +by C<encode>/C<decode> is off. + + +=item allow_tied + +Enable. + +This option will be obsoleted. + + +=item singlequote + +Allows to decode single quoted strings. + +Unlike L<JSON> module, this module does not encode +Perl string into single quoted string any longer. + + +=item allow_barekey + +Allows to decode bare key of member. + + +=item allow_bigint + +When json text has any integer in decoding more than Perl can't handle, +If this option is on, they are converted into L<Math::BigInt> objects. + + +=item strict + +For JSON format, unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid and +JSON::XS decodes just like that. While this module can deocde thoese. +But if this option is set, the module strictly decodes. + + +=item escape_slash + +By default, JSON::PP encodes strings without escaping slash (U+002F). +Setting the option to escape slash. + + +=item literal_value + + + +=back + + +=head1 MAPPING + + + +=head1 COMPARISON + +Using a benchmark program in the JSON::XS (v1.11) distribution. + + module | encode | decode | + -----------|------------|------------| + JSON::PP | 11092.260 | 4482.033 | + -----------+------------+------------+ + JSON::XS | 341513.380 | 226138.509 | + -----------+------------+------------+ + +In case t/12_binary.t (JSON::XS distribution). +(shrink of JSON::PP has no effect.) + +JSON::PP takes 147 (sec). + +JSON::XS takes 4. + + +=head1 TODO + +=over + +=item Document! + +It is troublesome. + +=item clean up + +Under the cleaning. + +=back + + +=head1 SEE ALSO + +L<JSON>, L<JSON::XS> + +RFC4627 + +=head1 AUTHOR + +Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/qooxdoo/source/perl/JSON/PP5005.pm b/qooxdoo/source/perl/JSON/PP5005.pm new file mode 100755 index 0000000..c7000b1 --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP5005.pm @@ -0,0 +1,82 @@ +package JSON::PP5005; + +use 5.005; +use strict; + +my @properties; + +$JSON::PP5005::VERSION = '0.05'; + +BEGIN { + *JSON::PP::JSON_encode_ascii = *_encode_ascii; + *JSON::PP::JSON_encode_latin1 = *_encode_latin1; + *JSON::PP::JSON_decode_unicode = *_disable_decode_unicode; + + sub utf8::is_utf8 { + 1; # It is considered that UTF8 flag on for Perl 5.005. + } + + sub utf8::encode (\$) { + } + + sub utf8::decode (\$) { + } + + sub JSON::PP::ascii { + warn "ascii() is disable in Perl5.005."; + $_[0]->{ascii} = 0; $_[0]; + } + + sub JSON::PP::latin1 { + warn "latin1() is disable in Perl5.005."; + $_[0]->{latin1} = 0; $_[0]; + } + + # missing in B module. + sub B::SVf_IOK () { 0x00010000; } + sub B::SVf_NOK () { 0x00020000; } + +} + + +sub _encode_ascii { + # currently noop +} + + +sub _encode_latin1 { + # currently noop +} + + +sub _disable_decode_unicode { chr(hex($_[0])); } + + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/qooxdoo/source/perl/JSON/PP56.pm b/qooxdoo/source/perl/JSON/PP56.pm new file mode 100755 index 0000000..2948908 --- /dev/null +++ b/qooxdoo/source/perl/JSON/PP56.pm @@ -0,0 +1,184 @@ +package JSON::PP56; + +use 5.006; +use strict; + +my @properties; + +$JSON::PP56::VERSION = '0.13'; + +BEGIN { + sub utf8::is_utf8 { + 1; # It is considered that UTF8 flag on for Perl 5.6. + } + + sub utf8::encode (\$) { # UTF8 flag off + ${$_[0]} = pack("C*", unpack("C*", ${$_[0]})); + } + + sub utf8::decode (\$) { # UTF8 flag on + ${$_[0]} = pack("U*", unpack_emu(${$_[0]})); + } +} + +eval q| require Unicode::String |; + +unless ($@) { + #print Unicode::String->VERSION; + if (Unicode::String->VERSION < 2.08) { # utf16be() exists more than v2.08 + eval q| *Unicode::String::utf16be = *Unicode::String::utf16 |; + } + + *JSON::PP::JSON_encode_ascii = *_encode_ascii; + *JSON::PP::JSON_encode_latin1 = *_encode_latin1; + *JSON::PP::JSON_decode_unicode = *JSON::PP::_decode_unicode; + + eval q| + sub Encode::encode { + my (undef, $str) = @_; + my $u = new Unicode::String; + $u->utf8($str); + $u->utf16be; + } + + sub Encode::decode { + my (undef, $str) = @_; + my $u = new Unicode::String; + $u->utf16be($str); + my $utf8 = $u->utf8; + pack("U", unpack("U", $utf8)); # UTF8 flag on + } + + |; + die $@ if ($@); + + $JSON::PP::_ENABLE_UTF16 = 1; + + push @JSON::PP::_properties, 'ascii', 'latin1'; +} +else { + *JSON::PP::JSON_encode_ascii = *_noop_encode_ascii; + *JSON::PP::JSON_decode_unicode = *_disable_decode_unicode; + + eval q| + sub JSON::PP::ascii { + warn "ascii() is disable in Perl5.6x."; + $_[0]->{ascii} = 0; $_[0]; + } + + sub JSON::PP::latin1 { + warn "latin1() is disable in Perl5.6x."; + $_[0]->{latin1} = 0; $_[0]; + } + |; +} + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack_emu($_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : + join("", map { '\u' . $_ } + unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_)))); + } unpack_emu($_[0]) + ); +} + + +sub unpack_emu { # for Perl 5.6 unpack warnings + my $str = $_[0]; + my @ret; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + if ($is_utf8) { + push @ret, unpack('U', $1); + } + else { + push @ret, unpack('C*', $1); + } + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + + if ($is_utf8) { # eventually, not utf8 + return unpack('C*', $str); + } + + push @ret, unpack('C', $2); + } + } + + return @ret; +} + + + +sub _noop_encode_ascii { + # noop +} + + +sub _disable_decode_unicode { chr(hex($_[0])); } + + +1; +__END__ + +=pod + +=head1 NAME + +JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 + +=head1 DESCRIPTION + +JSON::PP calls internally. + +=head1 AUTHOR + +Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Makamaka Hannyaharamitu + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/qooxdoo/source/perl/JSON/Parser.pm b/qooxdoo/source/perl/JSON/Parser.pm new file mode 100755 index 0000000..7c4e8b4 --- /dev/null +++ b/qooxdoo/source/perl/JSON/Parser.pm @@ -0,0 +1,419 @@ +package JSON::Parser; + +# +# Perl implementaion of json.js +# http://www.crockford.com/JSON/json.js +# + +use vars qw($VERSION $USE_UTF8 $USE_UnicodeString); +use strict; +use JSON (); +use Carp (); + +BEGIN { # suggested by philip.tellis[at]gmail.com + if ($] < 5.008) { + eval q{ require Unicode::String }; + unless ($@) { + $USE_UnicodeString = 1; + eval q| + sub utf8::encode (\$) { + my $f_ref = $_[0]; + if (length($$f_ref) == 1 && ord($$f_ref) <= 0xff) { + my $us = new Unicode::String; + $us->latin1($$f_ref); + $$f_ref = $us->utf8; + } + } + |; + } + } +} + + +$VERSION = '1.07'; + +# TODO: I made 1.03, but that will be used after JSON 1.90 + +$USE_UTF8 = JSON->USE_UTF8(); + +my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", +# '/' => '/', + '\\' => '\\', +); + + +sub new { + my $class = shift; + bless { @_ }, $class; +} + + +*jsonToObj = \&parse; + + +{ # PARSE + + my $text; + my $at; + my $ch; + my $len; + my $unmap; # unmmaping + my $bare; # bareKey + my $apos; # loosely quoting + my $utf8; # set utf8 flag + + + sub parse { + my $self = shift; + $text = shift; + $at = 0; + $ch = ''; + $len = length $text; + $self->_init(@_); + value(); + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($apos and $ch eq "'")); + return number() if($ch eq '-'); + return $ch =~ /\d/ ? number() : word(); + } + + + sub string { + my ($i,$s,$t,$u); + $s = ''; + + if($ch eq '"' or ($apos and $ch eq "'")){ + my $boundChar = $ch if ($apos); + + OUTER: while( defined(next_chr()) ){ + if((!$apos and $ch eq '"') or ($apos and $ch eq $boundChar)){ + next_chr(); + $utf8 and utf8::decode($s); + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ + my $u = ''; + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[\da-fA-F]/); + $u .= $ch; + } + my $f = chr(hex($u)); + utf8::encode( $f ) if($USE_UTF8 || $USE_UnicodeString); + $s .= $f; + } + else{ + $s .= $ch; + } + } + else{ + $s .= $ch; + } + } + } + + error("Bad string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if($ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif($ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + error("Unterminated comment"); + } + } + next; + } + else{ + error("Syntax error (whitespace)"); + } + } + else{ + last; + } + } + } + + + sub object { + my $o = {}; + my $k; + + if($ch eq '{'){ + next_chr(); + white(); + if($ch eq '}'){ + next_chr(); + return $o; + } + while(defined $ch){ + $k = ($bare and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if($ch ne ':'){ + last; + } + + next_chr(); + $o->{$k} = value(); + white(); + + if($ch eq '}'){ + next_chr(); + return $o; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + + error("Bad object"); + } + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $unmap ? 1 : bless {value => 'true'}, 'JSON::NotString' + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return $unmap ? undef : bless {value => undef}, 'JSON::NotString'; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $unmap ? 0 : bless {value => 'false'}, 'JSON::NotString' + } + } + + error("Syntax error (word)"); + } + + + sub number { + my $n = ''; + my $v; + + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; + + if($hex){ + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + } + + if(defined $n and length($n)){ + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + } + + while($ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if($ch eq '.'){ + $n .= '.'; + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if($ch eq 'e' or $ch eq 'E'){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-' or $ch =~ /\d/)){ + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + return 0+$v; + } + + + sub array { + my $a = []; + + if($ch eq '['){ + next_chr(); + white(); + if($ch eq ']'){ + next_chr(); + return $a; + } + while(defined($ch)){ + push @$a, value(); + white(); + if($ch eq ']'){ + next_chr(); + return $a; + } + elsif($ch ne ','){ + last; + } + next_chr(); + white(); + } + } + + error("Bad array"); + } + + + sub error { + my $error = shift; + + local $Carp::CarpLevel = 1; + + my $str = substr($text, $at); + + unless (length $str) { $str = '(end of string)'; } + + Carp::croak "$error, at character offset $at ($str)"; + } + + + sub _init { + my $opt = $_[1] || {}; + $unmap= $_[0]->{unmapping}; + $unmap= $opt->{unmapping} if(exists $opt->{unmapping}); + $bare = $_[0]->{barekey}; + $bare = $opt->{barekey} if(exists $opt->{barekey}); + $apos = $_[0]->{quotapos}; + $apos = $opt->{quotapos} if(exists $opt->{quotapos}); + $utf8 = $_[0]->{utf8}; + $utf8 = $opt->{utf8} if(exists $opt->{utf8}); + if($utf8 and !$USE_UTF8){ $utf8 = 0; warn "JSON::Parser couldn't use utf8."; } + } + +} # PARSE + + + + +package JSON::NotString; + +use overload ( + '""' => sub { $_[0]->{value} }, + 'bool' => sub { + ! defined $_[0]->{value} ? undef + : $_[0]->{value} eq 'false' ? 0 : 1; + }, + 'eq' => sub { (defined $_[0]->{value} ? $_[0]->{value} : 'null') eq $_[1] }, + 'ne' => sub { (defined $_[0]->{value} ? $_[0]->{value} : 'null') ne $_[1] }, + '==' => sub { (!defined $_[0]->{value} ? -1 : $_[0]->{value} eq 'false' ? 0 : 1) == $_[1] }, + '!=' => sub { (!defined $_[0]->{value} ? -1 : $_[0]->{value} eq 'false' ? 0 : 1) != $_[1] }, +); + +1; + +__END__ + + 'eq' => sub { + if (ref($_[1]) eq 'JSON::NotString') { + return $_[0]->{value} eq $_[1]->{value}; + } + else { + return $_[0]->{value} eq $_[1]; + } + }, + + +=head1 SEE ALSO + +L<http://www.crockford.com/JSON/index.html> + +This module is an implementation of L<http://www.crockford.com/JSON/json.js>. + + +=head1 COPYRIGHT + +makamaka [at] donzoko.net + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=cut |