File Coverage

blib/lib/JSON/WithComments.pm

Criterion	Covered	Total	%
statement	34	44	77.2
branch	3	10	30.0
condition	2	5	40.0
subroutine	10	10	100.0
pod	0	3	0.0
total	49	72	68.0

###############################################################################
#
# This file copyright © 2017 by Randy J. Ray, all rights reserved
#
# See "LICENSE AND COPYRIGHT" in the POD for terms.
#
###############################################################################
#
#   Description:    Simple support for comments in JSON content.
#
#   Functions:      import
#                   comment_style
#                   get_comment_style
#                   decode
#
#   Libraries:      JSON
#
#   Global Consts:  %PATTERNS
#
#   Environment:    None
#
###############################################################################

package JSON::WithComments;

use 5.008;
use strict;
use warnings;
use base qw(JSON);

use Carp ();

our $VERSION = '0.002'; # VERSION

# These regular expressions are adapted from Regexp::Common::comment.

# The length of the regexp for JS multi-line comments triggers this:
## no critic(RegularExpressions::RequireExtendedFormatting)
my $JS_SINGLE = qr{(?://)(?:[^\n]*)};
my $JS_MULTI  = qr{(?:\/[*])(?:(?:[^*]+|[*](?!\/))*)(?:[*]\/)};
my $PERL      = qr{(?:#)(?:[^\n]*)};
my %PATTERNS  = (
    perl       => qr{(?
    javascript => qr{(?
);

# This is the comment-style that will be used if/when an object has not
# specified a style. It can be changed in import() with -default_comment_style.
# This is also the style that will be used by decode_json.
my $default_comment_style = 'javascript';

# This table is used in lieu of per-object hashkeys, as the object is not a
# hashref when the JSON::XS backend is in use.
my %comment_style;

sub import {
    my ($class, @imports) = @_;

    my ($index, $style);
    for my $idx (0 .. $#imports) {
        if ($imports[$idx] eq '-default_comment_style') {
            $index = $idx;
            $style = $imports[$idx + 1];
            last;
        }
    }
    if (defined $index) {
        $style ||= '(undef)';
        if (! $PATTERNS{$style}) {
            Carp::croak "Unknown comment style '$style' given as default";
        }
        $default_comment_style = $style;
        splice @imports, $index, 2;
    }

    return $class->SUPER::import(@imports);
}

sub comment_style {
    my ($self, $value) = @_;

    if (defined $value) {
        if (! $PATTERNS{$value}) {
            Carp::croak "Unknown comment_style ($value)";
        }
        $comment_style{"$self"} = $value;
    }

    return $self;
}

sub get_comment_style {
    my $self = shift;

    return $comment_style{"$self"} || $default_comment_style;
}

sub decode {
    my ($self, $text) = @_;

    my $comment_re = $PATTERNS{$self->get_comment_style};
    # The JSON module reports errors using the character-offset within the
    # string as a whole. So rather than deleting comments, replace them with a
    # string of spaces of the same length. This should mean that any reported
    # character offsets in the JSON data will still be correct.
    $text =~ s/$comment_re/q{ } x length($1)/ge;

    return $self->SUPER::decode($text);
}

sub DESTROY {
    my $self = shift;

    delete $comment_style{"$self"};

    return;
}

1;

__END__