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	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;