package Data::Roundtrip;

use 5.006;
use strict;
use warnings;

use Encode qw/encode_utf8 decode_utf8/;
use JSON qw/decode_json encode_json/;
use Unicode::Escape;
use YAML;
use Sub::Override;
use Data::Dumper qw/Dumper/;

use Exporter qw(import);
 
our @EXPORT = qw(
	_read_from_file _write_to_file
	_read_from_filehandle _write_to_filehandle
	perl2json json2perl
	perl2yaml yaml2perl
	perl2dump dump2perl
);

sub	_read_from_file {
	my $infile = $_[0];
	my $FH;
	if( ! open $FH, '<:encoding(UTF-8)', $infile ){
		warn "failed to open file '$infile' for reading, $!";
		return undef;
	}
	my $contents = _read_from_filehandle($FH);
	close $FH;
	return $contents
}
sub	_write_to_file {
	my $outfile = $_[0];
	my $contents = $_[1];
	my $FH;
	if( ! open $FH, '>:encoding(UTF-8)', $outfile ){
		warn "failed to open file '$outfile' for reading, $!";
		return undef
	}
	if( ! _write_to_filehandle($FH, $contents) ){ warn "error, call to ".'_write_to_filehandle()'." has failed"; close $FH; return undef }
	close $FH;
	return $contents
}
sub	_read_from_filehandle {
	my $FH = $_[0];
	# you should open INFH as '<:encoding(UTF-8)'
	# or if it is STDIN, do binmode STDIN , ':encoding(UTF-8)';
	return do { local $/; <$FH> }
}
sub	_write_to_filehandle {
	my $FH = $_[0];
	my $contents = $_[1];
	# you should open $OUTFH as >:encoding(UTF-8)'
	# or if it is STDOUT, do binmode STDOUT , ':encoding(UTF-8)';
	print $FH $contents;
	return 1;
}
sub	perl2json {
	my $pv = $_[0];
	my $params = defined($_[1]) ? $_[1] : {};
	my $pretty_printing = exists($params->{'pretty'}) && defined($params->{'pretty'})
		? $params->{'pretty'} : 0
	;
	my $escape_unicode = exists($params->{'escape-unicode'}) && defined($params->{'escape-unicode'})
		? $params->{'escape-unicode'} : 0
	;
	my $json_string;
	if( $escape_unicode ){
		if( $pretty_printing ){
			$json_string = JSON->new->utf8(1)->pretty->encode($pv);
		} else { $json_string = JSON->new->utf8(1)->encode($pv) }
		$json_string = Unicode::Escape::escape($json_string, 'utf8');
	} else {
		if( $pretty_printing ){
			$json_string = JSON->new->utf8(0)->pretty->encode($pv);
		} else { $json_string = JSON->new->utf8(0)->encode($pv) }
	}
	if( ! $json_string ){ warn "perl2json() : error, no json produced from perl variable"; return undef }
	return $json_string
}
sub	perl2yaml {
	my $pv = $_[0];
	my $params = defined($_[1]) ? $_[1] : {};
	my $pretty_printing = exists($params->{'pretty'}) && defined($params->{'pretty'})
		? $params->{'pretty'} : 0
	;
	warn "perl2yaml() : pretty-printing is not supported" and $pretty_printing=0
		if $pretty_printing;

	my $escape_unicode = exists($params->{'escape-unicode'}) && defined($params->{'escape-unicode'})
		? $params->{'escape-unicode'} : 0
	;
	my ($yaml_string, $escaped);
	if( $escape_unicode ){
		if( $pretty_printing ){
			#$yaml_string = Data::Format::Pretty::YAML::format_pretty($pv);
		} else { $yaml_string = YAML::Dump($pv) }
		$yaml_string = Unicode::Escape::escape($yaml_string, 'utf8');
	} else {
		if( $pretty_printing ){
			#$yaml_string = Data::Format::Pretty::YAML::format_pretty($pv);
		} else { $yaml_string = YAML::Dump($pv) }
	}
	if( ! $yaml_string ){ warn "perl2yaml() : error, no yaml produced from perl variable"; return undef }
#	return Encode::decode_utf8($yaml_string)
	return $yaml_string
}
sub	yaml2perl {
	my $yaml_string = $_[0];
	#my $params = defined($_[1]) ? $_[1] : {};

	my $pv = YAML::Load($yaml_string);
	if( ! $pv ){ warn "yaml2perl() : error, call to YAML::Load() has failed"; return undef }
	return $pv
}
sub	json2perl {
	my $json_string = $_[0];
	#my $params = defined($_[1]) ? $_[1] : {};

	my $pv = JSON::decode_json(Encode::encode_utf8($json_string));
	if( ! defined $pv ){ warn "json2perl() :  error, call to json2perl() has failed"; return undef }
	return $pv;
}
sub	yaml2json {
	my $yaml_string = $_[0];
	my $params = defined($_[1]) ? $_[1] : {};

	my $pv = yaml2perl($yaml_string, $params);
	if( ! $pv ){ warn "yaml2json() : error, call to yaml2perl() has failed"; return undef }
	my $json = perl2json($pv, $params);
	if( ! $json ){ warn "yaml2json() : error, call to perl2json() has failed"; return undef }
	return $json
}
sub	json2yaml {
	my $json_string = $_[0];
	my $params = defined($_[1]) ? $_[1] : {};

	my $pv = json2perl($json_string, $params);
	if( ! defined $pv ){ warn "json2yaml() :  error, call to json2perl() has failed"; return undef }
	my $yaml_string = perl2yaml($pv, $params);
	if( ! defined $yaml_string ){ warn "json2yaml() :  error, call to perl2yaml() has failed"; return undef }
	return $yaml_string
}
# this bypasses Data::Dumper's obsession with escaping
# non-ascii characters by redefining qquote() sub
# The redefinition code is by [Corion] @ Perlmonks and cpan
# see https://perlmonks.org/?node_id=11115271
#
sub	perl2dump {
	my $pv = $_[0];
	my $params = defined($_[1]) ? $_[1] : {};

	local $Data::Dumper::Terse = exists($params->{'terse'}) && defined($params->{'terse'})
		? $params->{'terse'} : 0
	;
	local $Data::Dumper::Indent = exists($params->{'indent'}) && defined($params->{'indent'})
		? $params->{'indent'} : 0
	;
	my $ret;
	if( exists($params->{'dont-bloody-escape-unicode'}) && defined($params->{'dont-bloody-escape-unicode'})
	 && ($params->{'dont-bloody-escape-unicode'}==1) ){
		local $Data::Dumper::Useperl = 1;
		local $Data::Dumper::Useqq='utf8';
		my $override = Sub::Override->new(
			'Data::Dumper::qquote' => \& _qquote_redefinition_by_Corion
		);
		$ret = Dumper($pv);
		# restore the overriden sub
		$override->restore;
	} else { $ret = Dumper($pv) }
	return $ret
}
sub	dump2perl {
	my $dump_string = $_[0];
	#my $params = defined($_[1]) ? $_[1] : {};

	$dump_string =~ s/^\$VAR1\s*=\s*//g;
	my $pv = eval($dump_string);
	if( $@ || ! defined $pv ){ warn "error, failed to eval() input string alledgedly a perl variable: $@"; return undef }
	return $pv
}
# Below code is by [Corion] @ Perlmonks and cpan
# see https://perlmonks.org/?node_id=11115271
# it's for redefining Data::Dumper::qquote
# (it must be accompanied by
#  $Data::Dumper::Useperl = 1;
#  $Data::Dumper::Useqq='utf8';
sub	_qquote_redefinition_by_Corion {
  local($_) = shift;
  s/([\\\"\@\$])/\\$1/g;

  return qq("$_") unless /[[:^print:]]/;  # fast exit if only printables

  # Here, there is at least one non-printable to output.  First, translate the
  # escapes.
  s/([\a\b\t\n\f\r\e])/$Data::Dumper::esc{$1}/g;

  # no need for 3 digits in escape for octals not followed by a digit.
  s/($Data::Dumper::low_controls)(?!\d)/'\\'.sprintf('%o',ord($1))/eg;

  # But otherwise use 3 digits
  s/($Data::Dumper::low_controls)/'\\'.sprintf('%03o',ord($1))/eg;

    # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE--
  my $high = shift || "";
    if ($high eq "iso8859") {   # Doesn't escape the Latin1 printables
      if ($Data::Dumper::IS_ASCII) {
        s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
      }
      elsif ($] ge 5.007_003) {
        my $high_control = utf8::unicode_to_native(0x9F);
        s/$high_control/sprintf('\\%o',ord($1))/eg;
      }
    } elsif ($high eq "utf8") {
#     Some discussion of what to do here is in
#       https://rt.perl.org/Ticket/Display.html?id=113088
#     use utf8;
#     $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    } elsif ($high eq "8bit") {
        # leave it as it is
    } else {
      s/([[:^ascii:]])/'\\'.sprintf('%03o',ord($1))/eg;
      #s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
    }
    return qq("$_");
}

=head1 NAME

Data::Roundtrip - convert between Perl data structures, YAML and JSON with unicode support (I believe ...)

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Data::Roundtrip;

    my $foo = Data::Roundtrip->new();
    ...

=head1 EXPORT

	perl2json json2perl
	perl2yaml yaml2perl
	perl2dump dump2perl

	_read_from_file
	_write_to_file
	_read_from_filehandle
	_write_to_filehandle

=head1 SUBROUTINES/METHODS

=head2 perl2json($perlvar, $optional_paramshashref)

Given an input C<$perlvar> (which can be a simple scalar or
a nested data structure, but not an object), it will return
the equivalent JSON string. In C<$optional_paramshashref>
one can specify whether to escape unicode with
C<'escape-unicode'=>1>
and/or prettify the returned result with C<'pretty'=>1>.
The output can fed to L<Data::Roundtrip::json2perl>
for getting the Perl variable back.

Returns the JSON string on success or C<undef> on failure.

=head2 json2perl($jsonstring)

Given an input C<$jsonstring> as a string, it will return
the equivalent Perl data structure using
C<JSON::decode_json(Encode::encode_utf8($jsonstring))>.

Returns the Perl data structure on success or C<undef> on failure.

=head2 perl2yaml($perlvar, $optional_paramshashref)

Given an input C<$perlvar> (which can be a simple scalar or
a nested data structure, but not an object), it will return
the equivalent YAML string. In C<$optional_paramshashref>
one can specify whether to escape unicode with
C<'escape-unicode'=>1>. Prettify is not supported yet.
The output can fed to L<Data::Roundtrip::yaml2perl>
for getting the Perl variable back.

Returns the YAML string on success or C<undef> on failure.

=head2 yaml2perl($yamlstring)

Given an input C<$yamlstring> as a string, it will return
the equivalent Perl data structure using
C<YAML::Load($yamlstring)>

Returns the Perl data structure on success or C<undef> on failure.

=head2 perl2dump($perlvar, $optional_paramshashref)

Given an input C<$perlvar> (which can be a simple scalar or
a nested data structure, but not an object), it will return
the equivalent string (via L<Data::Dumper>).
In C<$optional_paramshashref>
one can specify whether to NOT escape unicode with
C<'dont-bloody-escape-unicode'=>1>,
and/or use terse output with C<'terse'=>1> and remove
all the incessant indentation C<indent'=>1>
which unfortunately goes to the other extreme of
producing a space-less output, not fit for human consumption.
The output can fed to L<Data::Roundtrip::dump2perl>
for getting the Perl variable back.

Returns the string representation of the input perl variable
on success or C<undef> on failure.

=head2 json2perl($jsonstring)

Given an input C<$jsonstring> as a string, it will return
the equivalent Perl data structure using
C<JSON::decode_json(Encode::encode_utf8($jsonstring))>.

Returns the Perl data structure on success or C<undef> on failure.

In C<$optional_paramshashref>
one can specify whether to escape unicode with
C<'escape-unicode'=>1>
and/or prettify the returned result with C<'pretty'=>1>.

Returns the yaml string on success or C<undef> on failure.

=head2 json2yaml($jsonstring, $optional_paramshashref)

Given an input JSON string C<$jsonstring>, it will return
the equivalent YAML string L<YAML>
by first converting JSON to a Perl variable and then
converting that variable to YAML using L<Data::Roundtrip::perl2yaml()>.
All the parameters supported by L<Data::Roundtrip::perl2yaml()>
are accepted.

Returns the YAML string on success or C<undef> on failure.

=head2 yaml2json($yamlstring, $optional_paramshashref)

Given an input YAML string C<$yamlstring>, it will return
the equivalent YAML string L<YAML>
by first converting YAML to a Perl variable and then
converting that variable to JSON using L<Data::Roundtrip::perl2json()>.
All the parameters supported by L<Data::Roundtrip::perl2json()>
are accepted.

Returns the JSON string on success or C<undef> on failure.

=head1 AUTHOR

Andreas Hadjiprocopis, C<< <bliako at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-data-roundtrip at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Data-Roundtrip>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Data::Roundtrip


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Data-Roundtrip>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Data-Roundtrip>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Data-Roundtrip>

=item * Search CPAN

L<https://metacpan.org/release/Data-Roundtrip>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

This software, EXCEPT the portion created by [Corion] @ Perlmonks,
 is Copyright (c) 2020 by Andreas Hadjiprocopis.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)


=cut

1; # End of Data::Roundtrip