CPAN::Groonga

package MojoX::AlmostJSON;
$MojoX::AlmostJSON::VERSION = '1.151250';
# ABSTRACT: Almost JSON but allow javascript function
# Code stolen from Mojo::JSON
use Mojo::Base -strict;
 
use B;
use Carp 'croak';
use Exporter 'import';
use Mojo::Util;
use Scalar::Util 'blessed';
 
our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
 
# Booleans
my ($FALSE, $TRUE) = map { bless \(my $dummy = $_), 'MojoX::AlmostJSON::_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) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
 
sub decode_json {
  my $err = _decode(\my $value, shift);
  return defined $err ? croak $err : $value;
}
 
sub encode_json { Mojo::Util::encode 'UTF-8', _encode_value(shift) }
 
sub false () {$FALSE}
 
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 eval { decode_json($_[0]) };
}
 
sub to_json { _encode_value(shift) }
 
sub true () {$TRUE}
 
sub _decode {
  my $valueref = shift;
 
  eval {
 
    # Missing input
    die "Missing or empty input\n" unless length(local $_ = shift);
 
    # UTF-8
    $_ = Mojo::Util::decode 'UTF-8', $_ unless shift;
    die "Input is not UTF-8 encoded\n" unless defined;
 
    # Value
    $$valueref = _decode_value();
 
    # Leftover data
    /\G[\x20\x09\x0a\x0d]*\z/gc or _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 /\G[\x20\x09\x0a\x0d]*,/gc;
 
    # End
    last if /\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
    /\G[\x20\x09\x0a\x0d]*"/gc
      or _throw('Expected string while parsing object');
 
    # Key
    my $key = _decode_string();
 
    # Colon
    /\G[\x20\x09\x0a\x0d]*:/gc
      or _throw('Expected colon while parsing object');
 
    # Value
    $hash{$key} = _decode_value();
 
    # Separator
    redo if /\G[\x20\x09\x0a\x0d]*,/gc;
 
    # End
    last if /\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;
  my $str = $1;
 
  # Invalid character
  unless (m/\G"/gc) {
    _throw('Unexpected character or invalid escape while parsing string')
      if /\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 =~ /\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 =~ /\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
  /\G[\x20\x09\x0a\x0d]*/gc;
 
  # String
  return _decode_string() if /\G"/gc;
 
  # Object
  return _decode_object() if /\G\{/gc;
 
  # Array
  return _decode_array() if /\G\[/gc;
 
  # Number
  return 0 + $1
    if /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
 
  # True
  return $TRUE if /\Gtrue/gc;
 
  # False
  return $FALSE if /\Gfalse/gc;
 
  # Null
  return undef if /\Gnull/gc;
 
  # 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->{$_}) }
    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';

	#Function
	return $$value if $ref eq 'SCALAR' and $$value !~/^[01]$/;

    # True or false
    return $value  ? 'true' : 'false' if $ref =~ /^(?:MojoX::Almost|Mojo::)JSON::_Bool$/;
    return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
	 
    # 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
  return $value
    if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
    && 0 + $value eq $value
    && $value * 0 == 0;
 
  # String
  return _encode_string($value);
}
 
sub _throw {
 
  # Leading whitespace
  /\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 MojoX::AlmostJSON::_Bool;
$MojoX::AlmostJSON::_Bool::VERSION = '1.151250';
use overload '""' => sub { ${$_[0]} }, fallback => 1;
 
1;

__END__

=pod

=encoding UTF-8

=head1 NAME

MojoX::AlmostJSON - Almost JSON but allow javascript function

=head1 VERSION

version 1.151250

=head1 AUTHOR

Nicolas Georges <xlat@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2015 by Nicolas Georges.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut