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.97';
@JSON::PP::EXPORT = qw(from_json to_json jsonToObj objToJson);
*jsonToObj = *from_json; # will be obsoleted.
*objToJson = *to_json; # will be obsoleted.
BEGIN {
my @properties = qw(
utf8 allow_nonref indent space_before space_after canonical max_depth shrink
self_encode singlequote allow_bigint disable_UTF8 strict
allow_barekey escape_slash literal_value
allow_blessed convert_blessed relaxed
);
# 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
allow_blessed convert_blessed
/;
my %decode_allow_method
= map {($_ => 1)} qw/utf8 allow_nonref disable_UTF8 strict singlequote allow_bigint
allow_barekey literal_value max_size relaxed/;
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 => 512,
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::PP's indent(3) ... JSON::XS indent(1) 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;
}
# etc
sub filter_json_object {
$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub filter_json_single_key_object {
if (@_ > 1) {
$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
}
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub max_size { # as default is 0, written here.
$_[0]->{max_size} = defined $_[1] ? $_[1] : 0;
$_[0];
}
###############################
###
### 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;
my $allow_blessed;
my $convert_blessed;
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,
$allow_blessed, $convert_blessed)
= @{$self}{qw/indent ascii utf8 self_encode max_depth disable_UTF8 escape_slash latin1
allow_blessed convert_blessed
/};
$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 ($convert_blessed) {
if ( $obj->can('TO_JSON') ) {
return $self->toJson( $obj->TO_JSON() );
}
}
if ($self->{self_encode} and $obj->can('toJson')) {
return $self->selfToJson($obj);
}
elsif (!$obj->isa('JSON::PP::Boolean')) { # handling in valueToJson
encode_error("allow_blessed") unless ($allow_blessed);
return 'null' unless ($convert_blessed);
return 'null';
}
}
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);
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);
}
--$depth;
$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);
my ($pre, $post) = $indent ? $self->_upIndent() : ('', '');
for my $v (@$obj){
push @res, $self->toJson($v) || $self->valueToJson($v);
}
--$depth;
$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::SVp_IOK
or $b_obj->FLAGS & B::SVf_NOK or $b_obj->FLAGS & B::SVp_NOK
) and !($b_obj->FLAGS & B::SVf_POK )
);
my $type = ref($value);
if(!$type){
return _stringfy($self, $value);
}
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
return $$value == 1 ? 'true' : 'false';
}
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 _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
my $max_size;
my $relaxed;
my $cb_object;
my $cb_sk_object;
my $F_HOOK;
# $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,
$max_size, $relaxed, $cb_object, $cb_sk_object, $F_HOOK)
= @{$self}{qw/utf8 literal_value max_depth allow_bigint disable_UTF8 strict singlequote allow_barekey
max_size relaxed cb_object cb_sk_object F_HOOK/};
if ($max_size and $len > $max_size) { # this lines must be up.
decode_error("max_size");
}
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{
if ($strict) {
decode_error('invalid escaped character');
}
$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\x5c]/) { # / ok
decode_error('invalid character');
}
}
$s .= $ch;
}
}
}
if ($relaxed) { # from object(), relaxed
if ((( caller(1) )[3]) =~ /object$/ and $ch eq '}') {
return;
}
}
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{
if ($relaxed and $ch eq '#') {
pos($text) = $at;
$text =~ /\G([^\n]*(?:\r\n|\r|\n))/g;
$at = pos($text);
next_chr;
next;
}
last;
}
}
}
sub object {
my $o = {};
my $k;
if($ch eq '{'){
decode_error('json datastructure exceeds maximum nesting level (set a higher max_depth)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
while(defined $ch){
$k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
white();
if(!defined $ch or $ch ne ':'){
if ($relaxed and $ch eq '}') { # not beautiful...
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
decode_error("Bad object ; ':' expected");
}
next_chr();
$o->{$k} = value();
white();
last if (!defined $ch);
if($ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
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 $JSON::PP::true;
}
elsif($word eq 'null'){
$at += 3;
next_chr;
return undef;
}
elsif($word eq 'fals'){
$at += 3;
if(substr($text,$at,1) eq 'e'){
$at++;
next_chr;
return $JSON::PP::false;
}
}
if ($relaxed) { # from array(), relaxed
if ((( caller(2) )[3]) =~ /array$/ and $ch eq ']') {
return;
}
}
$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){
decode_error("malformed number (leading zero must not be followed by another digit)");
($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
}
else{ # oct
($n) = ( substr($text, $at) =~ /^([0-7]+)/);
if (defined $n and length $n > 1) {
decode_error("malformed number (leading zero must not be followed by another digit)");
}
}
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 '-')){
$n .= $ch;
next_chr;
if (!defined $ch or $ch =~ /\D/) {
decode_error("malformed number (no digits after exp sign)");
}
$n .= $ch;
}
elsif(defined($ch) and $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 datastructure exceeds maximum nesting level (set a higher max_depth)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq ']'){
--$depth;
next_chr();
return $a;
}
while(defined($ch)){
push @$a, value();
white();
if (!defined $ch) {
last;
}
if($ch eq ']'){
--$depth;
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\"]";
}
}
sub _json_object_hook {
my $o = $_[0];
my @ks = keys %{$o};
if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
if (@val == 1) {
return $val[0];
}
}
my @val = $cb_object->($o) if ($cb_object);
if (@val == 0 or @val > 1) {
return $o;
}
else {
return $val[0];
}
}
} # 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;
};
}
}
# shamely copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
sub null { undef; }
###############################
# must be removed
sub JSON::true () { $JSON::PP::true; }
sub JSON::false () { $JSON::PP::false; }
sub JSON::null () { undef; }
###############################
package JSON::PP::Boolean;
use overload
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
"--" => sub { $_[0] = ${$_[0]} - 1 },
'""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
'eq' => \&comp,
fallback => 1;
sub comp {
my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
if ($op eq 'true' or $op eq 'false') {
return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
}
else {
return $obj ? 1 == $op : 0 == $op;
}
}
###############################
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::PP::true
Returns JSON true value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=item JSON::PP::false
Returns JSON false value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=item JSON::PP::null
Returns C<undef>.
=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, 512.
When a large value is set, it may raise a warning 'Deep recursion on subroutin'.
=item max_size
=item relaxed
=item allow_blessed
=item convert_blessed
=item filter_json_object
=item filter_json_single_key_object
=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.
Will be obsoleted.
=item disable_UTF8
If this option is set, UTF8 flag in strings generated
by C<encode>/C<decode> is off.
=item allow_tied
Now disable.
=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 (except for \x2f). While this module can deocde thoese.
But if this option is set, the module strictly decodes.
This option will be obsoleted and 'un-strict' will be added insted.
=item escape_slash
By default, JSON::PP encodes strings without escaping slash (U+002F).
Setting the option to escape slash.
=back
=head1 MAPPING
Now same as JSON::XS.
=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