Context Navigation

PP.pm@ 31781

Last change on this file since 31781 was 31781, checked in by ak19, 7 years ago
Adding in patches to cpan perl code as required to get the remote greenstone server to still work with perl v 5.22.1. Not tested these changes with out usual perl 5.18. I'm not getting a newer version of these modules from CPAN since I'm not sure whether there may be some compatibility issues of the newer versions with our existing code. So I'm making the smallest number of changes that will keep our code still working.
Property svn:executable set to ``*
File size: 58.7 KB

Line
1	package JSON::PP;
2
3	# JSON-2.0
4
5	use 5.005;
6	use strict;
7	use base qw(Exporter);
8	use overload ();
9
10	use Carp ();
11	use B ();
12	#use Devel::Peek;
13
14	$JSON::PP::VERSION = '2.27008';
15
16	@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
17
18	# instead of hash-access, i tried index-access for speed.
19	# but this method is not faster than what i expected. so it will be changed.
20
21	use constant P_ASCII => 0;
22	use constant P_LATIN1 => 1;
23	use constant P_UTF8 => 2;
24	use constant P_INDENT => 3;
25	use constant P_CANONICAL => 4;
26	use constant P_SPACE_BEFORE => 5;
27	use constant P_SPACE_AFTER => 6;
28	use constant P_ALLOW_NONREF => 7;
29	use constant P_SHRINK => 8;
30	use constant P_ALLOW_BLESSED => 9;
31	use constant P_CONVERT_BLESSED => 10;
32	use constant P_RELAXED => 11;
33
34	use constant P_LOOSE => 12;
35	use constant P_ALLOW_BIGNUM => 13;
36	use constant P_ALLOW_BAREKEY => 14;
37	use constant P_ALLOW_SINGLEQUOTE => 15;
38	use constant P_ESCAPE_SLASH => 16;
39	use constant P_AS_NONBLESSED => 17;
40
41	use constant P_ALLOW_UNKNOWN => 18;
42
43	use constant OLD_PERL => $] < 5.008 ? 1 : 0;
44
45	BEGIN {
46	my @xs_compati_bit_properties = qw(
47	latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
48	allow_blessed convert_blessed relaxed allow_unknown
49	);
50	my @pp_bit_properties = qw(
51	allow_singlequote allow_bignum loose
52	allow_barekey escape_slash as_nonblessed
53	);
54
55	# Perl version check, Unicode handling is enable?
56	# Helper module sets @JSON::PP::_properties.
57
58	my $helper = $] >= 5.008 ? 'JSON::PP58'
59	: $] >= 5.006 ? 'JSON::PP56'
60	: 'JSON::PP5005'
61	;
62
63	eval qq\| require $helper \|;
64	if ($@) { Carp::croak $@; }
65
66	for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
67	my $flag_name = 'P_' . uc($name);
68
69	eval qq/
70	sub $name {
71	my \$enable = defined \$_[1] ? \$_[1] : 1;
72
73	if (\$enable) {
74	\$_[0]->{PROPS}->[$flag_name] = 1;
75	}
76	else {
77	\$_[0]->{PROPS}->[$flag_name] = 0;
78	}
79
80	\$_[0];
81	}
82
83	sub get_$name {
84	\$_[0]->{PROPS}->[$flag_name] ? 1 : '';
85	}
86	/;
87	}
88
89	}
90
91
92
93	# Functions
94
95	my %encode_allow_method
96	= map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
97	allow_blessed convert_blessed indent indent_length allow_bignum
98	as_nonblessed
99	/;
100	my %decode_allow_method
101	= map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
102	allow_barekey max_size relaxed/;
103
104
105	my $JSON; # cache
106
107	sub encode_json ($) { # encode
108	($JSON \|\|= __PACKAGE__->new->utf8)->encode(@_);
109	}
110
111
112	sub decode_json { # decode
113	($JSON \|\|= __PACKAGE__->new->utf8)->decode(@_);
114	}
115
116	# Obsoleted
117
118	sub to_json($) {
119	Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
120	}
121
122
123	sub from_json($) {
124	Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
125	}
126
127
128	# Methods
129
130	sub new {
131	my $class = shift;
132	my $self = {
133	max_depth => 512,
134	max_size => 0,
135	indent => 0,
136	FLAGS => 0,
137	fallback => sub { encode_error('Invalid value. JSON can only reference.') },
138	indent_length => 3,
139	};
140
141	bless $self, $class;
142	}
143
144
145	sub encode {
146	return $_[0]->PP_encode_json($_[1]);
147	}
148
149
150	sub decode {
151	return $_[0]->PP_decode_json($_[1], 0x00000000);
152	}
153
154
155	sub decode_prefix {
156	return $_[0]->PP_decode_json($_[1], 0x00000001);
157	}
158
159
160	# accessor
161
162
163	# pretty printing
164
165	sub pretty {
166	my ($self, $v) = @_;
167	my $enable = defined $v ? $v : 1;
168
169	if ($enable) { # indent_length(3) for JSON::XS compatibility
170	$self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
171	}
172	else {
173	$self->indent(0)->space_before(0)->space_after(0);
174	}
175
176	$self;
177	}
178
179	# etc
180
181	sub max_depth {
182	my $max = defined $_[1] ? $_[1] : 0x80000000;
183	$_[0]->{max_depth} = $max;
184	$_[0];
185	}
186
187
188	sub get_max_depth { $_[0]->{max_depth}; }
189
190
191	sub max_size {
192	my $max = defined $_[1] ? $_[1] : 0;
193	$_[0]->{max_size} = $max;
194	$_[0];
195	}
196
197
198	sub get_max_size { $_[0]->{max_size}; }
199
200
201	sub filter_json_object {
202	$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
203	$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
204	$_[0];
205	}
206
207	sub filter_json_single_key_object {
208	if (@_ > 1) {
209	$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
210	}
211	$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
212	$_[0];
213	}
214
215	sub indent_length {
216	if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
217	Carp::carp "The acceptable range of indent_length() is 0 to 15.";
218	}
219	else {
220	$_[0]->{indent_length} = $_[1];
221	}
222	$_[0];
223	}
224
225	sub get_indent_length {
226	$_[0]->{indent_length};
227	}
228
229	sub sort_by {
230	$_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
231	$_[0];
232	}
233
234	sub allow_bigint {
235	Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
236	}
237
238	###############################
239
240	###
241	### Perl => JSON
242	###
243
244
245	{ # Convert
246
247	my $max_depth;
248	my $indent;
249	my $ascii;
250	my $latin1;
251	my $utf8;
252	my $space_before;
253	my $space_after;
254	my $canonical;
255	my $allow_blessed;
256	my $convert_blessed;
257
258	my $indent_length;
259	my $escape_slash;
260	my $bignum;
261	my $as_nonblessed;
262
263	my $depth;
264	my $indent_count;
265	my $keysort;
266
267
268	sub PP_encode_json {
269	my $self = shift;
270	my $obj = shift;
271
272	$indent_count = 0;
273	$depth = 0;
274
275	my $idx = $self->{PROPS};
276
277	($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
278	$convert_blessed, $escape_slash, $bignum, $as_nonblessed)
279	= @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
280	P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
281
282	($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
283
284	$keysort = $canonical ? sub { $a cmp $b } : undef;
285
286	if ($self->{sort_by}) {
287	$keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
288	: $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
289	: sub { $a cmp $b };
290	}
291
292	encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
293	if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
294
295	my $str = $self->object_to_json($obj);
296
297	$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
298
299	unless ($ascii or $latin1 or $utf8) {
300	utf8::upgrade($str);
301	}
302
303	if ($idx->[ P_SHRINK ]) {
304	utf8::downgrade($str, 1);
305	}
306
307	return $str;
308	}
309
310
311	sub object_to_json {
312	my ($self, $obj) = @_;
313	my $type = ref($obj);
314
315	if($type eq 'HASH'){
316	return $self->hash_to_json($obj);
317	}
318	elsif($type eq 'ARRAY'){
319	return $self->array_to_json($obj);
320	}
321	elsif ($type) { # blessed object?
322	if (blessed($obj)) {
323
324	return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
325
326	if ( $convert_blessed and $obj->can('TO_JSON') ) {
327	my $result = $obj->TO_JSON();
328	if ( defined $result and overload::Overloaded( $obj ) ) {
329	if ( overload::StrVal( $obj ) eq $result ) {
330	encode_error( sprintf(
331	"%s::TO_JSON method returned same object as was passed instead of a new one",
332	ref $obj
333	) );
334	}
335	}
336
337	return $self->object_to_json( $result );
338	}
339
340	return "$obj" if ( $bignum and _is_bignum($obj) );
341	return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
342
343	encode_error( sprintf("encountered object '%s', but neither allow_blessed "
344	. "nor convert_blessed settings are enabled", $obj)
345	) unless ($allow_blessed);
346
347	return 'null';
348	}
349	else {
350	return $self->value_to_json($obj);
351	}
352	}
353	else{
354	return $self->value_to_json($obj);
355	}
356	}
357
358
359	sub hash_to_json {
360	my ($self, $obj) = @_;
361	my @res;
362
363	encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
364	if (++$depth > $max_depth);
365
366	my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
367	my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
368
369	for my $k ( _sort( $obj ) ) {
370	if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
371	push @res, string_to_json( $self, $k )
372	. $del
373	. ( $self->object_to_json( $obj->{$k} ) \|\| $self->value_to_json( $obj->{$k} ) );
374	}
375
376	--$depth;
377	$self->_down_indent() if ($indent);
378
379	return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
380	}
381
382
383	sub array_to_json {
384	my ($self, $obj) = @_;
385	my @res;
386
387	encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
388	if (++$depth > $max_depth);
389
390	my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
391
392	for my $v (@$obj){
393	push @res, $self->object_to_json($v) \|\| $self->value_to_json($v);
394	}
395
396	--$depth;
397	$self->_down_indent() if ($indent);
398
399	return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
400	}
401
402
403	sub value_to_json {
404	my ($self, $value) = @_;
405
406	return 'null' if(!defined $value);
407
408	my $b_obj = B::svref_2object(\$value); # for round trip problem
409	my $flags = $b_obj->FLAGS;
410
411	return $value # as is
412	if $flags & ( B::SVp_IOK \| B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
413
414	my $type = ref($value);
415
416	if(!$type){
417	return string_to_json($self, $value);
418	}
419	elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
420	return $$value == 1 ? 'true' : 'false';
421	}
422	elsif ($type) {
423	if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
424	return $self->value_to_json("$value");
425	}
426
427	if ($type eq 'SCALAR' and defined $$value) {
428	return $$value eq '1' ? 'true'
429	: $$value eq '0' ? 'false'
430	: $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
431	: encode_error("cannot encode reference to scalar");
432	}
433
434	if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
435	return 'null';
436	}
437	else {
438	if ( $type eq 'SCALAR' or $type eq 'REF' ) {
439	encode_error("cannot encode reference to scalar");
440	}
441	else {
442	encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
443	}
444	}
445
446	}
447	else {
448	return $self->{fallback}->($value)
449	if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
450	return 'null';
451	}
452
453	}
454
455
456	my %esc = (
457	"\n" => '\n',
458	"\r" => '\r',
459	"\t" => '\t',
460	"\f" => '\f',
461	"\b" => '\b',
462	"\"" => '\"',
463	"\\" => '\\\\',
464	"\'" => '\\\'',
465	);
466
467
468	sub string_to_json {
469	my ($self, $arg) = @_;
470
471	$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
472	$arg =~ s/\//\\\//g if ($escape_slash);
473	$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
474
475	if ($ascii) {
476	$arg = JSON_PP_encode_ascii($arg);
477	}
478
479	if ($latin1) {
480	$arg = JSON_PP_encode_latin1($arg);
481	}
482
483	if ($utf8) {
484	utf8::encode($arg);
485	}
486
487	return '"' . $arg . '"';
488	}
489
490
491	sub blessed_to_json {
492	my $reftype = reftype($_[1]) \|\| '';
493	if ($reftype eq 'HASH') {
494	return $_[0]->hash_to_json($_[1]);
495	}
496	elsif ($reftype eq 'ARRAY') {
497	return $_[0]->array_to_json($_[1]);
498	}
499	else {
500	return 'null';
501	}
502	}
503
504
505	sub encode_error {
506	my $error = shift;
507	Carp::croak "$error";
508	}
509
510
511	sub _sort {
512	defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
513	}
514
515
516	sub _up_indent {
517	my $self = shift;
518	my $space = ' ' x $indent_length;
519
520	my ($pre,$post) = ('','');
521
522	$post = "\n" . $space x $indent_count;
523
524	$indent_count++;
525
526	$pre = "\n" . $space x $indent_count;
527
528	return ($pre,$post);
529	}
530
531
532	sub _down_indent { $indent_count--; }
533
534
535	sub PP_encode_box {
536	{
537	depth => $depth,
538	indent_count => $indent_count,
539	};
540	}
541
542	} # Convert
543
544
545	sub _encode_ascii {
546	join('',
547	map {
548	$_ <= 127 ?
549	chr($_) :
550	$_ <= 65535 ?
551	sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
552	} unpack('U*', $_[0])
553	);
554	}
555
556
557	sub _encode_latin1 {
558	join('',
559	map {
560	$_ <= 255 ?
561	chr($_) :
562	$_ <= 65535 ?
563	sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
564	} unpack('U*', $_[0])
565	);
566	}
567
568
569	sub _encode_surrogates { # from perlunicode
570	my $uni = $_[0] - 0x10000;
571	return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
572	}
573
574
575	sub _is_bignum {
576	$_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
577	}
578
579
580
581	#
582	# JSON => Perl
583	#
584
585	my $max_intsize;
586
587	BEGIN {
588	my $checkint = 1111;
589	for my $d (5..64) {
590	$checkint .= 1;
591	my $int = eval qq\| $checkint \|;
592	if ($int =~ /[eE]/) {
593	$max_intsize = $d - 1;
594	last;
595	}
596	}
597	}
598
599	{ # PARSE
600
601	my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
602	b => "\x8",
603	t => "\x9",
604	n => "\xA",
605	f => "\xC",
606	r => "\xD",
607	'\\' => '\\',
608	'"' => '"',
609	'/' => '/',
610	);
611
612	my $text; # json data
613	my $at; # offset
614	my $ch; # 1chracter
615	my $len; # text length (changed according to UTF8 or NON UTF8)
616	# INTERNAL
617	my $depth; # nest counter
618	my $encoding; # json text encoding
619	my $is_valid_utf8; # temp variable
620	my $utf8_len; # utf8 byte length
621	# FLAGS
622	my $utf8; # must be utf8
623	my $max_depth; # max nest nubmer of objects and arrays
624	my $max_size;
625	my $relaxed;
626	my $cb_object;
627	my $cb_sk_object;
628
629	my $F_HOOK;
630
631	my $allow_bigint; # using Math::BigInt
632	my $singlequote; # loosely quoting
633	my $loose; #
634	my $allow_barekey; # bareKey
635
636	# $opt flag
637	# 0x00000001 .... decode_prefix
638	# 0x10000000 .... incr_parse
639
640	sub PP_decode_json {
641	my ($self, $opt); # $opt is an effective flag during this decode_json.
642
643	($self, $text, $opt) = @_;
644
645	($at, $ch, $depth) = (0, '', 0);
646
647	if ( !defined $text or ref $text ) {
648	decode_error("malformed JSON string, neither array, object, number, string or atom");
649	}
650
651	my $idx = $self->{PROPS};
652
653	($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
654	= @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
655
656	if ( $utf8 ) {
657	utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
658	}
659	else {
660	utf8::upgrade( $text );
661	}
662
663	$len = length $text;
664
665	($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
666	= @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
667
668	if ($max_size > 1) {
669	use bytes;
670	my $bytes = length $text;
671	decode_error(
672	sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
673	, $bytes, $max_size), 1
674	) if ($bytes > $max_size);
675	}
676
677	# Currently no effect
678	# should use regexp
679	my @octets = unpack('C4', $text);
680	$encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
681	: (!$octets[0] and $octets[1]) ? 'UTF-16BE'
682	: (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
683	: ( $octets[2] ) ? 'UTF-16LE'
684	: (!$octets[2] ) ? 'UTF-32LE'
685	: 'unknown';
686
687	white(); # remove head white space
688
689	my $valid_start = defined $ch; # Is there a first character for JSON structure?
690
691	my $result = value();
692
693	return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
694
695	decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
696
697	if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
698	decode_error(
699	'JSON text must be an object or array (but found number, string, true, false or null,'
700	. ' use allow_nonref to allow this)', 1);
701	}
702
703	Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
704
705	my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
706
707	white(); # remove tail white space
708
709	if ( $ch ) {
710	return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
711	decode_error("garbage after JSON object");
712	}
713
714	( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
715	}
716
717
718	sub next_chr {
719	return $ch = undef if($at >= $len);
720	$ch = substr($text, $at++, 1);
721	}
722
723
724	sub value {
725	white();
726	return if(!defined $ch);
727	return object() if($ch eq '{');
728	return array() if($ch eq '[');
729	return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
730	return number() if($ch =~ /[0-9]/ or $ch eq '-');
731	return word();
732	}
733
734	sub string {
735	my ($i, $s, $t, $u);
736	my $utf16;
737	my $is_utf8;
738
739	($is_valid_utf8, $utf8_len) = ('', 0);
740
741	$s = ''; # basically UTF8 flag on
742
743	if($ch eq '"' or ($singlequote and $ch eq "'")){
744	my $boundChar = $ch;
745
746	OUTER: while( defined(next_chr()) ){
747
748	if($ch eq $boundChar){
749	next_chr();
750
751	if ($utf16) {
752	decode_error("missing low surrogate character in surrogate pair");
753	}
754
755	utf8::decode($s) if($is_utf8);
756
757	return $s;
758	}
759	elsif($ch eq '\\'){
760	next_chr();
761	if(exists $escapes{$ch}){
762	$s .= $escapes{$ch};
763	}
764	elsif($ch eq 'u'){ # UNICODE handling
765	my $u = '';
766
767	for(1..4){
768	$ch = next_chr();
769	last OUTER if($ch !~ /[0-9a-fA-F]/);
770	$u .= $ch;
771	}
772
773	# U+D800 - U+DBFF
774	if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
775	$utf16 = $u;
776	}
777	# U+DC00 - U+DFFF
778	elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
779	unless (defined $utf16) {
780	decode_error("missing high surrogate character in surrogate pair");
781	}
782	$is_utf8 = 1;
783	$s .= JSON_PP_decode_surrogates($utf16, $u) \|\| next;
784	$utf16 = undef;
785	}
786	else {
787	if (defined $utf16) {
788	decode_error("surrogate pair expected");
789	}
790
791	if ( ( my $hex = hex( $u ) ) > 127 ) {
792	$is_utf8 = 1;
793	$s .= JSON_PP_decode_unicode($u) \|\| next;
794	}
795	else {
796	$s .= chr $hex;
797	}
798	}
799
800	}
801	else{
802	unless ($loose) {
803	$at -= 2;
804	decode_error('illegal backslash escape sequence in string');
805	}
806	$s .= $ch;
807	}
808	}
809	else{
810
811	if ( ord $ch > 127 ) {
812	if ( $utf8 ) {
813	unless( $ch = is_valid_utf8($ch) ) {
814	$at -= 1;
815	decode_error("malformed UTF-8 character in JSON string");
816	}
817	else {
818	$at += $utf8_len - 1;
819	}
820	}
821	else {
822	utf8::encode( $ch );
823	}
824
825	$is_utf8 = 1;
826	}
827
828	if (!$loose) {
829	if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
830	$at--;
831	decode_error('invalid character encountered while parsing JSON string');
832	}
833	}
834
835	$s .= $ch;
836	}
837	}
838	}
839
840	decode_error("unexpected end of string while parsing JSON string");
841	}
842
843
844	sub white {
845	while( defined $ch ){
846	if($ch le ' '){
847	next_chr();
848	}
849	elsif($ch eq '/'){
850	next_chr();
851	if(defined $ch and $ch eq '/'){
852	1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
853	}
854	elsif(defined $ch and $ch eq '*'){
855	next_chr();
856	while(1){
857	if(defined $ch){
858	if($ch eq '*'){
859	if(defined(next_chr()) and $ch eq '/'){
860	next_chr();
861	last;
862	}
863	}
864	else{
865	next_chr();
866	}
867	}
868	else{
869	decode_error("Unterminated comment");
870	}
871	}
872	next;
873	}
874	else{
875	$at--;
876	decode_error("malformed JSON string, neither array, object, number, string or atom");
877	}
878	}
879	else{
880	if ($relaxed and $ch eq '#') { # correctly?
881	pos($text) = $at;
882	$text =~ /\G([^\n]*(?:\r\n\|\r\|\n\|$))/g;
883	$at = pos($text);
884	next_chr;
885	next;
886	}
887
888	last;
889	}
890	}
891	}
892
893
894	sub array {
895	my $a = [];
896
897	decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
898	if (++$depth > $max_depth);
899
900	next_chr();
901	white();
902
903	if(defined $ch and $ch eq ']'){
904	--$depth;
905	next_chr();
906	return $a;
907	}
908	else {
909	while(defined($ch)){
910	push @$a, value();
911
912	white();
913
914	if (!defined $ch) {
915	last;
916	}
917
918	if($ch eq ']'){
919	--$depth;
920	next_chr();
921	return $a;
922	}
923
924	if($ch ne ','){
925	last;
926	}
927
928	next_chr();
929	white();
930
931	if ($relaxed and $ch eq ']') {
932	--$depth;
933	next_chr();
934	return $a;
935	}
936
937	}
938	}
939
940	decode_error(", or ] expected while parsing array");
941	}
942
943
944	sub object {
945	my $o = {};
946	my $k;
947
948	decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
949	if (++$depth > $max_depth);
950	next_chr();
951	white();
952
953	if(defined $ch and $ch eq '}'){
954	--$depth;
955	next_chr();
956	if ($F_HOOK) {
957	return _json_object_hook($o);
958	}
959	return $o;
960	}
961	else {
962	while (defined $ch) {
963	$k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
964	white();
965
966	if(!defined $ch or $ch ne ':'){
967	$at--;
968	decode_error("':' expected");
969	}
970
971	next_chr();
972	$o->{$k} = value();
973	white();
974
975	last if (!defined $ch);
976
977	if($ch eq '}'){
978	--$depth;
979	next_chr();
980	if ($F_HOOK) {
981	return _json_object_hook($o);
982	}
983	return $o;
984	}
985
986	if($ch ne ','){
987	last;
988	}
989
990	next_chr();
991	white();
992
993	if ($relaxed and $ch eq '}') {
994	--$depth;
995	next_chr();
996	if ($F_HOOK) {
997	return _json_object_hook($o);
998	}
999	return $o;
1000	}
1001
1002	}
1003
1004	}
1005
1006	$at--;
1007	decode_error(", or } expected while parsing object/hash");
1008	}
1009
1010
1011	sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
1012	my $key;
1013	while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
1014	$key .= $ch;
1015	next_chr();
1016	}
1017	return $key;
1018	}
1019
1020
1021	sub word {
1022	my $word = substr($text,$at-1,4);
1023
1024	if($word eq 'true'){
1025	$at += 3;
1026	next_chr;
1027	return $JSON::PP::true;
1028	}
1029	elsif($word eq 'null'){
1030	$at += 3;
1031	next_chr;
1032	return undef;
1033	}
1034	elsif($word eq 'fals'){
1035	$at += 3;
1036	if(substr($text,$at,1) eq 'e'){
1037	$at++;
1038	next_chr;
1039	return $JSON::PP::false;
1040	}
1041	}
1042
1043	$at--; # for decode_error report
1044
1045	decode_error("'null' expected") if ($word =~ /^n/);
1046	decode_error("'true' expected") if ($word =~ /^t/);
1047	decode_error("'false' expected") if ($word =~ /^f/);
1048	decode_error("malformed JSON string, neither array, object, number, string or atom");
1049	}
1050
1051
1052	sub number {
1053	my $n = '';
1054	my $v;
1055
1056	# According to RFC4627, hex or oct digts are invalid.
1057	if($ch eq '0'){
1058	my $peek = substr($text,$at,1);
1059	my $hex = $peek =~ /[xX]/; # 0 or 1
1060
1061	if($hex){
1062	decode_error("malformed number (leading zero must not be followed by another digit)");
1063	($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
1064	}
1065	else{ # oct
1066	($n) = ( substr($text, $at) =~ /^([0-7]+)/);
1067	if (defined $n and length $n > 1) {
1068	decode_error("malformed number (leading zero must not be followed by another digit)");
1069	}
1070	}
1071
1072	if(defined $n and length($n)){
1073	if (!$hex and length($n) == 1) {
1074	decode_error("malformed number (leading zero must not be followed by another digit)");
1075	}
1076	$at += length($n) + $hex;
1077	next_chr;
1078	return $hex ? hex($n) : oct($n);
1079	}
1080	}
1081
1082	if($ch eq '-'){
1083	$n = '-';
1084	next_chr;
1085	if (!defined $ch or $ch !~ /\d/) {
1086	decode_error("malformed number (no digits after initial minus)");
1087	}
1088	}
1089
1090	while(defined $ch and $ch =~ /\d/){
1091	$n .= $ch;
1092	next_chr;
1093	}
1094
1095	if(defined $ch and $ch eq '.'){
1096	$n .= '.';
1097
1098	next_chr;
1099	if (!defined $ch or $ch !~ /\d/) {
1100	decode_error("malformed number (no digits after decimal point)");
1101	}
1102	else {
1103	$n .= $ch;
1104	}
1105
1106	while(defined(next_chr) and $ch =~ /\d/){
1107	$n .= $ch;
1108	}
1109	}
1110
1111	if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
1112	$n .= $ch;
1113	next_chr;
1114
1115	if(defined($ch) and ($ch eq '+' or $ch eq '-')){
1116	$n .= $ch;
1117	next_chr;
1118	if (!defined $ch or $ch =~ /\D/) {
1119	decode_error("malformed number (no digits after exp sign)");
1120	}
1121	$n .= $ch;
1122	}
1123	elsif(defined($ch) and $ch =~ /\d/){
1124	$n .= $ch;
1125	}
1126	else {
1127	decode_error("malformed number (no digits after exp sign)");
1128	}
1129
1130	while(defined(next_chr) and $ch =~ /\d/){
1131	$n .= $ch;
1132	}
1133
1134	}
1135
1136	$v .= $n;
1137
1138	if ($v !~ /[.eE]/ and length $v > $max_intsize) {
1139	if ($allow_bigint) { # from Adam Sussman
1140	require Math::BigInt;
1141	return Math::BigInt->new($v);
1142	}
1143	else {
1144	return "$v";
1145	}
1146	}
1147	elsif ($allow_bigint) {
1148	require Math::BigFloat;
1149	return Math::BigFloat->new($v);
1150	}
1151
1152	return 0+$v;
1153	}
1154
1155
1156	sub is_valid_utf8 {
1157
1158	$utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
1159	: $_[0] =~ /[\xC2-\xDF]/ ? 2
1160	: $_[0] =~ /[\xE0-\xEF]/ ? 3
1161	: $_[0] =~ /[\xF0-\xF4]/ ? 4
1162	: 0
1163	;
1164
1165	return unless $utf8_len;
1166
1167	my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
1168
1169	return ( $is_valid_utf8 =~ /^(?:
1170	[\x00-\x7F]
1171	\|[\xC2-\xDF][\x80-\xBF]
1172	\|[\xE0][\xA0-\xBF][\x80-\xBF]
1173	\|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
1174	\|[\xED][\x80-\x9F][\x80-\xBF]
1175	\|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
1176	\|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
1177	\|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
1178	\|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
1179	)$/x ) ? $is_valid_utf8 : '';
1180	}
1181
1182
1183	sub decode_error {
1184	my $error = shift;
1185	my $no_rep = shift;
1186	my $str = defined $text ? substr($text, $at) : '';
1187	my $mess = '';
1188	my $type = $] >= 5.008 ? 'U*'
1189	: $] < 5.006 ? 'C*'
1190	: utf8::is_utf8( $str ) ? 'U*' # 5.6
1191	: 'C*'
1192	;
1193
1194	for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
1195	$mess .= $c == 0x07 ? '\a'
1196	: $c == 0x09 ? '\t'
1197	: $c == 0x0a ? '\n'
1198	: $c == 0x0d ? '\r'
1199	: $c == 0x0c ? '\f'
1200	: $c < 0x20 ? sprintf('\x{%x}', $c)
1201	: $c == 0x5c ? '\\\\'
1202	: $c < 0x80 ? chr($c)
1203	: sprintf('\x{%x}', $c)
1204	;
1205	if ( length $mess >= 20 ) {
1206	$mess .= '...';
1207	last;
1208	}
1209	}
1210
1211	unless ( length $mess ) {
1212	$mess = '(end of string)';
1213	}
1214
1215	Carp::croak (
1216	$no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
1217	);
1218
1219	}
1220
1221
1222	sub _json_object_hook {
1223	my $o = $_[0];
1224	my @ks = keys %{$o};
1225
1226	if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
1227	my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
1228	if (@val == 1) {
1229	return $val[0];
1230	}
1231	}
1232
1233	my @val = $cb_object->($o) if ($cb_object);
1234	if (@val == 0 or @val > 1) {
1235	return $o;
1236	}
1237	else {
1238	return $val[0];
1239	}
1240	}
1241
1242
1243	sub PP_decode_box {
1244	{
1245	text => $text,
1246	at => $at,
1247	ch => $ch,
1248	len => $len,
1249	depth => $depth,
1250	encoding => $encoding,
1251	is_valid_utf8 => $is_valid_utf8,
1252	};
1253	}
1254
1255	} # PARSE
1256
1257
1258	sub _decode_surrogates { # from perlunicode
1259	my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
1260	my $un = pack('U*', $uni);
1261	utf8::encode( $un );
1262	return $un;
1263	}
1264
1265
1266	sub _decode_unicode {
1267	my $un = pack('U', hex shift);
1268	utf8::encode( $un );
1269	return $un;
1270	}
1271
1272
1273
1274
1275
1276	###############################
1277	# Utilities
1278	#
1279
1280	BEGIN {
1281	eval 'require Scalar::Util';
1282	unless($@){
1283	*JSON::PP::blessed = \&Scalar::Util::blessed;
1284	*JSON::PP::reftype = \&Scalar::Util::reftype;
1285	}
1286	else{ # This code is from Sclar::Util.
1287	# warn $@;
1288	eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
1289	*JSON::PP::blessed = sub {
1290	local($@, $SIG{__DIE__}, $SIG{__WARN__});
1291	ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
1292	};
1293	my %tmap = qw(
1294	B::NULL SCALAR
1295	B::HV HASH
1296	B::AV ARRAY
1297	B::CV CODE
1298	B::IO IO
1299	B::GV GLOB
1300	B::REGEXP REGEXP
1301	);
1302	*JSON::PP::reftype = sub {
1303	my $r = shift;
1304
1305	return undef unless length(ref($r));
1306
1307	my $t = ref(B::svref_2object($r));
1308
1309	return
1310	exists $tmap{$t} ? $tmap{$t}
1311	: length(ref($$r)) ? 'REF'
1312	: 'SCALAR';
1313	};
1314	}
1315	}
1316
1317
1318	# shamely copied and modified from JSON::XS code.
1319
1320	$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
1321	$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
1322
1323	sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
1324
1325	sub true { $JSON::PP::true }
1326	sub false { $JSON::PP::false }
1327	sub null { undef; }
1328
1329	###############################
1330
1331	package JSON::PP::Boolean;
1332
1333
1334	use overload (
1335	"0+" => sub { ${$_[0]} },
1336	"++" => sub { $_[0] = ${$_[0]} + 1 },
1337	"--" => sub { $_[0] = ${$_[0]} - 1 },
1338	fallback => 1,
1339	);
1340
1341
1342	###############################
1343
1344	package JSON::PP::IncrParser;
1345
1346	use strict;
1347
1348	use constant INCR_M_WS => 0; # initial whitespace skipping
1349	use constant INCR_M_STR => 1; # inside string
1350	use constant INCR_M_BS => 2; # inside backslash
1351	use constant INCR_M_JSON => 3; # outside anything, count nesting
1352	use constant INCR_M_C0 => 4;
1353	use constant INCR_M_C1 => 5;
1354
1355	$JSON::PP::IncrParser::VERSION = '1.01';
1356
1357	my $unpack_format = $] < 5.006 ? 'C' : 'U';
1358
1359	sub new {
1360	my ( $class ) = @_;
1361
1362	bless {
1363	incr_nest => 0,
1364	incr_text => undef,
1365	incr_parsing => 0,
1366	incr_p => 0,
1367	}, $class;
1368	}
1369
1370
1371	sub incr_parse {
1372	my ( $self, $coder, $text ) = @_;
1373
1374	$self->{incr_text} = '' unless ( defined $self->{incr_text} );
1375
1376	if ( defined $text ) {
1377	if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
1378	utf8::upgrade( $self->{incr_text} ) ;
1379	utf8::decode( $self->{incr_text} ) ;
1380	}
1381	$self->{incr_text} .= $text;
1382	}
1383
1384
1385	my $max_size = $coder->get_max_size;
1386
1387	if ( defined wantarray ) {
1388
1389	$self->{incr_mode} = INCR_M_WS;
1390
1391	if ( wantarray ) {
1392	my @ret;
1393
1394	$self->{incr_parsing} = 1;
1395
1396	do {
1397	push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
1398
1399	unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
1400	$self->{incr_mode} = INCR_M_WS;
1401	}
1402
1403	} until ( !$self->{incr_text} );
1404
1405	$self->{incr_parsing} = 0;
1406
1407	return @ret;
1408	}
1409	else { # in scalar context
1410	$self->{incr_parsing} = 1;
1411	my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
1412	$self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
1413	return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
1414	}
1415
1416	}
1417
1418	}
1419
1420
1421	sub _incr_parse {
1422	my ( $self, $coder, $text, $skip ) = @_;
1423	my $p = $self->{incr_p};
1424	my $restore = $p;
1425
1426	my @obj;
1427	my $len = length $text;
1428
1429	if ( $self->{incr_mode} == INCR_M_WS ) {
1430	while ( $len > $p ) {
1431	my $s = substr( $text, $p, 1 );
1432	$p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
1433	$self->{incr_mode} = INCR_M_JSON;
1434	last;
1435	}
1436	}
1437
1438	while ( $len > $p ) {
1439	my $s = substr( $text, $p++, 1 );
1440
1441	if ( $s eq '"' ) {
1442	if ( $self->{incr_mode} != INCR_M_STR ) {
1443	$self->{incr_mode} = INCR_M_STR;
1444	}
1445	else {
1446	$self->{incr_mode} = INCR_M_JSON;
1447	unless ( $self->{incr_nest} ) {
1448	last;
1449	}
1450	}
1451	}
1452
1453	if ( $self->{incr_mode} == INCR_M_JSON ) {
1454
1455	if ( $s eq '[' or $s eq '{' ) {
1456	if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
1457	Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
1458	}
1459	}
1460	elsif ( $s eq ']' or $s eq '}' ) {
1461	last if ( --$self->{incr_nest} <= 0 );
1462	}
1463	elsif ( $s eq '#' ) {
1464	while ( $len > $p ) {
1465	last if substr( $text, $p++, 1 ) eq "\n";
1466	}
1467	}
1468
1469	}
1470
1471	}
1472
1473	$self->{incr_p} = $p;
1474
1475	return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
1476
1477	return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
1478
1479	local $Carp::CarpLevel = 2;
1480
1481	$self->{incr_p} = $restore;
1482	$self->{incr_c} = $p;
1483
1484	my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
1485
1486	$self->{incr_text} = substr( $self->{incr_text}, $p );
1487	$self->{incr_p} = 0;
1488
1489	# To avoid syntax errors in newer versions of perl,
1490	# putting the return in brackets as explained at
1491	# https://rt.cpan.org/Public/Bug/Display.html?id=87302
1492	# "returns binds stronger than or, so the expressions after or are ignored.
1493	# See https://rt.perl.org/rt3/Public/Bug/Display.html?id=59802"
1494	return ($obj or '');
1495	}
1496
1497
1498	sub incr_text {
1499	if ( $_[0]->{incr_parsing} ) {
1500	Carp::croak("incr_text can not be called when the incremental parser already started parsing");
1501	}
1502	$_[0]->{incr_text};
1503	}
1504
1505
1506	sub incr_skip {
1507	my $self = shift;
1508	$self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
1509	$self->{incr_p} = 0;
1510	}
1511
1512
1513	sub incr_reset {
1514	my $self = shift;
1515	$self->{incr_text} = undef;
1516	$self->{incr_p} = 0;
1517	$self->{incr_mode} = 0;
1518	$self->{incr_nest} = 0;
1519	$self->{incr_parsing} = 0;
1520	}
1521
1522	###############################
1523
1524
1525	1;
1526	__END__
1527	=pod
1528
1529	=head1 NAME
1530
1531	JSON::PP - JSON::XS compatible pure-Perl module.
1532
1533	=head1 SYNOPSIS
1534
1535	use JSON::PP;
1536
1537	# exported functions, they croak on error
1538	# and expect/generate UTF-8
1539
1540	$utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
1541	$perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
1542
1543	# OO-interface
1544
1545	$coder = JSON::PP->new->ascii->pretty->allow_nonref;
1546	$pretty_printed_unencoded = $coder->encode ($perl_scalar);
1547	$perl_scalar = $coder->decode ($unicode_json_text);
1548
1549	# Note that JSON version 2.0 and above will automatically use
1550	# JSON::XS or JSON::PP, so you should be able to just:
1551
1552	use JSON;
1553
1554	=head1 DESCRIPTION
1555
1556	This module is L<JSON::XS> compatible pure Perl module.
1557	(Perl 5.8 or later is recommended)
1558
1559	JSON::XS is the fastest and most proper JSON module on CPAN.
1560	It is written by Marc Lehmann in C, so must be compiled and
1561	installed in the used environment.
1562
1563	JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
1564
1565
1566	=head2 FEATURES
1567
1568	=over
1569
1570	=item * correct unicode handling
1571
1572	This module knows how to handle Unicode (depending on Perl version).
1573
1574	See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
1575
1576
1577	=item * round-trip integrity
1578
1579	When you serialise a perl data structure using only data types supported
1580	by JSON and Perl, the deserialised data structure is identical on the Perl
1581	level. (e.g. the string "2.0" doesn't suddenly become "2" just because
1582	it looks like a number). There I<are> minor exceptions to this, read the
1583	MAPPING section below to learn about those.
1584
1585
1586	=item * strict checking of JSON correctness
1587
1588	There is no guessing, no generating of illegal JSON texts by default,
1589	and only JSON is accepted as input by default (the latter is a security feature).
1590	But when some options are set, loose chcking features are available.
1591
1592	=back
1593
1594	=head1 FUNCTIONS
1595
1596	Basically, check to L<JSON> or L<JSON::XS>.
1597
1598	=head2 encode_json
1599
1600	$json_text = encode_json $perl_scalar
1601
1602	=head2 decode_json
1603
1604	$perl_scalar = decode_json $json_text
1605
1606	=head2 JSON::PP::true
1607
1608	Returns JSON true value which is blessed object.
1609	It C<isa> JSON::PP::Boolean object.
1610
1611	=head2 JSON::PP::false
1612
1613	Returns JSON false value which is blessed object.
1614	It C<isa> JSON::PP::Boolean object.
1615
1616	=head2 JSON::PP::null
1617
1618	Returns C<undef>.
1619
1620	=head1 METHODS
1621
1622	Basically, check to L<JSON> or L<JSON::XS>.
1623
1624	=head2 new
1625
1626	$json = new JSON::PP
1627
1628	Rturns a new JSON::PP object that can be used to de/encode JSON
1629	strings.
1630
1631	=head2 ascii
1632
1633	$json = $json->ascii([$enable])
1634
1635	$enabled = $json->get_ascii
1636
1637	If $enable is true (or missing), then the encode method will not generate characters outside
1638	the code range 0..127. Any Unicode characters outside that range will be escaped using either
1639	a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
1640	(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
1641
1642	In Perl 5.005, there is no character having high value (more than 255).
1643	See to L<UNICODE HANDLING ON PERLS>.
1644
1645	If $enable is false, then the encode method will not escape Unicode characters unless
1646	required by the JSON syntax or other flags. This results in a faster and more compact format.
1647
1648	JSON::PP->new->ascii(1)->encode([chr 0x10401])
1649	=> ["\ud801\udc01"]
1650
1651	=head2 latin1
1652
1653	$json = $json->latin1([$enable])
1654
1655	$enabled = $json->get_latin1
1656
1657	If $enable is true (or missing), then the encode method will encode the resulting JSON
1658	text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
1659
1660	If $enable is false, then the encode method will not escape Unicode characters
1661	unless required by the JSON syntax or other flags.
1662
1663	JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
1664	=> ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
1665
1666	See to L<UNICODE HANDLING ON PERLS>.
1667
1668	=head2 utf8
1669
1670	$json = $json->utf8([$enable])
1671
1672	$enabled = $json->get_utf8
1673
1674	If $enable is true (or missing), then the encode method will encode the JSON result
1675	into UTF-8, as required by many protocols, while the decode method expects to be handled
1676	an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
1677	characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
1678
1679	(In Perl 5.005, any character outside the range 0..255 does not exist.
1680	See to L<UNICODE HANDLING ON PERLS>.)
1681
1682	In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
1683	encoding families, as described in RFC4627.
1684
1685	If $enable is false, then the encode method will return the JSON string as a (non-encoded)
1686	Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
1687	(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
1688
1689	Example, output UTF-16BE-encoded JSON:
1690
1691	use Encode;
1692	$jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
1693
1694	Example, decode UTF-32LE-encoded JSON:
1695
1696	use Encode;
1697	$object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
1698
1699
1700	=head2 pretty
1701
1702	$json = $json->pretty([$enable])
1703
1704	This enables (or disables) all of the C<indent>, C<space_before> and
1705	C<space_after> flags in one call to generate the most readable
1706	(or most compact) form possible.
1707
1708	=head2 indent
1709
1710	$json = $json->indent([$enable])
1711
1712	$enabled = $json->get_indent
1713
1714	The default indent space length is three.
1715	You can use C<indent_length> to change the length.
1716
1717	=head2 space_before
1718
1719	$json = $json->space_before([$enable])
1720
1721	$enabled = $json->get_space_before
1722
1723	=head2 space_after
1724
1725	$json = $json->space_after([$enable])
1726
1727	$enabled = $json->get_space_after
1728
1729	=head2 relaxed
1730
1731	$json = $json->relaxed([$enable])
1732
1733	$enabled = $json->get_relaxed
1734
1735	=head2 canonical
1736
1737	$json = $json->canonical([$enable])
1738
1739	$enabled = $json->get_canonical
1740
1741	If you want your own sorting routine, you can give a code referece
1742	or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
1743
1744	=head2 allow_nonref
1745
1746	$json = $json->allow_nonref([$enable])
1747
1748	$enabled = $json->get_allow_nonref
1749
1750	=head2 allow_unknown
1751
1752	$json = $json->allow_unknown ([$enable])
1753
1754	$enabled = $json->get_allow_unknown
1755
1756	=head2 allow_blessed
1757
1758	$json = $json->allow_blessed([$enable])
1759
1760	$enabled = $json->get_allow_blessed
1761
1762	=head2 convert_blessed
1763
1764	$json = $json->convert_blessed([$enable])
1765
1766	$enabled = $json->get_convert_blessed
1767
1768	=head2 filter_json_object
1769
1770	$json = $json->filter_json_object([$coderef])
1771
1772	=head2 filter_json_single_key_object
1773
1774	$json = $json->filter_json_single_key_object($key [=> $coderef])
1775
1776	=head2 shrink
1777
1778	$json = $json->shrink([$enable])
1779
1780	$enabled = $json->get_shrink
1781
1782	In JSON::XS, this flag resizes strings generated by either
1783	C<encode> or C<decode> to their minimum size possible.
1784	It will also try to downgrade any strings to octet-form if possible.
1785
1786	In JSON::PP, it is noop about resizing strings but tries
1787	C<utf8::downgrade> to the returned string by C<encode>.
1788	See to L<utf8>.
1789
1790	See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
1791
1792	=head2 max_depth
1793
1794	$json = $json->max_depth([$maximum_nesting_depth])
1795
1796	$max_depth = $json->get_max_depth
1797
1798	Sets the maximum nesting level (default C<512>) accepted while encoding
1799	or decoding. If a higher nesting level is detected in JSON text or a Perl
1800	data structure, then the encoder and decoder will stop and croak at that
1801	point.
1802
1803	Nesting level is defined by number of hash- or arrayrefs that the encoder
1804	needs to traverse to reach a given point or the number of C<{> or C<[>
1805	characters without their matching closing parenthesis crossed to reach a
1806	given character in a string.
1807
1808	If no argument is given, the highest possible setting will be used, which
1809	is rarely useful.
1810
1811	See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1812
1813	When a large value (100 or more) was set and it de/encodes a deep nested object/text,
1814	it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
1815
1816	=head2 max_size
1817
1818	$json = $json->max_size([$maximum_string_size])
1819
1820	$max_size = $json->get_max_size
1821
1822	Set the maximum length a JSON text may have (in bytes) where decoding is
1823	being attempted. The default is C<0>, meaning no limit. When C<decode>
1824	is called on a string that is longer then this many bytes, it will not
1825	attempt to decode the string but throw an exception. This setting has no
1826	effect on C<encode> (yet).
1827
1828	If no argument is given, the limit check will be deactivated (same as when
1829	C<0> is specified).
1830
1831	See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
1832
1833	=head2 encode
1834
1835	$json_text = $json->encode($perl_scalar)
1836
1837	=head2 decode
1838
1839	$perl_scalar = $json->decode($json_text)
1840
1841	=head2 decode_prefix
1842
1843	($perl_scalar, $characters) = $json->decode_prefix($json_text)
1844
1845
1846	=head1 INCREMENTAL PARSING
1847
1848	Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
1849
1850	In some cases, there is the need for incremental parsing of JSON texts.
1851	This module does allow you to parse a JSON stream incrementally.
1852	It does so by accumulating text until it has a full JSON object, which
1853	it then can decode. This process is similar to using C<decode_prefix>
1854	to see if a full JSON object is available, but is much more efficient
1855	(and can be implemented with a minimum of method calls).
1856
1857	This module will only attempt to parse the JSON text once it is sure it
1858	has enough text to get a decisive result, using a very simple but
1859	truly incremental parser. This means that it sometimes won't stop as
1860	early as the full parser, for example, it doesn't detect parenthese
1861	mismatches. The only thing it guarantees is that it starts decoding as
1862	soon as a syntactically valid JSON text has been seen. This means you need
1863	to set resource limits (e.g. C<max_size>) to ensure the parser will stop
1864	parsing in the presence if syntax errors.
1865
1866	The following methods implement this incremental parser.
1867
1868	=head2 incr_parse
1869
1870	$json->incr_parse( [$string] ) # void context
1871
1872	$obj_or_undef = $json->incr_parse( [$string] ) # scalar context
1873
1874	@obj_or_empty = $json->incr_parse( [$string] ) # list context
1875
1876	This is the central parsing function. It can both append new text and
1877	extract objects from the stream accumulated so far (both of these
1878	functions are optional).
1879
1880	If C<$string> is given, then this string is appended to the already
1881	existing JSON fragment stored in the C<$json> object.
1882
1883	After that, if the function is called in void context, it will simply
1884	return without doing anything further. This can be used to add more text
1885	in as many chunks as you want.
1886
1887	If the method is called in scalar context, then it will try to extract
1888	exactly I<one> JSON object. If that is successful, it will return this
1889	object, otherwise it will return C<undef>. If there is a parse error,
1890	this method will croak just as C<decode> would do (one can then use
1891	C<incr_skip> to skip the errornous part). This is the most common way of
1892	using the method.
1893
1894	And finally, in list context, it will try to extract as many objects
1895	from the stream as it can find and return them, or the empty list
1896	otherwise. For this to work, there must be no separators between the JSON
1897	objects or arrays, instead they must be concatenated back-to-back. If
1898	an error occurs, an exception will be raised as in the scalar context
1899	case. Note that in this case, any previously-parsed JSON texts will be
1900	lost.
1901
1902	Example: Parse some JSON arrays/objects in a given string and return them.
1903
1904	my @objs = JSON->new->incr_parse ("[5][7][1,2]");
1905
1906	=head2 incr_text
1907
1908	$lvalue_string = $json->incr_text
1909
1910	This method returns the currently stored JSON fragment as an lvalue, that
1911	is, you can manipulate it. This I<only> works when a preceding call to
1912	C<incr_parse> in I<scalar context> successfully returned an object. Under
1913	all other circumstances you must not call this function (I mean it.
1914	although in simple tests it might actually work, it I<will> fail under
1915	real world conditions). As a special exception, you can also call this
1916	method before having parsed anything.
1917
1918	This function is useful in two cases: a) finding the trailing text after a
1919	JSON object or b) parsing multiple JSON objects separated by non-JSON text
1920	(such as commas).
1921
1922	$json->incr_text =~ s/\s,\s//;
1923
1924	In Perl 5.005, C<lvalue> attribute is not available.
1925	You must write codes like the below:
1926
1927	$string = $json->incr_text;
1928	$string =~ s/\s,\s//;
1929	$json->incr_text( $string );
1930
1931	=head2 incr_skip
1932
1933	$json->incr_skip
1934
1935	This will reset the state of the incremental parser and will remove the
1936	parsed text from the input buffer. This is useful after C<incr_parse>
1937	died, in which case the input buffer and incremental parser state is left
1938	unchanged, to skip the text parsed so far and to reset the parse state.
1939
1940	=head2 incr_reset
1941
1942	$json->incr_reset
1943
1944	This completely resets the incremental parser, that is, after this call,
1945	it will be as if the parser had never parsed anything.
1946
1947	This is useful if you want ot repeatedly parse JSON objects and want to
1948	ignore any trailing data, which means you have to reset the parser after
1949	each successful decode.
1950
1951	See to L<JSON::XS/INCREMENTAL PARSING> for examples.
1952
1953
1954	=head1 JSON::PP OWN METHODS
1955
1956	=head2 allow_singlequote
1957
1958	$json = $json->allow_singlequote([$enable])
1959
1960	If C<$enable> is true (or missing), then C<decode> will accept
1961	JSON strings quoted by single quotations that are invalid JSON
1962	format.
1963
1964	$json->allow_singlequote->decode({"foo":'bar'});
1965	$json->allow_singlequote->decode({'foo':"bar"});
1966	$json->allow_singlequote->decode({'foo':'bar'});
1967
1968	As same as the C<relaxed> option, this option may be used to parse
1969	application-specific files written by humans.
1970
1971
1972	=head2 allow_barekey
1973
1974	$json = $json->allow_barekey([$enable])
1975
1976	If C<$enable> is true (or missing), then C<decode> will accept
1977	bare keys of JSON object that are invalid JSON format.
1978
1979	As same as the C<relaxed> option, this option may be used to parse
1980	application-specific files written by humans.
1981
1982	$json->allow_barekey->decode('{foo:"bar"}');
1983
1984	=head2 allow_bignum
1985
1986	$json = $json->allow_bignum([$enable])
1987
1988	If C<$enable> is true (or missing), then C<decode> will convert
1989	the big integer Perl cannot handle as integer into a L<Math::BigInt>
1990	object and convert a floating number (any) into a L<Math::BigFloat>.
1991
1992	On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
1993	objects into JSON numbers with C<allow_blessed> enable.
1994
1995	$json->allow_nonref->allow_blessed->allow_bignum;
1996	$bigfloat = $json->decode('2.000000000000000000000000001');
1997	print $json->encode($bigfloat);
1998	# => 2.000000000000000000000000001
1999
2000	See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
2001
2002	=head2 loose
2003
2004	$json = $json->loose([$enable])
2005
2006	The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
2007	and the module doesn't allow to C<decode> to these (except for \x2f).
2008	If C<$enable> is true (or missing), then C<decode> will accept these
2009	unescaped strings.
2010
2011	$json->loose->decode(qq\|["abc
2012	def"]\|);
2013
2014	See L<JSON::XS/SSECURITY CONSIDERATIONS>.
2015
2016	=head2 escape_slash
2017
2018	$json = $json->escape_slash([$enable])
2019
2020	According to JSON Grammar, I<slash> (U+002F) is escaped. But default
2021	JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
2022
2023	If C<$enable> is true (or missing), then C<encode> will escape slashes.
2024
2025	=head2 (OBSOLETED)as_nonblessed
2026
2027	$json = $json->as_nonblessed
2028
2029	(OBSOLETED) If C<$enable> is true (or missing), then C<encode> will convert
2030	a blessed hash reference or a blessed array reference (contains
2031	other blessed references) into JSON members and arrays.
2032
2033	This feature is effective only when C<allow_blessed> is enable.
2034
2035	=head2 indent_length
2036
2037	$json = $json->indent_length($length)
2038
2039	JSON::XS indent space length is 3 and cannot be changed.
2040	JSON::PP set the indent space length with the given $length.
2041	The default is 3. The acceptable range is 0 to 15.
2042
2043	=head2 sort_by
2044
2045	$json = $json->sort_by($function_name)
2046	$json = $json->sort_by($subroutine_ref)
2047
2048	If $function_name or $subroutine_ref are set, its sort routine are used
2049	in encoding JSON objects.
2050
2051	$js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
2052	# is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|);
2053
2054	$js = $pc->sort_by('own_sort')->encode($obj);
2055	# is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|);
2056
2057	sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
2058
2059	As the sorting routine runs in the JSON::PP scope, the given
2060	subroutine name and the special variables C<$a>, C<$b> will begin
2061	'JSON::PP::'.
2062
2063	If $integer is set, then the effect is same as C<canonical> on.
2064
2065	=head1 INTERNAL
2066
2067	For developers.
2068
2069	=over
2070
2071	=item PP_encode_box
2072
2073	Returns
2074
2075	{
2076	depth => $depth,
2077	indent_count => $indent_count,
2078	}
2079
2080
2081	=item PP_decode_box
2082
2083	Returns
2084
2085	{
2086	text => $text,
2087	at => $at,
2088	ch => $ch,
2089	len => $len,
2090	depth => $depth,
2091	encoding => $encoding,
2092	is_valid_utf8 => $is_valid_utf8,
2093	};
2094
2095	=back
2096
2097	=head1 MAPPING
2098
2099	See to L<JSON::XS/MAPPING>.
2100
2101
2102	=head1 UNICODE HANDLING ON PERLS
2103
2104	If you do not know about Unicode on Perl well,
2105	please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
2106
2107	=head2 Perl 5.8 and later
2108
2109	Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
2110
2111	$json->allow_nonref->encode(chr hex 3042);
2112	$json->allow_nonref->encode(chr hex 12345);
2113
2114	Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
2115
2116	$json->allow_nonref->decode('"\u3042"');
2117	$json->allow_nonref->decode('"\ud808\udf45"');
2118
2119	Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
2120
2121	Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
2122	so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
2123
2124
2125	=head2 Perl 5.6
2126
2127	Perl can handle Unicode and the JSON::PP de/encode methods also work.
2128
2129	=head2 Perl 5.005
2130
2131	Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
2132	That means the unicode handling is not available.
2133
2134	In encoding,
2135
2136	$json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
2137	$json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
2138
2139	Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
2140	as C<$value % 256>, so the above codes are equivalent to :
2141
2142	$json->allow_nonref->encode(chr 66);
2143	$json->allow_nonref->encode(chr 69);
2144
2145	In decoding,
2146
2147	$json->decode('"\u00e3\u0081\u0082"');
2148
2149	The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
2150	japanese character (C<HIRAGANA LETTER A>).
2151	And if it is represented in Unicode code point, C<U+3042>.
2152
2153	Next,
2154
2155	$json->decode('"\u3042"');
2156
2157	We ordinary expect the returned value is a Unicode character C<U+3042>.
2158	But here is 5.005 world. This is C<0xE3 0x81 0x82>.
2159
2160	$json->decode('"\ud808\udf45"');
2161
2162	This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
2163
2164
2165	=head1 TODO
2166
2167	=over
2168
2169	=item speed
2170
2171	=item memory saving
2172
2173	=back
2174
2175
2176	=head1 SEE ALSO
2177
2178	Most of the document are copied and modified from JSON::XS doc.
2179
2180	L<JSON::XS>
2181
2182	RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
2183
2184	=head1 AUTHOR
2185
2186	Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
2187
2188
2189	=head1 COPYRIGHT AND LICENSE
2190
2191	Copyright 2007-2010 by Makamaka Hannyaharamitu
2192
2193	This library is free software; you can redistribute it and/or modify
2194	it under the same terms as Perl itself.
2195
2196	=cut

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: main/trunk/greenstone2/perllib/cpan/JSON/PP.pm@ 31781

Download in other formats: