=head1 SimplifyRuke

PBS only accepts pure perl rules since 0.29. It is possible to write a plugin to allow
user to defined rule syntax. This plugin defines a simplified format.

note: AR ... [dependent => './dependency'] ;
the ./ in the dependency definition forces it to be from the pbs root.

=cut

#-------------------------------------------------------------------------------

use Data::TreeDumper ;
use PBS::Constants ;

my $display_simplified_rule_transformation ;

PBS::PBSConfigSwitches::RegisterFlagsAndHelp
	(
	  'display_simplified_rule_transformation'
	, \$display_simplified_rule_transformation
	, "Display debugging data about simplified rule transformation to pure perl rule."
	, ''
	) ;

#-------------------------------------------------------------------------------

sub AddTrigger
{
my ($file_name, $line, $trigger_definition) = @_ ;

PrintDebug DumpTree(\@_, "Plugin AddTrigger") if $display_simplified_rule_transformation ;

my $name = shift @$trigger_definition ;
my $triggered_and_triggering = shift @$trigger_definition ;

if('ARRAY' eq ref $triggered_and_triggering)
	{
	# $triggered_node at first posotion
	
	my $last_triggering_nodes = @$triggered_and_triggering - 1 ;
	for my $trigger (@$triggered_and_triggering[1 .. $last_triggering_nodes])
		{
		my 
			(
			  $build_ok, $build_message
			, $trigger_path_regex
			, $trigger_prefix_regex
			, $trigger_regex
			) = BuildDependentRegex($trigger) ;
			
		unless($build_ok)
			{
			PrintError("Invalid rule at '$file_name:$line' $build_message\n") ;
			PbsDisplayErrorWithContext($file_name,$line) ;
			die ;
			}
			
		my $original = $trigger ;
		$trigger = qr/^$trigger_path_regex$trigger_prefix_regex$trigger_regex$/ ;
		
		if($display_simplified_rule_transformation)
			{
			PrintDebug "Replacing '$original' by '$trigger' in trigger rule '$name' at '$file_name,$line'\n" ;
			}
		}
	}

return($name, $triggered_and_triggering) ;
}	

#-------------------------------------------------------------------------------

sub AddSubpbsRule
{
# called with arguments ($name, $node_regex, $Pbsfile, $pbs_package, @other_setup_data)
# or ($node_regex, $Pbsfile), $name and $pbs_package will be generate
# less than 2 arguments or 3 arguments is considered an error

my ($file_name, $line, $rule_definition) = @_ ;
my ($name, $node_regex, $Pbsfile, $pbs_package, @other_setup_data);

if(@$rule_definition < 2 || @$rule_definition == 3)
	{
	die "   Not enough arguments to AddSubpbsRule called at '$file_name:$line'.\n" 
		. "      Simplified AddSubpbsRule[s] either take 2 arguments (regex and pbsfile)\n"
		. "      or 4 arguments (name, regex, pbsfile, package) and optional arguments.\n" ;
	}
elsif(@$rule_definition == 2)
	{
	($node_regex, $Pbsfile, $pbs_package) = @$rule_definition ;
	$pbs_package = $name = "$node_regex | $Pbsfile" ; 
	}
else
	{
	($name, $node_regex, $Pbsfile, $pbs_package, @other_setup_data) = @$rule_definition ;
	}

unless('Regexp' eq ref $node_regex)
	{
	PrintDebug DumpTree(\@_, "Plugin AddSubpsRule") if $display_simplified_rule_transformation ;
	my 
		(
		  $build_ok, $build_message
		, $dependent_path_regex
		, $dependent_prefix_regex
		, $dependent_regex
		) =  BuildDependentRegex($node_regex) ;
		
	if($build_ok)
		{
		my $original = $node_regex ;
		$node_regex = qr/$dependent_path_regex$dependent_prefix_regex$dependent_regex/ ;	
		
		if($display_simplified_rule_transformation)
			{
			PrintDebug "Replacing '$original' by '$node_regex' in subpbs rule '$name' at '$file_name,$line'\n" ;
			}
		
		}
	else
		{	
		PrintError("Invalid rule at '$file_name:$line' $build_message\n") ;
		PbsDisplayErrorWithContext($file_name,$line) ;
		die ;
		}
	}

return($name, $node_regex, $Pbsfile, $pbs_package, @other_setup_data) ;
}

#-------------------------------------------------------------------------------

sub AddRule
{
# this implementation of the AddRule plugin translates simplified rule definition
# to a pure perl rule definition. 

# NOTE: A reference to the original rule is passed and directely manipulated

my ($file_name, $line, $rule_definition) =  @_ ;

PrintDebug DumpTree(\@_, "Plugin AddRule") if $display_simplified_rule_transformation ;

my ($types, $name, $creator, $dependent, $dependencies, $builder, $node_subs) = ParseRule($file_name, $line, @$rule_definition) ;

my $is_meta_rule = grep{ $_ eq META_RULE } @$types ;

if(defined $dependent && '' eq ref $dependent && !$is_meta_rule)
	{
	# compute new arguments to Addrule
	my 
		(
		  $dependency_regex_ok, $dependency_regex_message
		, $dependent_path_regex
		, $dependent_prefix_regex
		, $dependent_regex
		) =  BuildDependentRegex($dependent) ;
		
	unless($dependency_regex_ok)
		{
		PrintError("Invalid rule at '$file_name:$line' $dependency_regex_message\n") ;
		PbsDisplayErrorWithContext($file_name,$line) ;
		die ;
		}
		
	my $sub_dependent_regex = qr/^$dependent_path_regex($dependent_prefix_regex)$dependent_regex$/ ;
	
	if($display_simplified_rule_transformation)
		{
		PrintDebug "Replacing '$dependent' by '$sub_dependent_regex' in rule '$name' at '$file_name,$line'\n" ;
		}
	
	$dependencies = TransformToPurePerlDependencies($dependencies) ;
	
	my $dependent_and_dependencies = [$sub_dependent_regex, @$dependencies];
	unshift @$dependent_and_dependencies, $creator if($creator) ;
	
	@$rule_definition = ($types, $name, $dependent_and_dependencies, $builder, $node_subs) ;
	}
elsif (defined $dependent && 'HASH' eq ref $dependent)
	{
	# allow simplified regex in subpbses
	
	unless('Regexp' eq ref $dependent->{NODE_REGEX})
		{
		my 
			(
			  $build_ok, $build_message
			, $dependent_path_regex
			, $dependent_prefix_regex
			, $dependent_regex
			) =  BuildDependentRegex($dependent->{NODE_REGEX}) ;
			
		if($build_ok)
			{
			my $original = $dependent->{NODE_REGEX} ;
			$dependent->{NODE_REGEX} = qr/$dependent_path_regex$dependent_prefix_regex$dependent_regex/ ;	
			
			if($display_simplified_rule_transformation)
				{
				PrintDebug "Replacing '$original' by '$dependent->{NODE_REGEX}' in subpbs rule '$name' at '$file_name,$line'\n" ;
				}
			
			}
		else
			{	
			PrintError("Invalid rule at  '$file_name:$line' $build_message\n") ;
			PbsDisplayErrorWithContext($file_name,$line) ;
			die ;
			}
		}
	}
}

#-------------------------------------------------------------------------------

sub ParseRule
{
my ($file_name, $line, @rule_definition) = @_ ;

my ($rule_type, $name, $creator, $dependent, $dependencies, $builder, $node_subs) = (0);

my $first_argument = shift @rule_definition ;

if('ARRAY' eq ref $first_argument)
	{
	$rule_type = $first_argument ;
	$name = shift @rule_definition;
	}
else
	{
	if('' eq ref $first_argument)
		{
		$name = $first_argument ;
		$rule_type = [UNTYPED] ;
		}
	else
		{
		Carp::carp ERROR("Invalid rule at '$file_name:$line'. Expecting a string or an array ref as first argument.") ;
		PbsDisplayErrorWithContext($file_name,$line) ;
		die ;
		}
	}

my $is_meta_rule = grep{ $_ eq META_RULE } @$rule_type ;

(my $depender_and_dependencies, $builder, $node_subs) = @rule_definition ;

if('ARRAY' eq ref $depender_and_dependencies and !$is_meta_rule)
	{
	($dependent, my @dependencies) = @$depender_and_dependencies ;
	
	if('ARRAY' eq ref $dependent)
		{
		$creator = $dependent ;
		$dependent = shift @dependencies ;
		}
		
	$dependencies = \@dependencies ;
	}
else
	{
	$dependent = $depender_and_dependencies ;
	}
	
return ($rule_type, $name, $creator, $dependent, $dependencies, $builder, $node_subs) ;
}

#-------------------------------------------------------------------------------

sub BuildDependentRegex
{
# Given a simplified dependent definition, this sub creates a perl regex

my $dependent_regex_definition = shift ;
my $error_message   = '' ;

if((! defined $dependent_regex_definition) || $dependent_regex_definition eq '')
	{
	return(0, 'Empty Regex definition') ;
	}

my ($dependent_name, $dependent_path, $dependent_ext) = File::Basename::fileparse($dependent_regex_definition,('\..*')) ;
$dependent_path =~ s|\\|/|g;

my $dependent_regex = $dependent_name . $dependent_ext ;
unless(defined $dependent_regex)
	{
	$error_message = "Invalid dependency definition" ;
	}
	
my $dependent_path_regex = $dependent_path ;
$dependent_path_regex =~ s/(?<!\\)\./\\./g ;

if($dependent_path_regex =~ tr/\*/\*/ > 1)
	{
	$error_message = "Error: only one '*' allowed in path specification $dependent_regex." ;
	}
	
$dependent_path_regex =~ s/\*/.*/ ;
$dependent_path_regex = '\./(?:.*/)*' if $dependent_path_regex eq '\./.*/' ;

if(!File::Spec->file_name_is_absolute($dependent_path_regex) && $dependent_path_regex !~ /^\\\.\// && $dependent_path_regex !~ /^\.\*/)
	{
	$dependent_path_regex = './' . $dependent_path_regex ;
	}
	
if($dependent_regex =~ /^.[^\*]*\*/)
	{
	$error_message = "Error: '*' only allowed at first position in dependent specification '$dependent_regex'." ;
	}
	
my $dependent_prefix_regex = '' ;
if($dependent_regex =~ s/^\*//)
	{
	$dependent_prefix_regex = '[^/]*' ;
	}
	
# finaly escape special characters
# $dependent_path_regex is a regex with *, we don't want to escape it.
# $dependent_prefix_regex is a regex with *, we don't want to escape it.
$dependent_regex = quotemeta($dependent_regex) ;

return
	(
	  $error_message eq ''
	, $error_message
	, $dependent_path_regex
	, $dependent_prefix_regex
	, $dependent_regex
	) ;
}

#-------------------------------------------------------------------------------

sub TransformToPurePerlDependencies
{
my ($dependencies) = @_ ;

for my $dependency (@$dependencies)
	{
	if(defined $dependency && '' eq ref $dependency)
		{
		if($display_simplified_rule_transformation)
			{
			PrintDebug "Replacing dependency '$dependency' by " ;
			}
			
		$dependency =~ s/\*/\[basename\]/gi ;
		$dependency =~ s/\[name\]/\$name/gi ;
		$dependency =~ s/\[basename\]/\$basename/gi ;
		$dependency =~ s/\[path\]/\$path/gi ;
		$dependency =~ s/\[ext\]/\$ext/gi ;
		
		if($dependency =~ /^\.\// || $dependency =~ /^\$path/ || File::Spec->file_name_is_absolute($dependency))
			{
			# OK path set
			}
		else
			{
			$dependency = "\$path/$dependency" ;
			}
			
		if($display_simplified_rule_transformation)
			{
			PrintDebug "'$dependency'\n" ;
			}
		}
	}

return ($dependencies);
}

#-------------------------------------------------------------------------------

1 ;