#!/usr/bin/perl

use strict;
use utf8;
use warnings;

our $SRC = "data/IdnaTest.txt";
open IdnaTest, '<', $SRC || die "cannot open $SRC: $!";
binmode IdnaTest, ':utf8';

my @tests;

my $line = 0;
while(<IdnaTest>) {
  chomp; ++$line;
  s/\s*#.*//; next if !m/\S/;

  my @c = ($line, split /;/);
  foreach(@c) { s/^\s+//; s/\s+$//; };

  die "format error: '$_' $#c <@c>" if $#c < 4;
  die "unknown test type: $c[1]" if $c[1] !~ m/^(B|N|T)$/;
  
  push @tests, \@c;
}

die "no tests" unless @tests;

write_test('', 		'unicode', 3, { 'TransitionalProcessing' => 0, }, @tests);
write_test('', 		'ascii', , 4, { 'TransitionalProcessing' => 0, }, grep { $_->[1] =~ m/B|N/ } @tests);
write_test('-trans',    'ascii', , 4, { 'TransitionalProcessing' => 1, }, grep { $_->[1] =~ m/B|T/ } @tests);
exit(0);

sub write_test {
  my($type, $to, $column, $para, $min_perl) = splice @_,0,4;

  my $fn = "t/uts46_to_$to$type.t";

  print STDERR "generating $fn\n" if -t STDERR;

  open STDOUT, ">", $fn || die "cannot open $fn: $!";
  binmode STDOUT, ":utf8";
  
  my $c = $#_ + 1;

  print <<__EOF;
# *** DO NOT EDIT *** generated file *** DO NOT EDIT ***
#
# generated by $0 from $SRC
# see repository at http://github.com/cfaerber/Net-IDN-Encode for source files
#
use strict;
use utf8;
use warnings;

BEGIN {
  binmode STDOUT, ':utf8';
  binmode STDERR, ':utf8';
}

use Test::More tests => $c + 1;
use Test::NoWarnings;

use Net::IDN::UTS46 (':all');

no warnings 'utf8';

__EOF
  print "my %p = (".qhash(%{$para}).");\n\n";

  foreach (@_) {
    my $line = $_->[0];
    my $src  = $_->[2];
    my $dest = $_->[$column];

    my $src_u8  = parse_str($src);
    my $dest_u8 = parse_str($dest);

    $dest = $src if $dest eq '' && ($src_u8 !~ m/^\p{Join_Control}$/); # ouch
    my $err = '';

    my $com = "to_$to('".$src."')";

    if($dest =~ m/^\[(.*)\]$/) {
      $dest = undef;
      $com .= " throws error $1";
    }

    my $l_u8 = join '-', map { parse_str($_) } @{$_};

    my $min_perl = undef;
    my $TODO = undef;

    if(!defined $dest)					{ ;; } # error is ok
    if(($l_u8 =~ m/\P{Assigned}/) && (defined $dest))	{ $min_perl = -1 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 6.0}/})	{ $min_perl = -1 }	# don't know
    elsif(eval{$l_u8 =~ m/\P{Present_In: 5.2}/})	{ $min_perl = 5.014 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 5.1}/})	{ $min_perl = 5.012 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 5.0}/})	{ $min_perl = 5.010_001 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 4.1}/})	{ $min_perl = 5.010 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 4.0.1}/})	{ $min_perl = 5.008_007 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 4.0}/})	{ $min_perl = 5.008_004 }
    elsif(eval{$l_u8 =~ m/\P{Present_In: 3.2}/})	{ $min_perl = 5.008_001 };

    if(lc($src) eq 'xn--0.pt' and $to eq 'unicode')	{ $TODO = 'to be debugged'; }

    $com .= " [$SRC:$line]";

    if(defined $TODO) {
        print 'TODO: { local $TODO = "'.quotemeta($TODO).'"; ';
    }
    elsif(defined $min_perl) {
       if($min_perl < 0) {
        print 'TODO: { local $TODO = "test file was generated on perl '.$].', which is too old"; ';
       } else {
         print 'SKIP: { skip "requires perl '.$min_perl.', this is only perl $]", 1 if $] < '.$min_perl.'; ';
       }
    }

    print "is(eval{uts46_to_$to(", qstr($src), ", %p)},\t", qstr($dest), ',', "\t", '"', quotemeta($com), '"', ")",' or ($@ and diag($@))',";";
    if(defined($TODO) || defined($min_perl)) {
      print ' }';
    }

    print "\n";
  }
  print "\n\nexit(0);\n";

  close STDOUT;
}

sub qhash {
  my %h = @_; my $s = '';
  foreach(sort keys %h) {
    $s .= ', ' if $s;
    $s .= qstr($_);
    $s .= ' => '.qstr($h{$_});
  }
  return $s;
}

sub parse_str {
  my $s = shift;
  return 'undef' if !defined $s;
  $s =~ s/\\u(D[89AB][[:xdigit:]]{2})\\u(D[CDEF][[:xdigit:]]{2})/ chr(0x10000 + (hex($1)&0x3FF)*0x400 + (hex($2)&0x3FF)) /gei;
  $s =~ s/\\u([[:xdigit:]]{4})/ chr(hex $1) /gei;
  return $s;
}

sub qstr {
  my $s = shift;
  return 'undef' if !defined $s;
  $s =~ s/([\\\$\@\"])/\\$1/g;
  $s =~ s/\\\\u(D[89AB][[:xdigit:]]{2})\\\\u(D[CDEF][[:xdigit:]]{2})/
	sprintf('\x{%04X}', 0x10000 + (hex($1)&0x3FF)*0x400 + (hex($2)&0x3FF)) /gei;
  $s =~ s/\\\\u([[:xdigit:]]{4})/\\x{$1}/gi;
  return '"'. $s. '"';
}
