testygen

package of develop dns

#! /usr/bin/perl -w
#
# Copyright (c) 2002 Japan Network Information Center.
# All rights reserved.
#  
# By using this file, you agree to the terms and conditions set forth bellow.
# 
# 			LICENSE TERMS AND CONDITIONS 
# 
# The following License Terms and Conditions apply, unless a different
# license is obtained from Japan Network Information Center ("JPNIC"),
# a Japanese association, Kokusai-Kougyou-Kanda Bldg 6F, 2-3-4 Uchi-Kanda,
# Chiyoda-ku, Tokyo 101-0047, Japan.
# 
# 1. Use, Modification and Redistribution (including distribution of any
#    modified or derived work) in source and/or binary forms is permitted
#    under this License Terms and Conditions.
# 
# 2. Redistribution of source code must retain the copyright notices as they
#    appear in each source code file, this License Terms and Conditions.
# 
# 3. Redistribution in binary form must reproduce the Copyright Notice,
#    this License Terms and Conditions, in the documentation and/or other
#    materials provided with the distribution.  For the purposes of binary
#    distribution the "Copyright Notice" refers to the following language:
#    "Copyright (c) 2000-2002 Japan Network Information Center.  All rights reserved."
# 
# 4. The name of JPNIC may not be used to endorse or promote products
#    derived from this Software without specific prior written approval of
#    JPNIC.
# 
# 5. Disclaimer/Limitation of Liability: THIS SOFTWARE IS PROVIDED BY JPNIC
#    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
#    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
#    PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL JPNIC BE LIABLE
#    FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
#    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
#    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
#    BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
#    WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
#    OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
#    ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
#
use FileHandle;
use Getopt::Std;

#
# Parsing status.
#
my $STATUS_HEADER         = 0;
my $STATUS_HEADER_COMMENT = 1;
my $STATUS_SEPARATOR      = 2;
my $STATUS_BODY           = 3;
my $STATUS_GLOBAL         = 4;
my $STATUS_GLOBAL_COMMENT = 5;
my $STATUS_PREAMBLE       = 6;

my $LINENO_MARK = "<LINENO>";

#
# Create a new testsuite context.
#
sub new_testsuite {
    return {'ntests'    => 0,
	    'setups'    => {},
	    'teardowns' => {},
	    'tests'     => [],
	    'titles'    => [],
	    'preambles' => ''};
}

#
# Read `$file' and put the result into `$testsutie'.
#
sub parse_file {
    my ($testsuite, $file, $lineinfo) = @_;
    my $parser = {'type'     => '',
		  'group'    => '',
		  'title'    => '',
		  'status'   => $STATUS_PREAMBLE,
		  'error'    => '',
		  'file'     => $file,
		  'lineno'   => 0,
		  'lineinfo' => $lineinfo};

    my $handle = FileHandle->new($file, 'r');
    if (!defined($handle)) {
	die "failed to open the file, $!: $file\n";
    }

    my ($result, $line);
    for (;;) {
	$line = $handle->getline();
	last if (!defined($line));

	chomp($line);
	$line .= "\n";
	$parser->{lineno}++;
	$result = parse_line($testsuite, $parser, $line);
	if (!$result) {
	    die sprintf("%s, at line %d\n",
			$parser->{error}, $parser->{lineno});
	}
    }

    if ($parser->{status} != $STATUS_GLOBAL) {
	die "unexpected EOF, at line $.\n";
    }

    $handle->close();
}

sub parse_line {
    my ($testsuite, $parser, $line) = @_;
    my $result = 1;

    if ($parser->{status} == $STATUS_HEADER) {
	if ($line =~ /^\/\/--/) {
	    $parser->{status} = $STATUS_HEADER_COMMENT;
	} elsif ($line =~ /^\/\//) {
	    $result = parse_header($testsuite, $parser, $line);
	} elsif ($line =~ /^\s*$/) {
	    $parser->{status} = $STATUS_SEPARATOR;
	    $result = parse_endheader($testsuite, $parser, $line);
	} elsif ($line =~ /^\{\s*$/) {
	    $parser->{status} = $STATUS_BODY;
	    $result = parse_endheader($testsuite, $parser, $line)
		&& parse_startbody($testsuite, $parser, $line);
	} else {
	    $parser->{error} = 'syntax error';
	    $result = 0;
	}

    } elsif ($parser->{status} == $STATUS_HEADER_COMMENT) {
	if ($line =~ /^\/\//) {
	    # nothing to be done.
	} elsif ($line =~ /^\s*$/) {
	    $parser->{status} = $STATUS_SEPARATOR;
	    $result = parse_endheader($testsuite, $parser, $line);
	} elsif ($line =~ /^\{\s*$/) {
	    $parser->{status} = $STATUS_BODY;
	    $result = parse_endheader($testsuite, $parser, $line)
		&& parse_startbody($testsuite, $parser, $line);
	} else {
	    $parser->{error} = 'syntax error';
	    $result = 0;
	}

    } elsif ($parser->{status} == $STATUS_SEPARATOR) {
	if ($line =~ /^\s*$/) {
	    # nothing to be done.
	} elsif ($line =~ /^\{\s*$/) {
	    $parser->{status} = $STATUS_BODY;
	    $result = parse_startbody($testsuite, $parser, $line);
	} else {
	    $parser->{error} = 'syntax error';
	    $result = 0;
	}

    } elsif ($parser->{status} == $STATUS_BODY) {
	if ($line =~ /^\}\s*$/) {
	    $parser->{status} = $STATUS_GLOBAL;
	    $result = parse_endbody($testsuite, $parser, $line);
	} else {
	    $result = parse_body($testsuite, $parser, $line);
	}

    } elsif ($parser->{status} == $STATUS_GLOBAL) {
	if ($line =~ /^\/\/\#/) {
	    $parser->{status} = $STATUS_HEADER;
	    $result = parse_startheader($testsuite, $parser, $line);
	} elsif ($line =~ /^\/\/--/) {
	    $parser->{status} = $STATUS_GLOBAL_COMMENT;
	} elsif ($line =~ /^\s*$/) {
	    # nothing to be done.
	} else {
	    $parser->{error} = 'syntax error';
	    $result = 0;
	}

    } elsif ($parser->{status} == $STATUS_GLOBAL_COMMENT) {
	if ($line =~ /^\/\//) {
	    # nothing to be done.
	} elsif ($line =~ /^\s*$/) {
	    $parser->{status} = $STATUS_GLOBAL;
	} else {
	    $parser->{error} = 'syntax error';
	    $result = 0;
	}

    } elsif ($parser->{status} == $STATUS_PREAMBLE) {
	if ($line =~ /^\/\/\#/) {
	    $parser->{status} = $STATUS_HEADER;
	    $result = parse_startheader($testsuite, $parser, $line);
	} elsif ($line =~ /^\/\/--/) {
	    $parser->{status} = $STATUS_GLOBAL_COMMENT;
	} else {
	    $result = parse_preamble($testsuite, $parser, $line);
	}

    } else {
	$parser->{error} = 'syntax error';
	$result = 0;
    }

    return $result;
}

sub parse_startheader {
    my ($testsuite, $parser, $line) = @_;

    if ($line =~ /^\/\/\#\s*(SETUP|TEARDOWN|TESTCASE)\s*$/) {
	$parser->{type}  = $1;
	$parser->{group} = '';
	$parser->{title} = '';
    } else {
	$parser->{error} = 'invalid test-header format';
	return 0;
    }


    return 1;
}

sub parse_header {
    my ($testsuite, $parser, $line) = @_;

    my $field = $line;
    $field =~ s/^\/\/\s*//;
    $field =~ s/^(\S+):\s*/$1:/;
    $field =~ s/\s+$//;

    return 1 if ($field eq '');

    if ($field =~ /^group:(.*)$/) {
	my $group = $1;

	if ($parser->{group} ne '') {
	    $parser->{error} = "group defined twice in a header";
	    return 0;
	}
	if ($parser->{type} eq 'SETUP') {
	    if ($group !~ /^[0-9A-Za-z_\-]+$/) {
		$parser->{error} = "invalid group name";
		return 0;
	    }
	    if (defined($testsuite->{setups}->{$group})) {
		$parser->{error} = sprintf("SETUP \`%s' redefined", $group);
		return 0;
	    }
	} elsif ($parser->{type} eq 'TEARDOWN') {
	    if ($group !~ /^[0-9A-Za-z_\-]+$/) {
		$parser->{error} = "invalid group name";
		return 0;
	    }
	    if (defined($testsuite->{teardowns}->{$group})) {
		$parser->{error} = sprintf("TEARDOWN \`%s' redefined", $group);
		return 0;
	    }
	} else {
	    foreach my $i (split(/[ \t]+/, $group)) {
		if ($i !~ /^[0-9A-Za-z_\-]+$/) {
		    $parser->{error} = "invalid group name \`$i'";
		    return 0;
		}
		if (!defined($testsuite->{setups}->{$i})
		    && !defined($testsuite->{teardowns}->{$i})) {
		    $parser->{error} = sprintf("group \'%s' not defined", $i);
		    return 0;
		}
	    }
	}
	$parser->{group} = $group;

    } elsif ($field =~ /^title:(.*)$/) {
	my $title = $1;

	if ($parser->{title} ne '') {
	    $parser->{error} = "title defined twice in a header";
	    return 0;
	}
	if ($title =~ /[\x00-\x1f\x7f-\xff\"\\]/ || $title eq '') {
	    $parser->{error} = "invalid title";
	    return 0;
	}
	if ($parser->{type} ne 'TESTCASE') {
	    $parser->{error} = sprintf("title for %s is not permitted",
				       $parser->{type});
	    return 0;
	}
	$parser->{title} = $title;

    } else {
	$parser->{error} = "invalid test-header field";
	return 0;
    }

    return 1;
}

sub parse_endheader {
    my ($testsuite, $parser, $line) = @_;

    if ($parser->{type} ne 'TESTCASE' && $parser->{group} eq '') {
	$parser->{error} = "missing \`group' in the header";
	return 0;
    }

    if ($parser->{type} eq 'TESTCASE' && $parser->{title} eq '') {
	$parser->{error} = "missing \`title' in the header";
	return 0;
    }

    return 1;
}

sub parse_startbody {
    my ($testsuite, $parser, $line) = @_;
    my $group = $parser->{group};

    if ($parser->{type} eq 'SETUP') {
	if ($parser->{lineinfo}) {
	    $testsuite->{setups}->{$group} =
		generate_line_info($parser->{lineno} + 1, $parser->{file});
	}
    } elsif ($parser->{type} eq 'TEARDOWN') {
	if ($parser->{lineinfo}) {
	    $testsuite->{teardowns}->{$group} =
		generate_line_info($parser->{lineno} + 1, $parser->{file});
	}
    } else {
	$testsuite->{ntests}++;
	push(@{$testsuite->{tests}}, '');
	push(@{$testsuite->{titles}}, $parser->{title});

	$testsuite->{tests}->[-1] .= "\n";
	$testsuite->{tests}->[-1] .= "$LINENO_MARK\n";
	$testsuite->{tests}->[-1] .= 
	    sprintf("static void\ntestcase\%d(idn_testsuite_t ctx__) {\n", 
		    $testsuite->{ntests});

	my (@group_names) = split(/[ \t]+/, $group);
	for (my $i = 0; $i < @group_names; $i++) {
	    if (defined($testsuite->{setups}->{$group_names[$i]})) {
		$testsuite->{tests}->[-1] .= "\t\{\n";
		$testsuite->{tests}->[-1] .= "#undef EXIT__\n";
		$testsuite->{tests}->[-1] .= "#define EXIT__ exit${i}__\n";
		$testsuite->{tests}->[-1] .=
		    $testsuite->{setups}->{$group_names[$i]};
	    }
	}
	$testsuite->{tests}->[-1] .= "$LINENO_MARK\n";
	$testsuite->{tests}->[-1] .= "\t\{\n";
	$testsuite->{tests}->[-1] .= "#undef EXIT__\n";
	$testsuite->{tests}->[-1] .= "#define EXIT__ exit__\n";
	if ($parser->{lineinfo}) {
	    $testsuite->{tests}->[-1] .= 
		generate_line_info($parser->{lineno} + 1, $parser->{file});
	}
    }

    return 1;
}

sub parse_body {
    my ($testsuite, $parser, $line) = @_;
    my ($group) = $parser->{group};

    if ($parser->{type} eq 'SETUP') {
	$testsuite->{setups}->{$group} .= $line;
    } elsif ($parser->{type} eq 'TEARDOWN') {
	$testsuite->{teardowns}->{$group} .= $line;
    } else {
	$testsuite->{tests}->[-1] .= $line;
    }

    return 1;
}

sub parse_endbody {
    my ($testsuite, $parser, $line) = @_;
    my ($group) = $parser->{group};

    if ($parser->{type} eq 'TESTCASE') {
	$testsuite->{tests}->[-1] .= "$LINENO_MARK\n";
	$testsuite->{tests}->[-1] .= "\t\}\n";
	$testsuite->{tests}->[-1] .= "  exit__:\n";
	$testsuite->{tests}->[-1] .= "\t;\n";

	my (@group_names) = split(/[ \t]+/, $group);
	for (my $i = @group_names - 1; $i >= 0; $i--) {
	    $testsuite->{tests}->[-1] .= "  exit${i}__:\n";
	    $testsuite->{tests}->[-1] .= "\t;\n";
	    if (defined($testsuite->{teardowns}->{$group_names[$i]})) {
		$testsuite->{tests}->[-1] .=
		    $testsuite->{teardowns}->{$group_names[$i]};
	    }
	    $testsuite->{tests}->[-1] .= "$LINENO_MARK\n";
	    $testsuite->{tests}->[-1] .= "\t\}\n";
	}

	$testsuite->{tests}->[-1] .= "}\n";
    }

    return 1;
}

sub parse_preamble {
    my ($testsuite, $parser, $line) = @_;

    if ($parser->{lineinfo} && $parser->{lineno} == 1) {
	$testsuite->{preambles} .= generate_line_info(1, $parser->{file});
    }
    $testsuite->{preambles} .= $line;
    return 1;
}

sub generate_line_info {
    my ($lineno, $file) = @_;
    return "#line $lineno \"$file\"\n";
}

#
# Output `$testsuite' as source codes of C.
#
sub output_tests {
    my ($testsuite, $file, $lineinfo) = @_;

    my $generator = {
	'file' => $file,
	'lineno' => 0
    };

    my $handle = FileHandle->new($file, 'w');
    if (!defined($handle)) {
	die "failed to open the file, $!: $file\n";
    }

    my $preamble_header =
        "/* This file is automatically generated by testygen. */\n\n"
        . "#define TESTYGEN 1\n"
        . "\n";
    output_lines($preamble_header, $generator, $handle, $lineinfo);

    output_lines($testsuite->{preambles}, $generator, $handle, $lineinfo);

    my $preamble_footer =
        "\n"
	. "$LINENO_MARK\n"
        . "#include \"testsuite.h\"\n"
        . "\n";
    output_lines($preamble_footer, $generator, $handle, $lineinfo);


    for (my $i = 0; $i < $testsuite->{ntests}; $i++) {
	output_lines($testsuite->{tests}->[$i], $generator, $handle,
		     $lineinfo);
    }

    my $main_header = 
        "\n"
        . "$LINENO_MARK\n"
        . "int\n"
        . "main(int argc, char *argv[]) {\n"
        . "\tidn_testsuite_t ctx;\n"
        . "\tconst char *title;\n"
        . "\n"
        . "\tidn_testsuite_create(&ctx);\n";
    output_lines($main_header, $generator, $handle, $lineinfo);

    for (my $i = 0; $i < $testsuite->{ntests}; $i++) {
	my $title = $testsuite->{titles}->[$i];
	my $proc = sprintf("testcase%d", $i + 1);
	output_lines("\tidn_testsuite_addtestcase(ctx, \"$title\", $proc);\n",
		     $generator, $handle, $lineinfo);
    }

    my $main_footer = 
        "\n"
	. "\tif (argc > 1 && strcmp(argv[1], \"-v\") == 0) {\n"
	. "\t   idn_testsuite_setverbose(ctx);\n"
	. "\t   argc--;\n"
	. "\t   argv++;\n"
	. "\t}\n"
	. "\tif (argc == 1)\n"
        . "\t	idn_testsuite_runall(ctx);\n"
	. "\telse\n"
        . "\t	idn_testsuite_run(ctx, argv + 1);\n"
        . "\n"
        . "\tprintf(\"passed=%d, failed=%d, total=%d\\n\",\n"
        . "\t       idn_testsuite_npassed(ctx),\n"
        . "\t       idn_testsuite_nfailed(ctx),\n"
        . "\t       idn_testsuite_ntestcases(ctx) - idn_testsuite_nskipped(ctx));\n"
        . "\n"
        . "\tidn_testsuite_destroy(ctx);\n"
        . "\treturn (0);\n"
        . "\}\n";
    output_lines($main_footer, $generator, $handle, $lineinfo);

    $handle->close();
}

sub output_lines {
    my ($lines, $generator, $handle, $lineinfo) = @_;
    my ($line);

    chomp($lines);
    $lines .= "\n";

    while ($lines ne '') {
	$lines =~ s/^([^\n]*)\n//;
	$line = $1;
	$generator->{lineno}++;
	if ($line eq $LINENO_MARK) {
	    if ($lineinfo) {
		$handle->printf("#line %d \"%s\"\n", $generator->{lineno} + 1,
				$generator->{file});
	    }
	} else {
	    $handle->print("$line\n");
	}
    }
}

sub output_usage {
    warn "$0: [-o output-file] input-file\n";
}

#
# main.
#
my (%options);

if (!getopts('Lo:', \%options)) {
    output_usage;
    exit(1);
}
if (@ARGV != 1) {
    output_usage;
    exit(1);
}

my ($in_file) = $ARGV[0];
my ($out_file);
if (!defined($options{o})) {
    $out_file = $in_file;
    $out_file .= '\.tsy' if ($out_file !~ /\.tsy$/);
    $out_file =~ s/\.tsy$/\.c/;
} else {
    $out_file = $options{o};
}

my $testsuite = new_testsuite();
parse_file($testsuite, $in_file, !$options{L});
output_tests($testsuite, $out_file, !$options{L});

exit(0);