html5/spec-ja/make.pl

#!/usr/bin/perl
use strict;

my $source_file_name = shift;
my $data_dir_name = q[data/];
my $data_suffix = q[.dat];
my $result_file_name = shift;

sub normalize ($) {
  my $s = shift;
  $s =~ s/\s+/ /g;
  $s =~ s/^ //;
  $s =~ s/ $//g;
  return $s;
} # normalize

sub create_pattern1 ($) {
  my $s = quotemeta shift;
  $s =~ s/\\\*/(.+)/g;
  return $s;
} # create_pattern1

sub replace_pattern2 ($@) {
  my $s = shift;
  my @arg = @_;
  $s =~ s/\$(\d+)/$arg[$1 - 1]/g;
  return $s;
} # replace_pattern2

my %data;
my %pattern;
{
  opendir my $data_dir, $data_dir_name or die "$0: $data_dir_name: $!";
  local $/ = undef;
  for (readdir $data_dir) {
    next if /^\./; # hidden files
    my $data_file_name = qq[$data_dir_name$_];
    next unless $data_file_name =~ /\Q$data_suffix\E$/;
    warn "$data_file_name...\n";
    open my $data_file, '<:utf8', $data_file_name
        or die "$0: $data_file_name: $!";
    my $data = <$data_file>;
    $data =~ s/\x0D?\x0A/\n/g;
    for (split /\n\n+(?=#)/, $data) {
      my ($en, $ja) = split /\n#ja\n/, $_;
      if ($en =~ s/^#en\n//) {
        $data{normalize ($en)} = $ja;
      } elsif ($en =~ s/^#pattern\n//) {
        $pattern{create_pattern1 (normalize ($en))} = $ja;
      }
    }
  }
}
my @pattern = sort {length $b <=> length $a} keys %pattern;

my $source_text;
{
  warn "$source_file_name...\n";
  open my $source_file, '<:utf8', $source_file_name
      or die "$0: $source_file_name: $!";
  local $/ = undef;
  $source_text = <$source_file>;
}

warn "Generating...\n";
$source_text =~ s{(<(?>p(?>re)?|li|d[td]|t[dh]|h[1-6])(?>\s[^>]*)?>)((?>(?!</?(?>p(?>re)?|li|d(?>[tdl]|iv)|t[dh]|h[1-6]|ul|ol)(?>\s[^>]*)?>).)+)}
{
  my ($tag, $text) = ($1, $2);
  my $n_text = normalize ($text);
  my $ja_text = $data{$n_text};
  if (defined $ja_text) {
    $tag . q[<span class=ja-translation lang=ja>] . $ja_text . q[</span>];
  } else {
    my $v = $tag . $text;
    for my $pattern (@pattern) {
      if ($n_text =~ /^$pattern$/) {
        $v = $tag . q[<span class=ja-translation lang=ja>] .
            replace_pattern2 ($pattern{$pattern}, $1, $2, $3, $4, $5) .
            q[</span>];
        last;
      }
    }
    $v;
  }
}ges;
$source_text =~ s{(<(?>link|img|script)\s[^>]+>)}{
  my $tag = $1;
  my $n_text = normalize ($tag);
  my $ja_text = $data{$n_text};
  if (defined $ja_text) {
    $ja_text;
  } else {
    $tag;
  }
}ges;

$source_text =~ s{\[\[([A-Z ]+):([^]]+)\]\]}
{<em class=rfc2119 title="$1">$2</em>}gs;

#$source_text =~ s[<title>][<base href="http://www.whatwg.org/specs/web-apps/current-work/"><title>];

{
  warn "$result_file_name...\n";
  open my $result_file, '>:utf8', $result_file_name
      or die "$0: $result_file_name: $!";
  print $result_file $source_text;
}
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4	wakaba	1.6	my $source_file_name = shift;
5	wakaba	1.1	my $data_dir_name = q[data/];
6			my $data_suffix = q[.dat];
7	wakaba	1.6	my $result_file_name = shift;
8	wakaba	1.1
9			sub normalize ($) {
10			my $s = shift;
11			$s =~ s/\s+/ /g;
12			$s =~ s/^ //;
13			$s =~ s/ $//g;
14			return $s;
15			} # normalize
16
17			sub create_pattern1 ($) {
18			my $s = quotemeta shift;
19	wakaba	1.3	$s =~ s/\\\*/(.+)/g;
20	wakaba	1.1	return $s;
21			} # create_pattern1
22
23			sub replace_pattern2 ($@) {
24			my $s = shift;
25			my @arg = @_;
26			$s =~ s/\$(\d+)/$arg[$1 - 1]/g;
27			return $s;
28			} # replace_pattern2
29
30			my %data;
31			my %pattern;
32			{
33			opendir my $data_dir, $data_dir_name or die "$0: $data_dir_name: $!";
34			local $/ = undef;
35			for (readdir $data_dir) {
36			next if /^\./; # hidden files
37			my $data_file_name = qq[$data_dir_name$_];
38			next unless $data_file_name =~ /\Q$data_suffix\E$/;
39			warn "$data_file_name...\n";
40			open my $data_file, '<:utf8', $data_file_name
41			or die "$0: $data_file_name: $!";
42	wakaba	1.8	my $data = <$data_file>;
43			$data =~ s/\x0D?\x0A/\n/g;
44			for (split /\n\n+(?=#)/, $data) {
45	wakaba	1.1	my ($en, $ja) = split /\n#ja\n/, $_;
46			if ($en =~ s/^#en\n//) {
47			$data{normalize ($en)} = $ja;
48	wakaba	1.7	} elsif ($en =~ s/^#pattern\n//) {
49	wakaba	1.1	$pattern{create_pattern1 (normalize ($en))} = $ja;
50			}
51			}
52			}
53			}
54	wakaba	1.2	my @pattern = sort {length $b <=> length $a} keys %pattern;
55	wakaba	1.1
56			my $source_text;
57			{
58			warn "$source_file_name...\n";
59			open my $source_file, '<:utf8', $source_file_name
60			or die "$0: $source_file_name: $!";
61			local $/ = undef;
62			$source_text = <$source_file>;
63			}
64
65			warn "Generating...\n";
66			$source_text =~ s{(<(?>p(?>re)?\|li\|d[td]\|t[dh]\|h[1-6])(?>\s[^>])?>)((?>(?!</?(?>p(?>re)?\|li\|d(?>[tdl]\|iv)\|t[dh]\|h[1-6]\|ul\|ol)(?>\s[^>])?>).)+)}
67			{
68			my ($tag, $text) = ($1, $2);
69			my $n_text = normalize ($text);
70			my $ja_text = $data{$n_text};
71			if (defined $ja_text) {
72			$tag . q[<span class=ja-translation lang=ja>] . $ja_text . q[</span>];
73			} else {
74			my $v = $tag . $text;
75	wakaba	1.2	for my $pattern (@pattern) {
76	wakaba	1.1	if ($n_text =~ /^$pattern$/) {
77			$v = $tag . q[<span class=ja-translation lang=ja>] .
78			replace_pattern2 ($pattern{$pattern}, $1, $2, $3, $4, $5) .
79			q[</span>];
80	wakaba	1.5	last;
81	wakaba	1.1	}
82			}
83			$v;
84			}
85			}ges;
86			$source_text =~ s{(<(?>link\|img\|script)\s[^>]+>)}{
87			my $tag = $1;
88			my $n_text = normalize ($tag);
89			my $ja_text = $data{$n_text};
90			if (defined $ja_text) {
91			$ja_text;
92			} else {
93			$tag;
94			}
95			}ges;
96
97	wakaba	1.4	$source_text =~ s{\[\[([A-Z ]+):([^]]+)\]\]}
98	wakaba	1.1	{<em class=rfc2119 title="$1">$2</em>}gs;
99
100			#$source_text =~ s[<title>][<base href="http://www.whatwg.org/specs/web-apps/current-work/"><title>];
101
102			{
103			warn "$result_file_name...\n";
104			open my $result_file, '>:utf8', $result_file_name
105			or die "$0: $result_file_name: $!";
106			print $result_file $source_text;
107			}