translate RULES.txt to Rules.pm

1 files changed, 226 insertions, 0 deletions

diff --git a/regress/fml4to8/gen_rules.pl b/regress/fml4to8/gen_rules.pl
new file mode 100755
index 00000000..9d2cfb47
--- /dev/null
+++ b/regress/fml4to8/gen_rules.pl
@@ -0,0 +1,226 @@
+#!/usr/bin/env perl
+#
+# $FML$
+#
+
+use strict;
+use Carp;
+
+my $debug     = $ENV{'debug'} || 0;
+my $var_rules = ();
+my $var_count = 0;
+my $recursive = 0;
+my $ignore_regexp = 'use_fml8_value|fml8_default|unavailable|ignore|not_yet_implemented|not_yet_configurable';
+
+_init();
+
+_preamble();
+for my $var_name (sort keys %$var_rules) {
+    _parse_var_rules($var_name, $var_rules->{ $var_name });
+}
+_trailor();
+
+exit 0;
+
+
+sub _init
+{
+    my $rules = shift @ARGV;
+    use FileHandle;
+    my $rh = new FileHandle $rules;
+    if (defined $rh) {
+	my $var_name  = '';
+	my $buf;
+
+      LINE:
+	while ($buf = <$rh>) {
+	    next LINE if $buf =~ /^\s*$/o;
+	    next LINE if $buf =~ /^\#/o;
+
+	    if ($buf =~ /^\.if\s+(\S+)/o) {
+		$var_name  = sprintf("var%s_%s", $var_count++, $1);
+		$var_rules->{ $var_name } .= $buf;
+		next LINE;
+	    }
+
+	    if ($var_name) {
+		if ($buf =~ /^\s*\.($ignore_regexp)/o) {
+		    if ($debug) {
+			print STDERR "var_name = $var_name\n";
+			print STDERR "\tignored ($1)\n";
+		    }
+
+		    $var_rules->{ $var_name } = '';
+		}
+		elsif ($buf =~ /\S+/o) {
+		    if ($debug) {
+			print STDERR "var_name = $var_name\n";
+			print STDERR "\t", $buf, "\n";
+		    }
+		    $var_rules->{ $var_name } .= $buf;
+		}
+		else {
+		    if ($debug) {
+			print STDERR "var_name = $var_name\n";
+			print STDERR "\t", $buf, "\n";
+		    }
+		    $var_rules->{ $var_name } .= $buf;
+		}
+	    }
+
+	}
+	$rh->close();
+    }
+}
+
+
+sub _preamble
+{
+    use File::Basename;
+    my $prog = basename($0);
+
+    print qq{
+# -*- perl -*-
+#     *** CAUTION *** 
+#     DO NOT EDIT THIS FILE BY HAND!.
+#     THIS FILE IS AUTOMATICALLY GENERATED BY $prog.
+#
+# \$FML\$
+#
+};
+
+print q!
+package FML::Merge::FML4::Rules;
+
+sub translate
+{
+    my ($self, $dispatch, $diff, $key, $value) = @_;
+    my $fp_rule_convert           = $dispatch->{ rule_convert };
+    my $fp_rule_prefer_fml4_value = $dispatch->{ rule_prefer_fml4_value };
+    my $s;
+
+!;
+}
+
+
+sub _trailor
+{
+    print "\n   return '';\n";
+    print "} # sub translate\n";
+    print "\n1;\n";
+}
+
+
+sub _parse_var_rules
+{
+    my ($var_name, $var_rules) = @_;
+    my $rule_out = '';
+    my $i;
+    my $found = 0;
+
+    print STDERR "ALLOC $var_name => $var_rules\n" if $debug;
+    return unless $var_name;
+    return unless $var_rules;
+
+    for my $rule (split(/\n/, $var_rules)) {
+	$i++;
+	print STDERR "$var_name [$i] $rule\n" if $debug;
+
+	if ($rule =~ /^\.if/) {
+	    $rule_out .= _parse_if($rule);
+	}
+	else {
+	    $rule =~ s/^\s*//;
+	    $rule =~ s/\s*$//;
+
+	    if ($rule =~ /^\s*\.if/) {
+		$recursive++;
+		$rule_out .= _parse_if($rule);
+		next;
+	    }
+
+	    if ($rule eq '.use_fml4_value') {
+		$found = 1;
+		$rule_out .= "   \$s .= \&\$fp_rule_prefer_fml4_value(\$self, \$diff, \$key, \$value);\n";
+	    }
+	    elsif ($rule eq '.use_fml8_value') {
+		$found = 1;
+		$rule_out .= "   \$s .= \&\$fp_rule_prefer_fml8_value(\$self, \$diff, \$key, \$value);\n";
+	    }
+	    elsif ($rule eq '.convert') {
+		$found = 1;
+		$rule_out .= "   \$s .= \&\$fp_rule_convert(\$self, \$diff, \$key, \$value);\n";
+	    }
+	    elsif ($rule =~ /^\s*\.($ignore_regexp)/o) {
+		$rule_out .= "   # $rule\n";
+	    }
+	    else {
+		$found = 1;
+		$rule_out .= "   \$s .= \"$rule\";\n";
+		$rule_out .= "   \$s .= \"\\n\";\n";
+	    }
+
+	    if ($recursive > 0) {
+		$rule_out  =~ s/\n/\n   /g;
+		$rule_out .= "   }\n";
+		$recursive--;
+	    }
+	}
+    }
+
+    if ($found) {
+	$rule_out .= "   return \$s if defined \$s;\n";
+	$rule_out .= "}\n";
+	$rule_out .= "\n";
+
+	$rule_out =~ s/^\s*\n/\n/;
+	$rule_out =~ s/\n/\n   /g;
+
+	print $rule_out;
+    }
+}
+
+
+sub _parse_if
+{
+    my ($rule) = @_;
+    my $rule_out = '';
+
+    if ($rule =~ /^\.if\s+(\S+)\s+==\s+(\S+)/) {
+	$rule_out .= "\n";
+	my ($key, $value) = ($1, $2);
+	if ($value =~ /^\d+$/o) {
+	    $rule_out .= "if (\$key eq '$key' && \$value == $value) {\n";
+	    $rule_out .= "   \$s = undef;\n";
+	}
+	else {
+	    $rule_out .= "if (\$key eq '$key' && \$value eq '$value') {\n";
+	    $rule_out .= "   \$s = undef;\n";
+	}
+    }
+    elsif ($rule =~ /^\.if\s+(\S+)\s+\!=\s+(\S+)/) {
+	$rule_out .= "\n";
+	my ($key, $value) = ($1, $2);
+	if ($value =~ /^\d+$/o) {
+	    $rule_out .= "if (\$key eq '$key' && \$value \!= $value) {\n";
+	    $rule_out .= "   \$s = undef;\n";
+	}
+	else {
+	    $rule_out .= "if (\$key eq '$key' && \$value ne '$value') {\n";
+	    $rule_out .= "   \$s = undef;\n";
+	}
+    }
+    elsif ($rule =~ /^\.if\s+(\S+)\s*$/) {
+	my $key = $1;
+	$rule_out .= "if (\$key eq '$key' && defined \$value) {\n";
+	$rule_out .= "   \$s = undef;\n";
+    }
+
+    if ($recursive > 0) {
+	$rule_out =~ s/^/   /;
+	$rule_out =~ s/\n/\n   /g;
+    }
+
+    return $rule_out;
+}
+