File Coverage

blib/lib/Config/JSON/Enhanced.pm

Criterion	Covered	Total	%
statement	121	135	89.6
branch	44	56	78.5
condition	29	50	58.0
subroutine	10	10	100.0
pod	1	1	100.0
total	205	252	81.3

package Config::JSON::Enhanced;

use 5.010;
use strict;
use warnings;

our $VERSION = '0.09';

use strict;
use warnings;

# which loads JSON::XS with a purel-perl JSON fallback
use JSON;

use Data::Roundtrip qw/json2perl perl2dump no-unicode-escape-permanently/;

use Exporter; # we have our own import() don't import it
our @ISA = qw(Exporter);
our @EXPORT = qw/
	config2perl
/;

# Convert enhanced JSON string into a Perl data structure.
# The input parameters hashref:
#  * specify where is the content to be parsed via:
#    'filename',
#    'filehandle', or,
#    'string'
#  * optional 'commentstyle' is a string of comma separated
#    commentstyles (valid styles are C, CPP, shell)
#  * optional 'variable-substitutions' is a hashref with
#    keys as template variable names to be substutited
#    inside the content with their corresponding values.
#    For example {'xx' => 'hello'} will substitute
#      <% xx %> with hello
#  * optional 'remove-comments-in-strings' to remove comments from JSON strings
#    (both keys and values), default is to KEEP anything inside a string
#    even if it looks like comments we are supposed to remove (because string
#    can be a bash script, for example).
#  * optional 'debug' for setting verbosity, default is zero.
#
# It returns the created Perl data structure or undef on failure.
sub	config2perl {
	my $params = shift // {};

	my $contents;
	if( exists($params->{'filename'}) && defined(my $infile=$params->{'filename'}) ){
		my $fh;
		if( ! open $fh, '<:encoding(UTF-8)', $infile ){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, failed to open file '$infile' for reading, $!"; return undef }
		{ local $/ = undef; $contents = <$fh> }; close $fh;
	} elsif( exists($params->{'filehandle'}) && defined(my $fh=$params->{'filehandle'}) ){
		{ local $/ = undef; $contents = <$fh> }
		# we are not closing the filehandle, it is caller-specified, so caller responsibility
	} elsif( exists($params->{'string'}) && defined($params->{'string'}) ){
		$contents = $params->{'string'};
	}
	if( ! defined $contents ){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, one of 'filename', 'filehandle' or 'string' must be specified in the parameters hash as the source of the configuration contents."; return undef }

	my $debug = exists($params->{'debug'}) && defined($params->{'debug'})
		? $params->{'debug'} : 0
	;

	my $commentstyle = exists($params->{'commentstyle'}) && defined($params->{'commentstyle'})
		? $params->{'commentstyle'} : 'C'
	;

	my ($tvop, $tvcl);
	if( exists($params->{'tags'}) && defined($params->{'tags'}) ){
		if( ref($params->{'tags'}) ne 'ARRAY' ){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, input parameter 'tags' must be an ARRAYref of exactly 2 items and not a ".ref($params->{'tags'})."."; return undef }
		if( scalar(@{ $params->{'tags'} }) != 2 ){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, input parameter 'tags' must be an ARRAYref of exactly 2 items and not ".scalar(@{ $params->{'tags'} })."."; return undef }
		($tvop, $tvcl) = @{ $params->{'tags'} };
	} else { $tvop = '<%'; $tvcl = '%>' }

	# check that the tags for verbatim sections is not the same as comments
	while( $commentstyle =~ /\bcustom\((.+?)\)\((.*?)\)/ig ){
		my $coop = $1; my $cocl = $2;
		if( $debug > 0 ){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : checking comment tags '${coop}' and '${cocl}' not to be the same or contain verbatim/variables tags '${tvop}' and '${tvcl}' ..." }
		if( ($tvop eq $coop) || ($tvop eq $cocl)
		 || ($tvcl eq $coop) || ($tvcl eq $cocl)
		){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, there is a clash (exact match) with verbatim/variable tags ('${tvop}' and '${tvcl}') and comment tags ('${coop}' and '${cocl}')."; return undef }
		# also check if one contains the other
		if( ($tvop =~ /\Q${coop}\E/) || ($tvop =~ /\Q${cocl}\E/)
		 || ($tvcl =~ /\Q${coop}\E/) || ($tvcl =~ /\Q${cocl}\E/)
		){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, there is a clash (one contains the other) with verbatim/variable tags ('${tvop}' and '${tvcl}') and comment tags ('${coop}' and '${cocl}')."; return undef }
		if( ($coop =~ /\Q${tvop}\E/) || ($coop =~ /\Q${tvcl}\E/)
		 || ($cocl =~ /\Q${tvop}\E/) || ($cocl =~ /\Q${tvcl}\E/)
		){ warn __PACKAGE__.'::configfile2perl()'." (line ".__LINE__.") : error, there is a clash (one contains the other) with verbatim/variable tags ('${tvop}' and '${tvcl}') and comment tags ('${coop}' and '${cocl}')."; return undef }
	}

	my $tsubs = exists($params->{'variable-substitutions'})
		? $params->{'variable-substitutions'} : undef
	;

	# remove comments inside strings? default is NO, keep comments if inside strings
	# because they may not be our comments (e.g. string contains a bash script)
	my $remove_comments_in_strings = exists($params->{'remove-comments-in-strings'}) && defined($params->{'remove-comments-in-strings'})
		? $params->{'remove-comments-in-strings'} : 0
	;

	# firstly, substitute templated variables if any
	# with the user-specified data.
	# This includes ANYTHNING in the input enhanced JSON including
	# verbatim sections, keys, values, etc.
	# The opening and closing tags of vars are user-specified
	# and are NOT allowed to contain spaces in between
	# (e.g. '<  %' will not be matched if '<%' was specified)
	for my $ak (keys %$tsubs){
		my $av = $tsubs->{$ak};
		if( ($ak =~ /(?:\Q${tvop}\E)|(?:\Q${tvcl}\E)/) ){ warn __PACKAGE__.'::config2perl()'." (line ".__LINE__.") : error, variable names can not contain the specified opening ($tvop) and/or closing ($tvcl) variable name tags."; return undef }
		$contents =~ s!\Q${tvop}\E\s*${ak}\s*\Q${tvcl}\E!${av}!g;
	}
	# this is a warning:
	# we can not be sure if this <% xyz %> is part of the content or a forgotten templated variable
	# NOTE: During test t/090-config2perl-failed-verbatim.t some CPAN testers
	# report a failure. The fact is that this test deliberately tests a failed case
	# and the line below should cause the sub to exit and print a long winded, multiline error message.
	# So, some testers (3/15) report a failure.
	# see https://www.cpantesters.org/cpan/report/fbbe94b6-62e8-11ee-9f69-c1f66d8775ea
	# So, I am replacing the comment with a short comment.
	#if( $contents =~ /\Q${tvop}\E\s*!(:?(:?begin-verbatim-section)|(:?end-verbatim-section))\s*\Q${tvcl}\E/ ){ print STDERR "--begin content:\n".$contents."\n--end content.\n".__PACKAGE__.'::config2perl()'." (line ".__LINE__.") : warning, there may still be remains of templated variables in the specified content (tags used: '${tvop}' and '${tvcl} -- ignore the enclosing single quotes), see above what remained after all template variables substitutions were done." }
	if( $contents =~ /\Q${tvop}\E\s*!(:?(:?begin-verbatim-section)|(:?end-verbatim-section))\s*\Q${tvcl}\E/ ){ print STDERR __PACKAGE__.'::config2perl()'." (line ".__LINE__.") : warning, there may still be remains of templated variables in the specified content (tags used: '${tvop}' and '${tvcl}' -- ignore the enclosing single quotes), see above what remained after all template variables substitutions were done." }

	# secondly, remove the VERBATIM multiline sections and transform them.
	# Comments inside the verbatim section will NOT BE touched.
	# The only thing touched was the templated variables earlier
	# it substitutes each verbatim section with a code
	# then does the comments and then replaces the code with the verbatim section at the very end
	my @verbs;
	my $idx = 0;
	while( $contents =~ s/\Q${tvop}\E\s*begin-verbatim-section\s*\Q${tvcl}\E(.*?)\Q${tvop}\E\s*end-verbatim-section\s*\Q${tvcl}\E/"___my___verbatim-section-${idx}___my___"/s ){
		my $vc = $1;
		# remove from start and end of whole string newlines+spaces
		$vc =~ s/^[\n\t ]+//;
		$vc =~ s/[\n\t ]+$//;
		# remove newlines followed by optional spaces at the beginning of each line
		$vc =~ s/\n+[ \t]*/\\n/gs;
		# escape all double quotes (naively)
		# but not those which are already escaped (naively)
		$vc =~ s/\\"/<%__abcQQxyz__%>/g;
		$vc =~ s/"/\\"/g;
		$vc =~ s/<%__abcQQxyz__%>/\\\\\\"/g;
		# so echo "aa \"xx\""
		# becomes echo \"aa \\\"xx\\\"\"
		push @verbs, $vc;
		$idx++;
	}

	# thirdly, replace all JSON strings (keys or values) with indexed markers
	# so that their contained comments
	# to be left intact after the comment substitution which will
	# be done later on.
	my @stringsubs;
	if( $remove_comments_in_strings == 0 ){
		$idx = 0;
		while( $contents =~ s/(?
			push @stringsubs, $1;
			$idx++;
		}
	}

	# thirdly, remove comments: 'shell' and/or 'C' and/or 'CPP'
	# and/or multiple instances of 'custom()()'
	my $tc = $commentstyle;
	if( $tc =~ s/\bC\b//i ){
		$contents =~ s/\/\*(?:(?!\*\/).)*\*\/\n?//sg;
	}
	if( $tc =~ s/\bCPP\b//i ){
		$contents =~ s/\/\*(?:(?!\*\/).)*\*\/\n?//sg;
		$contents =~ s!//.*$!!mg;
	}
	if( $tc =~ s/\bshell\b//i ){
		# TODO: we must also remove the newline left!
		$contents =~ s/#.*$//mg;
	}

	# specify a custom comment style with required opening string
	# and an optional closing
	# e.g. custom(required)(optional), custom(<<)(>>) or custom(REM)()
	while( $tc =~ s/\bcustom\((.+?)\)\((.*?)\)//i ){
		# mulitple custom(opening)(closing) commentstyle are allowed
		# 'opening' and 'closing' can be any string
		# And need not be balanced e.g. <<< and >>
		# And can be the same e.g. <<< and <<<
		my $coop = $1; my $cocl = $2;
		if( $cocl =~ /^\s*$/ ){
			# TODO: we must also remove the newline left!
			$contents =~ s/\Q${coop}\E.*$//mg;
		} else {
			$contents =~ s/\Q${coop}\E(?:(?!\Q${cocl}\E\s*).)*\Q${cocl}\E\s*\n?//sg;
		}
	}
	if( $tc =~ /[a-z]/i ){ warn __PACKAGE__.'::config2perl()'." (line ".__LINE__.") : error, comments style '${commentstyle}' was not understood, this is what was left after parsing it: '${tc}'."; return undef }

	# this is a warning:
	# we can not be sure if this <% xyz %> is part of the content or a forgotten templated variable
	if( $contents =~ /\Q${tvop}\E.+?-verbatim-section\s*\Q${tvcl}\E/ ){ warn "--begin content:\n".$contents."\n--end content.\n".__PACKAGE__.'::config2perl()'." (line ".__LINE__.") : warning, there may still be remains of templated variables in the specified content, see above what remained after all verbatime sections were removed." }

	if( $remove_comments_in_strings == 0 ){
		$idx = 0;
		for($idx=scalar(@stringsubs);$idx-->0;){
			my $astring = $stringsubs[$idx];
			$contents =~ s/___my___EJSTRING\($idx\)___my___/"${astring}"/g
		}
	}

	# and now substitute the transformed verbatim sections back
	for($idx=scalar(@verbs);$idx-->0;){
		$contents =~ s/___my___verbatim-section-${idx}___my___/$verbs[$idx]/g;
	}

	if( $debug > 0 ){ warn $contents."\n\n".__PACKAGE__.'::config2perl()'." (line ".__LINE__.") : produced above standard JSON from enhanced JSON content." }

	# here $contents must contain standard JSON which we parse:
	my $inhash = json2perl($contents);
	if( ! defined $inhash ){ warn $contents."\n\n".__PACKAGE__.'::config2perl()'." (line ".__LINE__.") : error, call to ".'Data::Roundtrip::json2perl()'." has failed for above json string and comments style '${commentstyle}'."; return undef }
	return $inhash
}

=pod

=head1 NAME

Config::JSON::Enhanced - JSON-based config with C/Shell-style comments, verbatim sections and variable substitutions

=head1 VERSION

Version 0.09

=head1 SYNOPSIS

This module provides subroutine C for parsing configuration content,
from files or strings,  based on, what I call, "enhanced JSON" (see section
L for more details). Briefly, it is standard JSON which allows:

=over 2

=item * C-style, C-style, C-style or custom comments.

=item * Template-style variables (e.g. C% appdir %E>)
which are substituted with user-specified data during parsing.

=item * Verbatim sections which are a sort of here-doc for JSON,
allowing strings to span multiple
lines, to contain single and double quotes unescaped,
to contain template-style variables.

=back

This module was created because I needed to include
long shell scripts containing lots of quotes and newlines,
in a configuration file which started as JSON.

The process is simple: so-called "enhanced JSON" is parsed
by L. Comments are removed, variables are
substituted, verbatim sections become one line again
and standard JSON is created. This is parsed with
L (via L) to
produce a Perl data structure which is returned.

It has been tested with unicode data
(see C)
with success. But who knows ?!?!

Here is an example:

    use Config::JSON::Enhanced;

    # simple "enhanced" JSON with comments in 3 styles: C,shell,CPP
    my $configdata = <<'EOJ';
     {
        /* 'a' is ... */
        "a" : "abc",
        # b is ...
        "b" : [1,2,3],
        "c" : 12 // c is ...
     }
    EOJ
    my $perldata = config2perl({
        'string' => $configdata,
        'commentstyle' => "C,shell,CPP",
    });
    die "call to config2perl() has failed" unless defined $perldata;
    # the standard JSON:
    # {"a" : "abc","b" : [1,2,3], "c" : 12}


    # this "enhanced" JSON demonstrates the use of variables
    # which will be substituted during the transformation to
    # standard JSON with user-specified data.
    # Notice that the opening and closing tags enclosing variable
    # names can be customised using the 'tags' input parameter,
    # so as to avoid clashes with content in the JSON.
    my $configdata = <<'EOJ';
     {
       "d" : [1,2,<% tempvar0 %>],
       "configfile" : "<%SCRIPTDIR%>/config/myapp.conf",
       "username" : "<% username %>"
        }
     }
    EOJ
    my $perldata = config2perl({
        'string' => $configdata,
        'commentstyle' => "C,shell,CPP",
        # optionally customise the tags enclosing the variables
        # when you want to avoid clashes with other strings in JSON
        #'tags' => ['<%', '%>'], # <<< these are the default values
        # user-specified data to replace the variables in
        # the "enhanced" JSON above:
        'variable-substitutions' => {
            'tempvar0' => 42,
            'username' => getlogin(),
            'SCRIPTDIR' => $FindBin::Bin,
        },
    });
    die "call to config2perl() has failed" unless defined $perldata;
    # the standard JSON
    # (notice how all variables in <%...%> are now replaced):
    # {"d" : [1,2,42],
    #  "username" : "yossarian",
    #  "configfile" : "/home/yossarian/B52/config/myapp.conf"
    # }


    # this "enhanced" JSON demonstrates "verbatim sections"
    # the puprose of which is to make more readable JSON strings
    # by allowing them to span over multiple lines.
    # There is also no need for escaping double quotes.
    # template variables (like above) will be substituted
    # There will be no comments removal from the verbatim sections.
    my $configdata = <<'EOJ';
     {
      "a" : <%begin-verbatim-section%>
      This is a multiline
      string
      "quoted text" and 'quoted like this also'
      will be retained in the string escaped.
      White space from beginning and end will be chomped.

      <%end-verbatim-section%>
      ,
      "b" = 123
     }
    EOJ
    my $perldata = config2perl({
        'string' => $configdata,
        'commentstyle' => "C,shell,CPP",
    });
    die "call to config2perl() has failed" unless defined $perldata;
    # the standard JSON (notice that "a" value is in a single line,
    # here printed broken for readability):
    # {"a" :
    #   "This is a multiline\nstring\n\"quoted text\" and 'quoted like
    #   this also'\nwill be retained in the string escaped.\nComments
    #   will not be removed.\nWhite space from
    #   beginning and end will be chomped.",
    #  "b" : 123
    # };


=head1 EXPORT

=over 4

=item * C is exported by default.

=back


=head1 SUBROUTINES

=head2 C

  my $ret = config2perl($params);
  die unless defined $ret;

Arguments:

=over 4

=item * C<$params> : a hashref of input parameters.

=back

Return value:

=over 4

=item * the parsed content as a Perl data structure
on success or C on failure.

=back

Given input content in L, this sub removes comments
(as per preferences via input parameters),
replaces all template variables, if any,
compacts L, if any, into a single-line
string and then parses
what remains as standard JSON into a Perl data structure
which is returned to caller. JSON parsing is done with
L, which uses L.

Comments outside of JSON fields will always be removed,
otherwise JSON can not be parsed.

Comments inside of JSON fields, keys, values, strings etc.
will not be removed unless input parameter C
is set to 1 by the caller.

Comments (or what looks like comments with the current input parameters)
inside L will never be removed.

The input content to-be-parsed can be specified
with one of the following input parameters (entries in the
C<$params>):

=over 4

=item * C : content is read from a file with this name.

=item * C : content is read from a file which has already
been opened for reading by the caller.

=item * C : content is contained in this string.

=back

Additionally, input parameters can contain the following keys:

=over 4

=item * C : specify what comment style(s) to be expected
in the input content (if any) as a B. For example
C<'C,CPP,shell,custom(EE)(EE),custom(REM)()'>.
These are the values it understands:

=over 2

=item * C : comments take the form of C-style comments which
are exclusively within C. For example C<* I am a comment */>.
This is the B if none specified.

=item * C : comments can the the form of C++-style comments
which are within C or after C until the end of line.
For example C, C.

=item * C : comments can be after C<#> until the end of line.
For example, C<# I am a comment to the end of line>.

=item * C : comments are enclosed (or preceded) by custom,
user-specified tags. The form is C.
C is required. C is optional meaning that
the comment extends to the end of line (just like C comments).
For example CE)(EE)> or
C or C or CEEE)(EE)>.
C and C do not need to be of
the same character length as it is
obvious from the previous example. A word of warning:
the regex for identifying comments (and variables and verbatim sections)
has the custom tags escaped for special regex characters
(with the C<\Q ... \E> construct). So you are pretty safe in using
any character. Please report weird behaviour.

B : either opening or closing comment tags must not
be the same as opening or closing variables / verbatim section tags.

=back

=item * C : a hashref whose keys are
variable names as they occur in the input I content
and their corresponding values should substitute them. I,
can contain template variables in the form C% my-var-1 %E>. These
must be replaced with data which is supplied to the call of C
under the parameters key C, for example:

  config2perl({
    "variable-substitutions" => {
      "my-var-1" => 42,
      "SCRIPTDIR" => "/home/abc",
    },
    "string" => '{"a":"<% my-var-1 %>", "b":"<% SCRIPTDIR %>/app.conf"}',
  });

Variable substitution will be performed in both
keys and values of the input JSON, including L.

=item * C : by default no attempt
to remove what-looks-like-comments from JSON strings
(both keys and values). However, if this flag is set to
C<1> anything that looks like comments (as per the 'C'
parameter) will be removed from inside all JSON strings
(keys or values) unless they were part of verbatim section.

This does not apply for the content verbatim sections.
What looks like comments to us, inside verbatim sections
will be left intact.

For example consider the JSON string C<"hello/*a comment*/">
(which can be a key or a value). If C is
set to 1, then the JSON string will become C. If set to
0 (which is the default) it will be unchanged.

=item * C : specify the opening and closing tags for template
variables and verbatim section as an ARRAYref of exactly 2 items (the
opening and the closing tags). By default the opening tag is C%>
and the closing tag is C<%E>. A word of warning:
the regex for identifying variables and verbatim sections (and comments)
has the custom tags escaped for special regex characters
(with the C<\Q ... \E> construct). So you are pretty safe in using
any character. Please report weird behaviour.

If you set C [ '[::', '::]' ]>
then your template variables should look like this: C<{:: var1 ::]> and
verbatim sections like this: C<[:: begin-verbatim-section ::]>.

=item * C : set this to a positive integer to increase verbosity
and dump debugging messages. Default is zero for zero verbosity.

=back

See section L for details on the format
of B I.

C returns the parsed content as a Perl data structure
on success or C on failure.


=head1 ENHANCED JSON FORMAT

This is JSON with added reasonable, yet completely ad-hoc, enhancements
(from my point of view).

These enhancements are:

=over 4

=item * B:

=over 2

=item * C-style comments take the form of C-style comments which
are exclusively within C. For example C<* I am a comment */>

=item * C-style comments can the the form of C++-style comments
which are within C or after C until the end of line.
For example C, C

=item * C-style comments can be after C<#> until the end of line.
For example, C<# I am a comment to the end of line.>

=item * comments with C, user-specified, opening and
optional closing tags
which allows fine-tuning the process of deciding on something being a
comment.

=back

=item * B