summaryrefslogtreecommitdiffstats
path: root/qooxdoo/source/perl/JSON
diff options
context:
space:
mode:
Diffstat (limited to 'qooxdoo/source/perl/JSON')
-rwxr-xr-xqooxdoo/source/perl/JSON/Converter.pm473
-rwxr-xr-xqooxdoo/source/perl/JSON/PP.pm1355
-rwxr-xr-xqooxdoo/source/perl/JSON/PP5005.pm82
-rwxr-xr-xqooxdoo/source/perl/JSON/PP56.pm184
-rwxr-xr-xqooxdoo/source/perl/JSON/Parser.pm419
5 files changed, 0 insertions, 2513 deletions
diff --git a/qooxdoo/source/perl/JSON/Converter.pm b/qooxdoo/source/perl/JSON/Converter.pm
deleted file mode 100755
index 1bcc398..0000000
--- a/qooxdoo/source/perl/JSON/Converter.pm
+++ /dev/null
@@ -1,473 +0,0 @@
-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
deleted file mode 100755
index dc2d39a..0000000
--- a/qooxdoo/source/perl/JSON/PP.pm
+++ /dev/null
@@ -1,1355 +0,0 @@
-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
deleted file mode 100755
index c7000b1..0000000
--- a/qooxdoo/source/perl/JSON/PP5005.pm
+++ /dev/null
@@ -1,82 +0,0 @@
-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
deleted file mode 100755
index 2948908..0000000
--- a/qooxdoo/source/perl/JSON/PP56.pm
+++ /dev/null
@@ -1,184 +0,0 @@
-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
deleted file mode 100755
index 7c4e8b4..0000000
--- a/qooxdoo/source/perl/JSON/Parser.pm
+++ /dev/null
@@ -1,419 +0,0 @@
-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
generated by cgit v1.2.3-24-g4f1b (git 2.32.0) at 2024-06-11 20:11:34 +0200