1package JSON::Tiny; 2 3# Minimalistic JSON. Adapted from Mojo::JSON. (c)2012-2015 David Oswald 4# License: Artistic 2.0 license. 5# http://www.perlfoundation.org/artistic_license_2_0 6 7use strict; 8use warnings; 9use Carp 'croak'; 10use Exporter 'import'; 11use Scalar::Util 'blessed'; 12use Encode (); 13use B; 14 15our $VERSION = '0.58'; 16our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true); 17 18# Literal names 19# Users may override Booleans with literal 0 or 1 if desired. 20our($FALSE, $TRUE) = map { bless \(my $dummy = $_), 'JSON::Tiny::_Bool' } 0, 1; 21 22# Escaped special character map with u2028 and u2029 23my %ESCAPE = ( 24 '"' => '"', 25 '\\' => '\\', 26 '/' => '/', 27 'b' => "\x08", 28 'f' => "\x0c", 29 'n' => "\x0a", 30 'r' => "\x0d", 31 't' => "\x09", 32 'u2028' => "\x{2028}", 33 'u2029' => "\x{2029}" 34); 35my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE; 36 37for(0x00 .. 0x1f) { 38 my $packed = pack 'C', $_; 39 $REVERSE{$packed} = sprintf '\u%.4X', $_ unless defined $REVERSE{$packed}; 40} 41 42sub decode_json { 43 my $err = _decode(\my $value, shift); 44 return defined $err ? croak $err : $value; 45} 46 47sub encode_json { Encode::encode 'UTF-8', _encode_value(shift) } 48 49sub false () {$FALSE} ## no critic (prototypes) 50 51sub from_json { 52 my $err = _decode(\my $value, shift, 1); 53 return defined $err ? croak $err : $value; 54} 55 56sub j { 57 return encode_json $_[0] if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH'; 58 return decode_json $_[0]; 59} 60 61sub to_json { _encode_value(shift) } 62 63sub true () {$TRUE} ## no critic (prototypes) 64 65sub _decode { 66 my $valueref = shift; 67 68 eval { 69 70 # Missing input 71 die "Missing or empty input\n" unless length( local $_ = shift ); 72 73 # UTF-8 74 $_ = eval { Encode::decode('UTF-8', $_, 1) } unless shift; 75 die "Input is not UTF-8 encoded\n" unless defined $_; 76 77 # Value 78 $$valueref = _decode_value(); 79 80 # Leftover data 81 return m/\G[\x20\x09\x0a\x0d]*\z/gc || _throw('Unexpected data'); 82 } ? return undef : chomp $@; 83 84 return $@; 85} 86 87sub _decode_array { 88 my @array; 89 until (m/\G[\x20\x09\x0a\x0d]*\]/gc) { 90 91 # Value 92 push @array, _decode_value(); 93 94 # Separator 95 redo if m/\G[\x20\x09\x0a\x0d]*,/gc; 96 97 # End 98 last if m/\G[\x20\x09\x0a\x0d]*\]/gc; 99 100 # Invalid character 101 _throw('Expected comma or right square bracket while parsing array'); 102 } 103 104 return \@array; 105} 106 107sub _decode_object { 108 my %hash; 109 until (m/\G[\x20\x09\x0a\x0d]*\}/gc) { 110 111 # Quote 112 m/\G[\x20\x09\x0a\x0d]*"/gc 113 or _throw('Expected string while parsing object'); 114 115 # Key 116 my $key = _decode_string(); 117 118 # Colon 119 m/\G[\x20\x09\x0a\x0d]*:/gc 120 or _throw('Expected colon while parsing object'); 121 122 # Value 123 $hash{$key} = _decode_value(); 124 125 # Separator 126 redo if m/\G[\x20\x09\x0a\x0d]*,/gc; 127 128 # End 129 last if m/\G[\x20\x09\x0a\x0d]*\}/gc; 130 131 # Invalid character 132 _throw('Expected comma or right curly bracket while parsing object'); 133 } 134 135 return \%hash; 136} 137 138sub _decode_string { 139 my $pos = pos; 140 141 # Extract string with escaped characters 142 m!\G((?:(?:[^\x00-\x1f\\"]|\\(?:["\\/bfnrt]|u[0-9a-fA-F]{4})){0,32766})*)!gc; # segfault on 5.8.x in t/20-mojo-json.t 143 my $str = $1; 144 145 # Invalid character 146 unless (m/\G"/gc) { 147 _throw('Unexpected character or invalid escape while parsing string') 148 if m/\G[\x00-\x1f\\]/; 149 _throw('Unterminated string'); 150 } 151 152 # Unescape popular characters 153 if (index($str, '\\u') < 0) { 154 $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs; 155 return $str; 156 } 157 158 # Unescape everything else 159 my $buffer = ''; 160 while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) { 161 $buffer .= $1; 162 163 # Popular character 164 if ($2) { $buffer .= $ESCAPE{$2} } 165 166 # Escaped 167 else { 168 my $ord = hex $3; 169 170 # Surrogate pair 171 if (($ord & 0xf800) == 0xd800) { 172 173 # High surrogate 174 ($ord & 0xfc00) == 0xd800 175 or pos($_) = $pos + pos($str), _throw('Missing high-surrogate'); 176 177 # Low surrogate 178 $str =~ m/\G\\u([Dd][C-Fc-f]..)/gc 179 or pos($_) = $pos + pos($str), _throw('Missing low-surrogate'); 180 181 $ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00); 182 } 183 184 # Character 185 $buffer .= pack 'U', $ord; 186 } 187 } 188 189 # The rest 190 return $buffer . substr $str, pos $str, length $str; 191} 192 193sub _decode_value { 194 195 # Leading whitespace 196 m/\G[\x20\x09\x0a\x0d]*/gc; 197 198 # String 199 return _decode_string() if m/\G"/gc; 200 201 # Object 202 return _decode_object() if m/\G\{/gc; 203 204 # Array 205 return _decode_array() if m/\G\[/gc; 206 207 # Number 208 my ($i) = /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc; 209 return 0 + $i if defined $i; 210 211 # True 212 return $TRUE if m/\Gtrue/gc; 213 214 # False 215 return $FALSE if m/\Gfalse/gc; 216 217 # Null 218 return undef if m/\Gnull/gc; ## no critic (return) 219 220 # Invalid character 221 _throw('Expected string, array, object, number, boolean or null'); 222} 223 224sub _encode_array { 225 '[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']'; 226} 227 228sub _encode_object { 229 my $object = shift; 230 my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) } 231 sort keys %$object; 232 return '{' . join(',', @pairs) . '}'; 233} 234 235sub _encode_string { 236 my $str = shift; 237 $str =~ s!([\x00-\x1f\x{2028}\x{2029}\\"/])!$REVERSE{$1}!gs; 238 return "\"$str\""; 239} 240 241sub _encode_value { 242 my $value = shift; 243 244 # Reference 245 if (my $ref = ref $value) { 246 247 # Object 248 return _encode_object($value) if $ref eq 'HASH'; 249 250 # Array 251 return _encode_array($value) if $ref eq 'ARRAY'; 252 253 # True or false 254 return $$value ? 'true' : 'false' if $ref eq 'SCALAR'; 255 return $value ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool'; 256 257 # Blessed reference with TO_JSON method 258 if (blessed $value && (my $sub = $value->can('TO_JSON'))) { 259 return _encode_value($value->$sub); 260 } 261 } 262 263 # Null 264 return 'null' unless defined $value; 265 266 267 # Number (bitwise operators change behavior based on the internal value type) 268 269 return $value 270 if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK) 271 # filter out "upgraded" strings whose numeric form doesn't strictly match 272 && 0 + $value eq $value 273 # filter out inf and nan 274 && $value * 0 == 0; 275 276 # String 277 return _encode_string($value); 278} 279 280sub _throw { 281 282 # Leading whitespace 283 m/\G[\x20\x09\x0a\x0d]*/gc; 284 285 # Context 286 my $context = 'Malformed JSON: ' . shift; 287 if (m/\G\z/gc) { $context .= ' before end of data' } 288 else { 289 my @lines = split "\n", substr($_, 0, pos); 290 $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || ''); 291 } 292 293 die "$context\n"; 294} 295 296# Emulate boolean type 297package JSON::Tiny::_Bool; 298use overload '""' => sub { ${$_[0]} }, fallback => 1; 2991; 300