GPL v3 Release

csf/JSON/Tiny.pm

@@ -0,0 +1,306 @@
+package JSON::Tiny;
+
+# Minimalistic JSON. Adapted from Mojo::JSON. (c)2012-2023 David Oswald
+# License: Artistic 2.0 license.
+# http://www.perlfoundation.org/artistic_license_2_0
+
+use strict;
+use warnings;
+use Carp 'croak';
+use Exporter 'import';
+use Scalar::Util 'blessed';
+use Encode ();
+
+our $VERSION = '0.56';
+our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
+
+# Literal names
+# Users may override Booleans with literal 0 or 1 if desired.
+our($FALSE, $TRUE) = map { bless \(my $dummy = $_), 'JSON::Tiny::_Bool' } 0, 1;
+
+# Escaped special character map with u2028 and u2029
+my %ESCAPE = (
+  '"'     => '"',
+  '\\'    => '\\',
+  '/'     => '/',
+  'b'     => "\x08",
+  'f'     => "\x0c",
+  'n'     => "\x0a",
+  'r'     => "\x0d",
+  't'     => "\x09",
+  'u2028' => "\x{2028}",
+  'u2029' => "\x{2029}"
+);
+my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
+
+for(0x00 .. 0x1f) {
+  my $packed = pack 'C', $_;
+  $REVERSE{$packed} = sprintf '\u%.4X', $_ unless defined $REVERSE{$packed};
+}
+
+sub decode_json {
+  my $err = _decode(\my $value, shift);
+  return defined $err ? croak $err : $value;
+}
+
+sub encode_json { Encode::encode 'UTF-8', _encode_value(shift) }
+
+sub false () {$FALSE}  ## no critic (prototypes)
+
+sub from_json {
+  my $err = _decode(\my $value, shift, 1);
+  return defined $err ? croak $err : $value;
+}
+
+sub j {
+  return encode_json $_[0] if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
+  return decode_json $_[0];
+}
+
+sub to_json { _encode_value(shift) }
+
+sub true () {$TRUE} ## no critic (prototypes)
+
+sub _decode {
+  my $valueref = shift;
+
+  eval {
+
+    # Missing input
+    die "Missing or empty input\n" unless length( local $_ = shift );
+
+    # UTF-8
+    $_ = eval { Encode::decode('UTF-8', $_, 1) } unless shift;
+    die "Input is not UTF-8 encoded\n" unless defined $_;
+
+    # Value
+    $$valueref = _decode_value();
+
+    # Leftover data
+    return m/\G[\x20\x09\x0a\x0d]*\z/gc || _throw('Unexpected data');
+  } ? return undef : chomp $@;
+
+  return $@;
+}
+
+sub _decode_array {
+  my @array;
+  until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
+
+    # Value
+    push @array, _decode_value();
+
+    # Separator
+    redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
+
+    # End
+    last if m/\G[\x20\x09\x0a\x0d]*\]/gc;
+
+    # Invalid character
+    _throw('Expected comma or right square bracket while parsing array');
+  }
+
+  return \@array;
+}
+
+sub _decode_object {
+  my %hash;
+  until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
+
+    # Quote
+    m/\G[\x20\x09\x0a\x0d]*"/gc
+      or _throw('Expected string while parsing object');
+
+    # Key
+    my $key = _decode_string();
+
+    # Colon
+    m/\G[\x20\x09\x0a\x0d]*:/gc
+      or _throw('Expected colon while parsing object');
+
+    # Value
+    $hash{$key} = _decode_value();
+
+    # Separator
+    redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
+
+    # End
+    last if m/\G[\x20\x09\x0a\x0d]*\}/gc;
+
+    # Invalid character
+    _throw('Expected comma or right curly bracket while parsing object');
+  }
+
+  return \%hash;
+}
+
+sub _decode_string {
+  my $pos = pos;
+  
+  # Extract string with escaped characters
+  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
+  my $str = $1;
+
+  # Invalid character
+  unless (m/\G"/gc) {
+    _throw('Unexpected character or invalid escape while parsing string')
+      if m/\G[\x00-\x1f\\]/;
+    _throw('Unterminated string');
+  }
+
+  # Unescape popular characters
+  if (index($str, '\\u') < 0) {
+    $str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
+    return $str;
+  }
+
+  # Unescape everything else
+  my $buffer = '';
+  while ($str =~ m/\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
+    $buffer .= $1;
+
+    # Popular character
+    if ($2) { $buffer .= $ESCAPE{$2} }
+
+    # Escaped
+    else {
+      my $ord = hex $3;
+
+      # Surrogate pair
+      if (($ord & 0xf800) == 0xd800) {
+
+        # High surrogate
+        ($ord & 0xfc00) == 0xd800
+          or pos($_) = $pos + pos($str), _throw('Missing high-surrogate');
+
+        # Low surrogate
+        $str =~ m/\G\\u([Dd][C-Fc-f]..)/gc
+          or pos($_) = $pos + pos($str), _throw('Missing low-surrogate');
+
+        $ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
+      }
+
+      # Character
+      $buffer .= pack 'U', $ord;
+    }
+  }
+
+  # The rest
+  return $buffer . substr $str, pos $str, length $str;
+}
+
+sub _decode_value {
+
+  # Leading whitespace
+  m/\G[\x20\x09\x0a\x0d]*/gc;
+
+  # String
+  return _decode_string() if m/\G"/gc;
+
+  # Object
+  return _decode_object() if m/\G\{/gc;
+
+  # Array
+  return _decode_array() if m/\G\[/gc;
+
+  # Number
+  my ($i) = /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
+  return 0 + $i if defined $i;
+
+  # True
+  return $TRUE if m/\Gtrue/gc;
+
+  # False
+  return $FALSE if m/\Gfalse/gc;
+
+  # Null
+  return undef if m/\Gnull/gc;  ## no critic (return)
+
+  # Invalid character
+  _throw('Expected string, array, object, number, boolean or null');
+}
+
+sub _encode_array {
+  '[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']';
+}
+
+sub _encode_object {
+  my $object = shift;
+  my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) }
+    sort keys %$object;
+  return '{' . join(',', @pairs) . '}';
+}
+
+sub _encode_string {
+  my $str = shift;
+  $str =~ s!([\x00-\x1f\x{2028}\x{2029}\\"/])!$REVERSE{$1}!gs;
+  return "\"$str\"";
+}
+
+sub _encode_value {
+  my $value = shift;
+
+  # Reference
+  if (my $ref = ref $value) {
+
+    # Object
+    return _encode_object($value) if $ref eq 'HASH';
+
+    # Array
+    return _encode_array($value) if $ref eq 'ARRAY';
+
+    # True or false
+    return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
+    return $value  ? 'true' : 'false' if $ref eq 'JSON::Tiny::_Bool';
+
+    # Blessed reference with TO_JSON method
+    if (blessed $value && (my $sub = $value->can('TO_JSON'))) {
+      return _encode_value($value->$sub);
+    }
+  }
+
+  # Null
+  return 'null' unless defined $value;
+
+
+  # Number (bitwise operators change behavior based on the internal value type)
+
+  # "0" & $x will modify the flags on the "0" on perl < 5.14, so use a copy
+  my $zero = "0";
+  # "0" & $num -> 0. "0" & "" -> "". "0" & $string -> a character.
+  # this maintains the internal type but speeds up the xor below.
+  my $check = $zero & $value;
+  return $value
+    if length $check
+    # 0 ^ itself          -> 0    (false)
+    # $character ^ itself -> "\0" (true)
+    && !($check ^ $check)
+    # filter out "upgraded" strings whose numeric form doesn't strictly match
+    && 0 + $value eq $value
+    # filter out inf and nan
+    && $value * 0 == 0;
+
+  # String
+  return _encode_string($value);
+}
+
+sub _throw {
+
+  # Leading whitespace
+  m/\G[\x20\x09\x0a\x0d]*/gc;
+
+  # Context
+  my $context = 'Malformed JSON: ' . shift;
+  if (m/\G\z/gc) { $context .= ' before end of data' }
+  else {
+    my @lines = split "\n", substr($_, 0, pos);
+    $context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
+  }
+
+  die "$context\n";
+}
+
+# Emulate boolean type
+package JSON::Tiny::_Bool;
+use overload '""' => sub { ${$_[0]} }, fallback => 1;
+1;