File Coverage

blib/lib/Table/Trans.pm
Criterion Covered Total %
statement 50 103 48.5
branch 5 34 14.7
condition n/a
subroutine 11 15 73.3
pod 5 8 62.5
total 71 160 44.3


line stmt bran cond sub pod time code
1             package Table::Trans;
2 4     4   143576 use warnings;
  4         23  
  4         134  
3 4     4   21 use strict;
  4         8  
  4         89  
4 4     4   20 use Carp;
  4         6  
  4         282  
5 4     4   1267 use utf8;
  4         32  
  4         24  
6             require Exporter;
7             our @ISA = qw(Exporter);
8             our @EXPORT_OK = qw/
9             add_trans
10             get_lang_name
11             get_lang_trans
12             read_trans
13             trans_to_json_file
14             write_trans
15             /;
16             our %EXPORT_TAGS = (
17             all => \@EXPORT_OK,
18             );
19             our $VERSION = '0.01';
20              
21 4     4   2350 use Table::Readable '0.05', qw!read_table read_table_hash!;
  4         6113  
  4         588  
22 4     4   1857 use JSON::Create 'write_json';
  4         5169  
  4         232  
23 4     4   1817 use JSON::Parse; # Used for test only in fact.
  4         4987  
  4         4667  
24              
25             my %lang2name;
26              
27             sub add_trans
28             {
29 0     0 0 0 my ($trans, $file) = @_;
30 0         0 my $trans2 = read_trans_table ($file);
31 0         0 for my $id (keys %$trans2) {
32 0 0       0 if ($trans->{$id}) {
33 0         0 warn "$id is duplicated.\n";
34             }
35             else {
36 0         0 $trans->{$id} = $trans2->{$id};
37             }
38             }
39             }
40              
41             sub get_single_trans
42             {
43 0     0 0 0 my ($trans, $id, $lang) = @_;
44 0 0       0 if (! $trans->{$id}) {
45 0         0 croak "Unknown id '$id'";
46             }
47 0 0       0 if (! $trans->{$id}->{$lang}) {
48 0         0 carp "Id '$id' has no translation in $lang";
49             }
50 0         0 return $trans->{$id}->{$lang};
51             }
52              
53              
54              
55             sub get_lang_trans
56             {
57 0     0 1 0 my ($trans, $vars, $lang, $verbose) = @_;
58 0         0 my $varstrans = {};
59 0         0 for my $id (keys %{$trans}) {
  0         0  
60 0 0       0 if ($verbose) {
61 0         0 print "$id, $trans->{$id}{$lang}\n";
62             }
63 0         0 my $value;
64 0 0       0 if ($trans->{$id}{all}) {
65 0         0 $value = $trans->{$id}{all};
66             }
67             else {
68 0         0 $value = $trans->{$id}{$lang};
69             }
70             # The following test checks whether $value is defined because
71             # an empty string may be a valid translation (for example if
72             # something does not need to be translated).
73 0 0       0 if (! defined $value) {
74 0 0       0 if ($verbose) {
75 0         0 warn "No translation for $id for language $lang: substituting English.";
76             }
77 0         0 $value = $trans->{$id}->{en};
78             }
79 0         0 $varstrans->{$id} = $value;
80             }
81 0         0 $vars->{trans} = $varstrans;
82             }
83              
84              
85              
86              
87             sub get_lang_name
88             {
89 1     1 1 82 my ($lang) = @_;
90 1 50       6 if (scalar (keys %lang2name) == 0) {
91 1         3 my $l2nfile = __FILE__;
92 1         4 $l2nfile =~ s!Trans\.pm!l2n.txt!;
93 1         9 my @langs = read_table ($l2nfile);
94 1         27730 for my $lang (@langs) {
95 270         701 $lang2name{$lang->{lang}} = $lang->{name};
96             }
97             }
98 1         4 my $name = $lang2name{$lang};
99 1 50       35 if (! $name) {
100 0         0 $name = $lang;
101             }
102 1         9 return $name;
103             }
104              
105              
106             sub read_trans
107             {
108 2     2 1 13273 my ($input_file, %options) = @_;
109 2         16 my ($trans, $order) = read_table_hash ($input_file, 'id', %options);
110 2         13136 x_link ($trans, $order);
111 2 50       6 if (wantarray ()) {
112 0         0 return ($trans, $order);
113             }
114 2         8 return $trans;
115             }
116              
117             sub trans_to_json_file
118             {
119 1     1 1 132 my ($trans_file, $json_file) = @_;
120 1         4 my $trans = read_trans ($trans_file);
121 1         9 write_json ($json_file, $trans, indent => 1, sort => 1);
122             }
123              
124             sub write_trans
125             {
126 0     0 1 0 my ($trans, $lang_ref, $file_name, $id_order_ref) = @_;
127 0 0       0 if (ref $lang_ref ne 'ARRAY') {
128 0         0 croak "write_trans requires an array reference of languages to print as its second argument.";
129             }
130 0 0       0 open my $output, '>:encoding(utf8)', $file_name or die $!;
131 0         0 my @id_order;
132 0 0       0 if ($id_order_ref) {
133 0         0 @id_order = @{$id_order_ref};
  0         0  
134             }
135             else {
136 0         0 warn "No order supplied.\n";
137 0         0 @id_order = keys %$trans;
138             }
139 0         0 for my $id (@id_order) {
140 0         0 print $output "id: $id\n";
141 0         0 for my $lang (@$lang_ref) {
142 0         0 my $t = $trans->{$id}->{$lang};
143 0 0       0 if (! $t) {
144 0         0 $t = $trans->{$id}->{en};
145             }
146 0 0       0 if (! $t) {
147 0         0 croak "Translation $id does not have an English translation.";
148             }
149 0         0 $t =~ s/\s+$//;
150 0         0 print $output "%%$lang:\n$t\n%%\n";
151             }
152 0         0 print $output "\n";
153             }
154 0         0 close $output;
155             }
156              
157             my $x_lang_re = qr/\{\{(\w+)\}\}/;
158              
159             sub x_link
160             {
161 2     2 0 8 my ($trans_ref, $order) = @_;
162             # X-trans links to copy text from one bit of the translation to another.
163 2         6 for my $id (@$order) {
164 4         10 my $trans = $trans_ref->{$id};
165            
166 4         12 for my $lang (keys %$trans) {
167             # Check the links go somewhere
168 14         75 while ($trans->{$lang} =~ /$x_lang_re/g) {
169 1         19 my $w = $1;
170 1         3 my $t = $trans_ref->{$w}{all};
171 1 50       4 if (! $t) {
172 1         3 $t = $trans_ref->{$w}{$lang};
173             }
174 1 50       3 if (! $t) {
175 0         0 die "Bad X-trans {{$w}} in $id for language id '$lang'.\n";
176             }
177 1         19 $trans->{$lang} =~ s/\{\{$w\}\}/$t/g;
178             }
179             }
180             }
181             }
182              
183             1;