#!/usr/bin/perl

use strict;
use lib "blib/lib";

use Regexp::Common qw /RE_comment_ALL/;
use t::Common qw /run_new_tests ww/;

BEGIN {$^W = 0 if $] < 5.006};

use warnings;


# 1. List of tokens.
# 2. List of languages.
my @data   = do {
    no warnings;
    (
        {start_tokens =>  ["\\"],  # No qw here, 5.6.0 parses it incorrectly.
         languages    =>  [qw {ABC Forth}],
        },
        {start_tokens =>  [qw {# //}],
         languages    =>  [qw {Advisor}],
        },
        {start_tokens =>  [qw {--}],
         languages    =>  [qw {Ada Alan Eiffel lua}],
        },
        {start_tokens =>  [qw {;}],
         languages    =>  [qw {Advsys CQL Lisp LOGO M MUMPS REBOL Scheme
                                      SMITH zonefile}],
        },
        {start_tokens =>  [qw {#}],
         languages    =>  [qw {awk fvwm2 Icon m4 mutt Perl Python QML R Ruby
                               shell Tcl}],
        },
        {start_tokens =>  [qw {* ! REM}],
         languages    =>  [[BASIC => 'mvEnterprise']],
        },
        {start_tokens =>  [qw {//}],
         languages    =>  [qw {beta-Juliet Portia Ubercode},
                           q  {Crystal Report}],
        },
        {start_tokens =>  [qw {%}],
         languages    =>  [qw {CLU LaTeX TeX slrn}],
        },
        {start_tokens =>  [qw {!}],
         languages    =>  [qw {Fortran}],
        },
        {start_tokens =>  [qw {NB}],
         languages    =>  [qw {ILLGOL}],
        },
        {start_tokens =>  ["PLEASE NOT", "PLEASE   NOT", "PLEASE N'T", 
                           "DO NOT", "DO     N'T", "DO    NOT",
                           "PLEASE DO NOT", "PLEASE   DO    NOT",
                           "PLEASE  DO  N'T"],
         languages    =>  [qw {INTERCAL}]},
        {start_tokens =>  [qw {NB.}],
         languages    =>  [qw {J}],
        },
        {start_tokens =>  [qw !{!],
         languages    =>  [[qw {Pascal Alice}]],
         end_tokens   =>  [qw !}!],
        },
        {start_tokens =>  [qw {. ;}],
         languages    =>  [qw {PL/B}],
        },
        {start_tokens =>  [qw {`}],
         languages    =>  [qw {Q-BAL}],
        },
        {start_tokens =>  [qw {-- --- -----}],
         languages    =>  [qw {SQL}],   # SQL comments start with /-{2,}/
        },
        {start_tokens =>  ['\\"'], # No qw here, 5.6.0 parses it incorrectly.
         languages    =>  [qw {troff}],
        },
        {start_tokens =>  [qw {"}],
         languages    =>  [qw {vi}],
        },
        {start_tokens =>  [qw {'}],
         languages    =>  [qw {ZZT-OOP}],
        },
    );
};


#
# Extract the markers.
#
# my @tokens = map {@{$$_ {start_tokens}}} @data;
my @tokens;
foreach my $data (@data) {
    if ($$data {end_tokens}) {
        push @tokens =>
              map {[$$data {start_tokens} [$_] =>
                    $$data {end_tokens}   [$_]]} 0 .. $#{$$data {start_tokens}};
    }
    else {
        push @tokens => map {[$_ => "\n"]} @{$$data {start_tokens}}
    }
}


#
# Some basic comments, not including delimiters.
#
my @comments = ("", "This is a comment", "A\tcomment", "Another /* comment");

# Targets, and test suites.
my %targets;
my @tests;
my @bad;

foreach my $token (@tokens) {
    my ($start, $end) = @$token;
    my $pass_key      = "pass_${start}_${end}";
    my $fail_key      = "fail_${start}_${end}";
    my @my_bad;

    $targets {$pass_key} = {
        list   => \@comments,
        query  => sub {$start . $_ [0] . $end},
        wanted => sub {$_, $start, $_ [0], $end},
    };

    # No trailing newline.
    push @bad => map {"$start$_"} @comments;
    # No leading token.
    push @bad => map {"$_$end"} @comments;
    # Double newlines.
    push @my_bad => map {"$start$_$end$end"} @comments;
    # Double comments.
    push @my_bad => map {"$start$_$end" x 2} @comments;
    # Garbage trailing the comments.
    push @my_bad => map {"$start$_$end" . ww (1, 5)} @comments;
    # Garbage leading the comments.
    push @my_bad => map {ww (1, 5) . "$start$_$end"} @comments;

    $targets {$fail_key} = {
        list   => \@my_bad
    }
}

# A few extras.
push @bad => ("/* This is a C comment */",
              "(*  This is a Pascal comment *)",
              "<!-- This is an HTML comment -->");

$targets {bad} = {
    list => \@bad
};

foreach my $entry (@data) {
    my ($start_tokens, $langs) = @$entry {qw /start_tokens languages/};
    my $end_tokens = $$entry {end_tokens} ? $$entry {end_tokens}
                                          : [("\n") x @$start_tokens];

    my @my_tokens = map {[$$start_tokens [$_], $$end_tokens [$_]]}
                         0 .. $#$start_tokens;
    my %my_tokens = map {$_ => 1}
                    map {join _ => $$start_tokens [$_], $$end_tokens [$_]}
                         0 .. $#$start_tokens;

    my   @pass_tokens = map {join _ => "pass", $$start_tokens [$_],
                                               $$end_tokens   [$_]}
                             0 .. $#$start_tokens;


    #
    # Find out what should fail.
    #
    # 1. A global 'bad' list.
    #
    my   @fail_tokens = ("bad");
    #
    # 2. Failures for our tokens.
    #
    push @fail_tokens => map {join _ => "fail", $$start_tokens [$_],
                                                $$end_tokens   [$_]}
                              0 .. $#$start_tokens;
    #
    # 3. Passes for tokens that aren't ours, and don't "fit" ours.
    #
  TOKEN:
    foreach my $token (@tokens) {
        my ($start, $end) = @$token;
        foreach my $my_token (@my_tokens) {
            my ($my_start, $my_end) = @$my_token;
            if ($start =~ /^\Q$my_start\E/ && $end =~ /\Q$my_end\E$/) {
                next TOKEN;
            }
        }
        push @fail_tokens => join _ => pass => @$token;
    }

    foreach my $lang (@$langs) {
        my $name = ref $lang ? join "/" => @$lang : $lang;
        my $re   = ref $lang ? $RE {comment} {$lang -> [0]} {$lang -> [1]}
                             : $RE {comment} {$lang};
        my $sub  = ref $lang ? join "_" => "RE_comment", @$lang
                             : "RE_comment_$lang";
        $sub =~ s/\W/X/g;

        no strict 'refs';
        push @tests => {
            name    => $name,
            regex   => $re,
            sub     => \&$sub,
            pass    => \@pass_tokens,
            fail    => \@fail_tokens,
        };
    }
}

run_new_tests tests        => \@tests,
              targets      => \%targets,
              version_from => 'Regexp::Common::comment',


__END__