#!/usr/bin/env perl -w
#############################################################################
# Name:        regex.pl
# Purpose:     Generate test code for wxRegEx from 'reg.test'
# Author:      Mike Wetherell
# RCS-ID:      $Id$
# Copyright:   (c) Mike Wetherell
# Licence:     wxWidgets licence
#############################################################################

#
# Notes:
#   See './regex.pl -h' for usage
#
#   Output at the moment is C++ using the cppunit testing framework. The
#   language/framework specifics are separated, with the following 5
#   subs as an interface: 'begin_output', 'begin_section', 'write_test',
#   'end_section' and 'end_output'. So for a different language/framework,
#   implement 5 new similar subs.
# 
#   I've avoided using 'use encoding "UTF-8"', since this wasn't available
#   in perl 5.6.x. Instead I've used some hacks like 'pack "U0C*"'. Versions
#   earler than perl 5.6.0 aren't going to work.
#

use strict;
use File::Basename;
#use encoding "UTF-8";  # enable in the future when perl 5.6.x is just a memory

# if 0 output is wide characters, if 1 output is utf8 encoded
my $utf = 1;

# quote a parameter (C++ helper)
#
sub quotecxx {
    my %esc = ( "\a" => "a", "\b" => "b", "\f" => "f",
                "\n" => "n", "\r" => "r", "\t" => "t",
                "\013" => "v", '"' => '"', "\\" => "\\" );

    # working around lack of 'use encoding'
    $_ = pack "U0C*", unpack "C*", $_;
    use utf8;

    s/[\000-\037"\\\177-\x{ffff}]/
        if ($esc{$&}) {
            "\\$esc{$&}";
        } elsif (ord($&) > 0x9f) {
            if ($utf) {
                $&;
            } else {
                sprintf "\\u%04x", ord($&);
            }
        } else {
            sprintf "\\%03o", ord($&);
        }
    /ge;

    # working around lack of 'use encoding'
    no utf8;
    $_ = pack "C*", unpack "C*", $_;

    return ($utf ? '"' : 'L"') . $_ . '"'
}

# start writing the output code (C++ interface)
#
sub begin_output {
    my ($from, $instructions) = @_;

    # embed it in the comment
    $from = "\n$from";
    $from =~ s/^(?:   )?/ * /mg;

    # $instructions contains information about the flags etc.
    if ($instructions) {
        $instructions = "\n$instructions";
        $instructions =~ s/^(?:   )?/ * /mg;
    }

    my $u = $utf ? " (UTF-8 encoded)" : "";

    print <<EOT;
/*
 * Test data for wxRegEx$u
$from$instructions */

EOT
}

my @classes;

# start a new section (C++ interface)
#
sub begin_section {
    my ($id, $title) = @_;
    my $class = "regextest_$id";
    $class =~ s/\W/_/g;
    push @classes, [$id, $class];

    print <<EOT;

/*
 * $id $title
 */

class $class : public RegExTestSuite
{
public:
    $class() : RegExTestSuite("regex.$id") { }
    static Test *suite();
};

Test *$class\::suite()
{
    RegExTestSuite *suite = new $class;

EOT
}

# output a test line (C++ interface)
#
sub write_test {
    my @args = @_;
    $_ = quotecxx for @args;
    print "    suite->add(" . (join ', ', @args) . ", NULL);\n"; 
}

# end a section (C++ interface)
#
sub end_section {
    my ($id, $class) = @{$classes[$#classes]};

    print <<EOT;

    return suite;
}

CPPUNIT_TEST_SUITE_NAMED_REGISTRATION($class, "regex.$id");

EOT
}

# finish off the output (C++ interface)
#
sub end_output {
    print <<EOT;

/*
 * A suite containing all the above suites
 */

class regextest : public TestSuite
{
public:
    regextest() : TestSuite("regex") { }
    static Test *suite();
};

Test *regextest::suite()
{
    TestSuite *suite = new regextest;

EOT
    print "    suite->addTest(".$_->[1]."::suite());\n" for @classes;

    print <<EOT;

    return suite;
}

CPPUNIT_TEST_SUITE_NAMED_REGISTRATION(regextest, "regex");
CPPUNIT_TEST_SUITE_REGISTRATION(regextest);
EOT
}

# Parse a tcl string. Handles curly quoting and double quoting.
#
sub parsetcl {
    my ($curly, $quote);
    # recursively defined expression that can parse balanced braces
    # warning: uses experimental features of perl, see perlop(1)
    $curly = qr/\{(?:(?>(?:\\[{}]|[^{}])+)|(??{$curly}))*\}/;
    $quote = qr/"(?:\\"|[^"])*"/;
    my @tokens = shift =~ /($curly|$quote|\S+)/g;

    # now remove braces/quotes and unescape any escapes
    for (@tokens) {
        if (s/^{(.*)}$/$1/) {
            # for curly quoting, only unescape \{ and \}
            s/\\([{}])/$1/g;
        } else {
            s/^"(.*)"$/$1/;

            # unescape any escapes
            my %esc = ( "a" => "\a", "b" => "\b", "f" => "\f",
                        "n" => "\n", "r" => "\r", "t" => "\t",
                        "v" => "\013" );
            my $x = qr/[[:xdigit:]]/;

            s/\\([0-7]{1,3}|x$x+|u$x{1,4}|.)/
                if ($1 =~ m{^([0-7]+)}) {
                    chr(oct($1));
                } elsif ($1 =~ m{^x($x+)}) {
                    pack("C0U", hex($1) & 0xff);
                } elsif ($1 =~ m{^u($x+)}) {
                    pack("C0U", hex($1));
                } elsif ($esc{$1}) {
                    $esc{$1};
                } else {
                    $1;
                }
            /ge;
        }
    }

    return @tokens;
}

# helpers which keep track of whether begin_section has been called, so that
# end_section can be called when appropriate
#
my @doing = ("0", "");
my $in_section = 0;

sub handle_doing {
    end_section if $in_section;
    $in_section = 0;
    @doing = @_;
}

sub handle_test {
    begin_section(@doing) if !$in_section;
    $in_section = 1;
    write_test @_;
}

sub handle_end {
    end_section if $in_section;
    $in_section = 0;
    end_output;
}

# 'main' - start by parsing the command lines options.
#
my $badoption = !@ARGV;
my $utfdefault = $utf;
my $outputname;

for (my $i = 0; $i < @ARGV; ) {
    if ($ARGV[$i] !~ m{^-.}) {
        $i++;
        next;
    }

    if ($ARGV[$i] eq '--') {
        splice @ARGV, $i, 1;
        last;
    }

    if ($ARGV[$i] =~ s{^-(.*)o(.*)$}{-$1}i) {       # -o : output file
        $outputname = $2 || splice @ARGV, $i + 1, 1;
    }

    for (split //, substr($ARGV[$i], 1)) {
        if (/u/i) {                                 # -u : utf-8 output
            $utf = 1;
        } elsif (/w/i) {                            # -w : wide char output
            $utf = 0;
        } else {
            $badoption = 1;
        }
    }

    splice @ARGV, $i, 1;
}

# Display help
#
if ($badoption) {
    my $prog = basename $0;
    my ($w, $u) = (" (default)", "          ");
    ($w, $u) = ($u, $w) if $utfdefault;
    
    print <<EOT;
Usage: $prog [-u|-w] [-o OUTPUT] [FILE...]
Generate test code for wxRegEx from 'reg.test'
Example: $prog -o regex.inc reg.test wxreg.test 

 -w$w   Output will be wide characters.
 -u$u   Output will be UTF-8 encoded.

Input files should be in UTF-8. If no input files are specified input is
read from stdin. If no output file is specified output is written to stdout.
See the comments in reg.test (in src/regex) for details of the input file
format.
EOT
    exit 0;
}

# Open the output file
#
open STDOUT, ">$outputname" if $outputname;

# Read in the files and initially parse just the comments for copyright
# information and instructions on the tests
#
my @input;                  # slurped input files stripped of comments
my $files = "";             # copyright info from the input comments
my $instructions = "";      # test instructions from the input comments

do {
    my $inputname = basename $ARGV[0] if @ARGV;

    # slurp input
    undef $/;
    my $in = <>;

    # remove escaped newlines
    $in =~ s/(?<!\\)\\\n//g;

    # record the copyrights of the input files
    for ($in =~ /^#[\t ]*(.*copyright.*)$/mig) {
        s/[\s:]+/ /g;
        $files .= "  ";
        $files .= $inputname . ": " if $inputname && $inputname ne '-';
        $files .= "$_\n";
    }

    # Parse the comments for instructions on the tests, which look like this:
    #    i    successful match with -indices (used in checking things like
    #         nonparticipating subexpressions)
    if (!$instructions) {
        my $sp = qr{\t|   +};                   # tab or three or more spaces
        my @instructions = $in =~
            /\n(
                (?:
                    \#$sp\S?$sp\S[^\n]+\n       # instruction line
                    (?:\#$sp$sp\S[^\n]+\n)*     # continuation lines (if any)
                )+
            )/gx;

        if (@instructions) {
            $instructions[0] = "Test types:\n$instructions[0]";
            if (@instructions > 1) {
                $instructions[1] = "Flag characters:\n$instructions[1]";
            }
            $instructions = join "\n", @instructions;
            $instructions =~ s/^#([^\t]?)/ $1/mg;
        }
    }

    # @input is the input of all files (stipped of comments)
    $in =~ s/^#.*$//mg;
    push @input, $in;

} while $ARGV[0];

# Make a string naming the generator, the input files and copyright info
#
my $from = "Generated " . localtime() . " by " . basename $0;
$from =~ s/[\s]+/ /g;
if ($files) {
    if ($files =~ /:/) {
        $from .= " from the following files:";
    } else {
        $from .= " from work with the following copyright:";
    }
}
$from = join("\n", $from =~ /(.{0,76}(?:\s|$))/g);  # word-wrap
$from .= "\n$files" if $files;

# Now start to print the code
#
begin_output $from, $instructions;

# numbers for 'extra' sections
my $extra = 1;

for (@input)
{
    # Print the main tests
    #
    # Test lines look like this:
    # m  3  b       {\(a\)b}        ab      ab      a
    # 
    # Also looks for heading lines, e.g.:
    # doing 4 "parentheses"
    #
    for (split "\n") {
        if (/^doing\s+(\S+)\s+(\S.*)/) {
            handle_doing parsetcl "$1 $2";
        } elsif (/^[efimp]\s/) {
            handle_test parsetcl $_;
        }
    }

    # Extra tests
    #
    # The expression below matches something like this:
    #   test reg-33.8 {Bug 505048} {
    #       regexp -inline {\A\s*[^b]*b} ab
    #   } ab
    #   
    # The three subexpressions then return these parts: 
    #   $extras[$i]     = '{Bug 505048}',
    #   $extras[$i + 1] = '-inline {\A\s*[^b]*b} ab'
    #   $extras[$i + 2] = 'ab'
    #
    my @extras = /\ntest\s+\S+\s*(\{.*?\})\s*\{\n       # line 1
                  \s*regexp\s+([^\n]+)\n                # line 2
                  \}\s*(\S[^\n]*)/gx;                   # line 3

    handle_doing "extra_" . $extra++, "checks for bug fixes" if @extras;

    for (my $i = 0; $i < @extras; $i += 3) {
        my $id = $extras[$i];

        # further parse the middle line into options and the rest (i.e. $args)
        my ($opts, $args) = $extras[$i + 1] =~ /^\s*((?:-\S+\s+)*)([^\s-].*)/;

        my @args = parsetcl $args;
        $#args = 1;     # only want the first two

        # now handle the options
        my $test    = $opts =~ /-indices/ ? 'i' : $extras[$i + 2] ? 'm' : 'f';
        my $results = $opts =~ /-inline/ && $test ne 'f' ? $extras[$i+2] : '';

        # get them all in the right order and print
        unshift @args, $test, parsetcl($id), '-';
        push @args, parsetcl(parsetcl($results)) if $results;
        handle_test @args;
    }
}

# finish
#
handle_end;