#! /bin/false

# Copyright (C) 2016-2020 Guido Flohr <guido.flohr@cantanea.com>,
# all rights reserved.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package Qgoda::JavaScript::Environment;
$Qgoda::JavaScript::Environment::VERSION = '0.9.8';
use strict;

use Qgoda::Util qw(empty);
use JavaScript::Duktape::XS 0.000074;
use Cpanel::JSON::XS qw(decode_json);
use File::Spec;
use File::Basename qw(dirname);
use Locale::TextDomain qw(qgoda);

BEGIN {
	if ($JavaScript::Duktape::XS::VERSION ne '0.000074') {
		die __x("You are using version '{version}' of 'JavaScript::Duktape::XS'"
		        . " which is too new.  Please downgrade to version 0.000074."
		        . " See '{url}' for details!\n",
		        version => $JavaScript::Duktape::XS::VERSION,
		        url => 'https://github.com/gflohr/qgoda/issues/86');
	}
}

sub new {
	my ($class, %args) = @_;

	my $global = $args{global};
	$global = [$global] if defined $global;
	my @global = @{$global || []};
	my $exchange = empty $args{exchange} ? '__perl__' : $args{exchange};

	my $self = {
		__global => [@global],
		__exchange_name => $exchange,
	};

	my $module_resolve = sub {
		my ($module, $path) = @_;

		#warn "require('$module') from '$path'\n";
		return $self->__normalize($self->__moduleResolve($module, $path));
	};

	my $module_load = sub {
		my ($filename) = @_;

		#warn "Loading $filename\n";
		return $self->__moduleLoad($filename);
	};

	# Our exchange buffer with the JavaScript world.
	my $perl = {
		output => {}
	};

	$self->{__vm} = JavaScript::Duktape::XS->new(
		{
			save_messages => $args{no_output}
		}
	);
	$self->{__vm}->set(perl_module_resolve => $module_resolve);
	$self->{__vm}->set(perl_module_load => $module_load);

	my $no_console = $args{'no_console'};
	$self->{__jsout} = '';
	$self->{__jserr} - '';
	$self->{__no_output} = $args{'no_output'};

	unless ($no_console) {
		$perl->{modules}->{console} = {
			log => sub {
				if ($args{no_output}) {
					$self->{__jsout} .= shift . "\n";
				} else {
					print shift . "\n";
				}
			},
			error => sub {
				if ($args{no_output}) {
					$self->{__jserr} .= shift . "\n";
				} else {
					print STDERR shift . "\n";
				}
			},
			warn => sub {
				if ($args{no_output}) {
					$self->{__jserr} .= shift . "\n";
				} else {
					print STDERR shift . "\n";
				}
			}
		};

		$self->{__vm}->set(console => {});
	}

	# All code that wants to call back into Perl must run after thie line.
	$self->{__vm}->set($exchange, $perl);
	$self->{__exchange} = $perl;

	unless ($no_console) {
		require 'Qgoda/JavaScript/console.js';
		$self->{__vm}->eval(Qgoda::JavaScript::console->code);
	}

	bless $self, $class;
}

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

	my $exchange = $self->{__vm}->get($self->{__exchange_name}) or return;

	if (@_ > 2) {
		$exchange->{$key} = $value;
		$self->{__vm}->set($self->{__exchange_name}, $exchange);
	}

	return $exchange->{$key};
}

sub run {
	my ($self, $code) = @_;

	my $q = Qgoda->new;

	if ($self->{__no_output}) {
		$self->{__jsout} = '';
		$self->{__jserr} = '';
		$self->{__vm}->reset_msgs;
	}

	my $retval = $self->{__vm}->eval($code);

	if ($self->{__no_output}) {
		my $stdout = $self->{__jsout};
		$stdout = '' if empty $stdout;
		my $vm_stdout = $self->{__vm}->get_msgs->{stdout};
		$vm_stdout = '' if empty $vm_stdout;

		my $stderr = $self->{__jserr};
		$stderr = '' if empty $stderr;
		my $vm_stderr = $self->{__vm}->get_msgs->{stderr};
		$vm_stderr = '' if empty $vm_stderr;

		my $q = Qgoda->new;
		$q->jsout($stdout . $vm_stdout);
		$q->jserr($stderr . $vm_stderr);
	}

	$q->jsreturn($self->{__vm}->get($self->{__exchange_name} . '.return'));

	return $retval;
}

sub vm {
	shift->{__vm};
}

sub __moduleResolve {
	my ($self, $module, $path) = @_;

	# FIXME! Do we have to implement a cache or does Duktape do that for us?
	$path = '' if !defined $path;
	$path = '' if $module =~ m{^/};
	$path = dirname $path if '' ne $path;

	if ($module =~ m{^\.{0,2}/}) {
		my $resolved = eval { $self->__loadAsFile("$path/$module") };
		$@ or return $resolved;
		$resolved = eval { $self->__loadAsDirectory("$path/$module") };
		$@ or return $resolved;
	}

	my $resolved = eval { $self->__loadNodeModules($module, $path) };
	$@ or return $resolved;

	$self->__jsError(__x("Cannot find module '{module}'!\n",
	                     module => $module));
}

sub __moduleLoad {
	my ($self, $filename) = @_;

	open my $fh, '<', $filename
		or $self->__jsError(__x("error reading '{filename}': {err}\n",
		                        filename => $filename, err => $!));

	my $code = join '', <$fh>;
	if ($filename =~ /\.json$/) {
		$code = 'module.exports = ' . $code;
	}

	return $code;
}

sub __normalize {
	my ($self, $path) = @_;

	my $here = $path =~ s{^./}{};

	# canonpath does string manipulation, but does not remove "..".
	my $ret = File::Spec->canonpath($path);

	# Let's remove ".." by using a regex.
	while ($ret =~ s{
		(^|/)			  # Either the beginning of the string, or a slash, save as $1
		(				  # Followed by one of these:
			[^/]|		  #  * Any one character (except slash, obviously)
			[^./][^/]|	 #  * Two characters where
			[^/][^./]|	 #	they are not ".."
			[^/][^/][^/]+  #  * Three or more characters
		)				  # Followed by:
		/\.\./			 # "/", followed by "../"
		}{$1}x
	) {
		# Repeat this substitution until not possible anymore.
	}

	# Re-adding the trailing slash, if needed.
	if ($path =~ m!/$! && $ret !~ m!/$!) {
		$ret .= '/';
	}

	$ret = './' . $ret if $here;

	return $ret;
}

sub __jsError {
	my ($self, $error) = @_;

	#warn $error;
	die $error;
}

sub __isFile {
	my ($self, $filename) = @_;

	return 1 if -e $filename && !-d $filename;
}

sub __loadAsFile {
	my ($self, $name) = @_;

	my $filename = $name;
	return $filename if $self->__isFile($filename);
	$filename = "$name.js";
	return $filename if $self->__isFile($filename);
	# FIXME! Try to mark $filename as json.  That's safer than looking
	# at the extender;
	$filename = "$name.json";
	return $filename if $self->__isFile($filename);

	die;
}

sub __loadAsIndex {
	my ($self, $name) = @_;

	return "$name/index.js" if $self->__isFile("$name/index.js");
	return "$name/index.json" if $self->__isFile("$name/index.json");

	die;
}

sub __loadAsDirectory {
	my ($self, $name) = @_;

	# Load as directory.
	my $package_json = join '/', $name, 'package.json';
	if ($self->__isFile($package_json)) {
		open my $fh, '<', $package_json
				or die;

		my $decoder = Cpanel::JSON::XS->new;
   		my $package = join '', <$fh>;
		$package = $decoder->decode($package);

		my $main = $package->{main};
		$main = '' if !defined $main;
		$main = "$name/$main";
		my $resolved = eval { $self->__loadAsFile($main) };
		$@ or return $resolved;
		return $self->__loadAsIndex($main);
	}

	return $self->__loadAsIndex($name);
}

sub __nodeModulesPath {
	my ($self, $start) = @_;

	$start = '.' if empty $start;
	my @parts = split /\//, $start;
	my $i = -1 + @parts;
	my @dirs = @{$self->{__global}};
	while ($i >= 0) {
		if ('node_modules' eq $parts[$i]) {
			--$i;
			next;
		}
		push @dirs, join '/', @parts[0 .. $i], 'node_modules';
		--$i;
	}

	return @dirs;
}

sub __loadNodeModules {
	my ($self, $module, $path) = @_;

	my @dirs = $self->__nodeModulesPath($path);
	foreach my $dir (@dirs) {
		my $resolved = eval { $self->__loadAsFile("$dir/$module") };
		$@ or return $resolved;
		$resolved = eval { $self->__loadAsDirectory("$dir/$module") };
		$@ or return $resolved;
	}

	die;
}

1;