File Coverage

blib/lib/JSON/Decode/Regexp.pm

Criterion	Covered	Total	%
statement	19	20	95.0
branch	8	10	80.0
condition			n/a
subroutine	6	6	100.0
pod	1	1	100.0
total	34	37	91.8

package JSON::Decode::Regexp;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-08-01'; # DATE
our $DIST = 'JSON-Decode-Regexp'; # DIST
our $VERSION = '0.102'; # VERSION

use 5.014004;
use strict;
use warnings;

#use Data::Dumper;

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(from_json);

sub _fail { die __PACKAGE__.": $_[0] at offset ".pos()."\n" }

my %escape_codes = (
    "\\" => "\\",
    "\"" => "\"",
    "b" => "\b",
    "f" => "\f",
    "n" => "\n",
    "r" => "\r",
    "t" => "\t",
);

sub _decode_str {
    my $str = shift;
    $str =~ s[(\\(?:([0-7]{1,3})|x([0-9A-Fa-f]{1,2})|(.)))]
             [defined($2) ? chr(oct $2) :
                  defined($3) ? chr(hex $3) :
                      $escape_codes{$4} ? $escape_codes{$4} :
                          $1]eg;
    $str;
}

our $FROM_JSON = qr{

(?:
    (?&VALUE) (?{ $_ = $^R->[1] })
|
    \z (?{ _fail "Unexpected end of input" })
|
      (?{ _fail "Invalid literal" })
)

(?(DEFINE)

(?
  \{\s*
    (?{ [$^R, {}] })
    (?:
        (?&KV) # [[$^R, {}], $k, $v]
        (?{ [$^R->[0][0], {$^R->[1] => $^R->[2]}] })
        \s*
        (?:
            (?:
                ,\s* (?&KV) # [[$^R, {...}], $k, $v]
                (?{ $^R->[0][1]{ $^R->[1] } = $^R->[2]; $^R->[0] })
            )*
        |
            (?:[^,\}]|\z) (?{ _fail "Expected ',' or '\x7d'" })
        )*
    )?
    \s*
    (?:
        \}
    |
        (?:.|\z) (?{ _fail "Expected closing of hash" })
    )
)

(?
  (?&STRING) # [$^R, "string"]
  \s*
  (?:
      :\s* (?&VALUE) # [[$^R, "string"], $value]
      (?{ [$^R->[0][0], $^R->[0][1], $^R->[1]] })
  |
      (?:[^:]|\z) (?{ _fail "Expected ':'" })
  )
)

(?
  \[\s*
  (?{ [$^R, []] })
  (?:
      (?&VALUE) # [[$^R, []], $val]
      (?{ [$^R->[0][0], [$^R->[1]]] })
      \s*
      (?:
          (?:
              ,\s* (?&VALUE)
              (?{ push @{$^R->[0][1]}, $^R->[1]; $^R->[0] })
          )*
      |
          (?: [^,\]]|\z ) (?{ _fail "Expected ',' or '\x5d'" })
      )
  )?
  \s*
  (?:
      \]
  |
      (?:.|\z) (?{ _fail "Expected closing of array" })
  )
)

(?
  \s*
  (
      (?&STRING)
  |
      (?&NUMBER)
  |
      (?&OBJECT)
  |
      (?&ARRAY)
  |
      true (?{ [$^R, 1] })
  |
      false (?{ [$^R, 0] })
  |
      null (?{ [$^R, undef] })
  )
  \s*
)

(?
    "
    (
        (?:
            [^\\"]+
        |
            \\ [0-7]{1,3}
        |
            \\ x [0-9A-Fa-f]{1,2}
        |
            \\ ["\\/bfnrt]
        #|
        #    \\ u [0-9a-fA-f]{4}
        |
            \\ (.) (?{ _fail "Invalid string escape character $^N" })
        )*
    )
    (?:
        "
    |
        (?:\\|\z) (?{ _fail "Expected closing of string" })
    )

  (?{ [$^R, _decode_str($^N)] })
)

(?
  (
    -?
    (?: 0 | [1-9][0-9]* )
    (?: \. [0-9]+ )?
    (?: [eE] [-+]? [0-9]+ )?
  )

  (?{ [$^R, 0+$^N] })
)

) }xms;

sub from_json {
    state $re = qr{\A$FROM_JSON\z};

    local $_ = shift;
    local $^R;
    eval { $_ =~ $re } and return $_;
    die $@ if $@;
    die 'no match';
}

1;
# ABSTRACT: JSON parser as a single Perl Regex

__END__