File Coverage

blib/lib/JSON/WithComments.pm

Criterion	Covered	Total	%
statement	39	49	79.5
branch	7	14	50.0
condition	0	2	0.0
subroutine	11	11	100.0
pod	0	4	0.0
total	57	80	71.2

###############################################################################
#
# 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.003'; # 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 new {
    my $class = shift;

    return $class->SUPER::new->comment_style($default_comment_style);
}

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

    if (defined $value) {
        if ($value eq 'perl') {
            $self->relaxed(1);
        } elsif ($PATTERNS{$value}) {
            $self->relaxed(0);
        } else {
            Carp::croak "Unknown comment_style ($value)";
        }
        $comment_style{"$self"} = $value;
    }

    return $self;
}

sub get_comment_style {
    my $self = shift;

    return $comment_style{"$self"};
}

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

    # Perl-style comments are handled by having set the "relaxed" property on
    # the object. We only use the regexp approach for the other style(s).
    if ((my $style = $self->get_comment_style) ne 'perl') {
        my $comment_re = $PATTERNS{$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__