whatpm/t/testfiles.pl

use strict;

sub execute_test ($$$) {
  my $file_name = shift;
  my $field_props = shift; # {$field_name => {is_prefixed, is_list}}
  my $test_code = shift;

  print STDERR "# $file_name\n";

  my @tests;
  {
    open my $file, '<:utf8', $file_name or die "$0: $file_name: $!";
    local $/ = undef;
    my $content = <$file>;
    $content =~ s/\x0D\x0A/\x0A/g;
    $content =~ tr/\x0D/\x0A/;
    $content =~ s/^\x0A*#//;
    $content =~ s/\x0A+\z//;
    @tests = split /\x0A\x0A#/, $content;
  }

  for (@tests) {
    my %test;
    for my $v (split /\x0A#/, $_) {
      my $field_name = '';
      my @field_opt;
      if ($v =~ s/^([A-Za-z0-9-]+)//) {
        $field_name = $1;
      }
      if ($v =~ s/^([^\x0A]*)\x0A//) {
        push @field_opt, grep {length $_} split /[\x09\x20]+/, $1;
      }

      if ($field_props->{$field_name}->{is_prefixed}) {
        $v =~ s/^\| //;
        $v =~ s/\x0A\| /\x0A/g;
      }
      if ($field_props->{$field_name}->{is_list}) {
        my @v = split /\x0A/, $v;
        my $field_escaped = (@field_opt and $field_opt[-1] eq 'escaped');
        if ($field_escaped) {
          pop @field_opt;
          for (@v) {
            s/\\u([0-9A-Fa-f]{4})/chr hex $1/ge;
            s/\\U([0-9A-Fa-f]{8})/chr hex $1/ge;
          }
        }

        if (defined $test{$field_name}) {
          warn qq[Duplicate #$field_name field (value "$v")];
        } else {
          $test{$field_name} = [\@v, \@field_opt];
        }
      } else {
        my $field_escaped = (@field_opt and $field_opt[-1] eq 'escaped');
        if ($field_escaped) {
          pop @field_opt;
          $v =~ s/\\u([0-9A-Fa-f]{4})/chr hex $1/ge;
          $v =~ s/\\U([0-9A-Fa-f]{8})/chr hex $1/ge;
        }

        if (defined $test{$field_name}) {
          warn qq[Duplicate #$field_name field (value "$v")];
        } else {
          $test{$field_name} = [$v, \@field_opt];
        }
      }
    }

    $test_code->(\%test);
  }
} # execute_test

1;
1	wakaba	1.1	use strict;
2
3			sub execute_test ($$$) {
4			my $file_name = shift;
5			my $field_props = shift; # {$field_name => {is_prefixed, is_list}}
6			my $test_code = shift;
7
8			print STDERR "# $file_name\n";
9
10			my @tests;
11			{
12			open my $file, '<:utf8', $file_name or die "$0: $file_name: $!";
13			local $/ = undef;
14			my $content = <$file>;
15			$content =~ s/\x0D\x0A/\x0A/g;
16			$content =~ tr/\x0D/\x0A/;
17			$content =~ s/^\x0A*#//;
18			$content =~ s/\x0A+\z//;
19			@tests = split /\x0A\x0A#/, $content;
20			}
21
22			for (@tests) {
23			my %test;
24			for my $v (split /\x0A#/, $_) {
25			my $field_name = '';
26			my @field_opt;
27			if ($v =~ s/^([A-Za-z0-9-]+)//) {
28			$field_name = $1;
29			}
30			if ($v =~ s/^([^\x0A]*)\x0A//) {
31			push @field_opt, grep {length $_} split /[\x09\x20]+/, $1;
32			}
33
34			if ($field_props->{$field_name}->{is_prefixed}) {
35			$v =~ s/^\\| //;
36			$v =~ s/\x0A\\| /\x0A/g;
37			}
38			if ($field_props->{$field_name}->{is_list}) {
39			my @v = split /\x0A/, $v;
40			my $field_escaped = (@field_opt and $field_opt[-1] eq 'escaped');
41			if ($field_escaped) {
42			pop @field_opt;
43			for (@v) {
44			s/\\u([0-9A-Fa-f]{4})/chr hex $1/ge;
45			s/\\U([0-9A-Fa-f]{8})/chr hex $1/ge;
46			}
47			}
48
49			if (defined $test{$field_name}) {
50			warn qq[Duplicate #$field_name field (value "$v")];
51			} else {
52			$test{$field_name} = [\@v, \@field_opt];
53			}
54			} else {
55			my $field_escaped = (@field_opt and $field_opt[-1] eq 'escaped');
56			if ($field_escaped) {
57			pop @field_opt;
58			$v =~ s/\\u([0-9A-Fa-f]{4})/chr hex $1/ge;
59			$v =~ s/\\U([0-9A-Fa-f]{8})/chr hex $1/ge;
60			}
61
62			if (defined $test{$field_name}) {
63			warn qq[Duplicate #$field_name field (value "$v")];
64			} else {
65			$test{$field_name} = [$v, \@field_opt];
66			}
67			}
68			}
69
70			$test_code->(\%test);
71			}
72			} # execute_test
73
74			1;